summaryrefslogtreecommitdiffstats
path: root/Tools/scripts/mailerdaemon.py
blob: aeb451e942ded5312ac18e1fdd9d2efcc379a830 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
#!/usr/bin/env python3
"""Classes to parse mailer-daemon messages."""

import calendar
import email.message
import re
import os
import sys


class Unparseable(Exception):
    pass


class ErrorMessage(email.message.Message):
    def __init__(self):
        email.message.Message.__init__(self)
        self.sub = ''

    def is_warning(self):
        sub = self.get('Subject')
        if not sub:
            return 0
        sub = sub.lower()
        if sub.startswith('waiting mail'):
            return 1
        if 'warning' in sub:
            return 1
        self.sub = sub
        return 0

    def get_errors(self):
        for p in EMPARSERS:
            self.rewindbody()
            try:
                return p(self.fp, self.sub)
            except Unparseable:
                pass
        raise Unparseable

# List of re's or tuples of re's.
# If a re, it should contain at least a group (?P<email>...) which
# should refer to the email address.  The re can also contain a group
# (?P<reason>...) which should refer to the reason (error message).
# If no reason is present, the emparse_list_reason list is used to
# find a reason.
# If a tuple, the tuple should contain 2 re's.  The first re finds a
# location, the second re is repeated one or more times to find
# multiple email addresses.  The second re is matched (not searched)
# where the previous match ended.
# The re's are compiled using the re module.
emparse_list_list = [
    'error: (?P<reason>unresolvable): (?P<email>.+)',
    ('----- The following addresses had permanent fatal errors -----\n',
     '(?P<email>[^ \n].*)\n( .*\n)?'),
    'remote execution.*\n.*rmail (?P<email>.+)',
    ('The following recipients did not receive your message:\n\n',
     ' +(?P<email>.*)\n(The following recipients did not receive your message:\n\n)?'),
    '------- Failure Reasons  --------\n\n(?P<reason>.*)\n(?P<email>.*)',
    '^<(?P<email>.*)>:\n(?P<reason>.*)',
    '^(?P<reason>User mailbox exceeds allowed size): (?P<email>.+)',
    '^5\\d{2} <(?P<email>[^\n>]+)>\\.\\.\\. (?P<reason>.+)',
    '^Original-Recipient: rfc822;(?P<email>.*)',
    '^did not reach the following recipient\\(s\\):\n\n(?P<email>.*) on .*\n +(?P<reason>.*)',
    '^ <(?P<email>[^\n>]+)> \\.\\.\\. (?P<reason>.*)',
    '^Report on your message to: (?P<email>.*)\nReason: (?P<reason>.*)',
    '^Your message was not delivered to +(?P<email>.*)\n +for the following reason:\n +(?P<reason>.*)',
    '^ was not +(?P<email>[^ \n].*?) *\n.*\n.*\n.*\n because:.*\n +(?P<reason>[^ \n].*?) *\n',
    ]
# compile the re's in the list and store them in-place.
for i in range(len(emparse_list_list)):
    x = emparse_list_list[i]
    if type(x) is type(''):
        x = re.compile(x, re.MULTILINE)
    else:
        xl = []
        for x in x:
            xl.append(re.compile(x, re.MULTILINE))
        x = tuple(xl)
        del xl
    emparse_list_list[i] = x
    del x
del i

# list of re's used to find reasons (error messages).
# if a string, "<>" is replaced by a copy of the email address.
# The expressions are searched for in order.  After the first match,
# no more expressions are searched for.  So, order is important.
emparse_list_reason = [
    r'^5\d{2} <>\.\.\. (?P<reason>.*)',
    '<>\.\.\. (?P<reason>.*)',
    re.compile(r'^<<< 5\d{2} (?P<reason>.*)', re.MULTILINE),
    re.compile('===== stderr was =====\nrmail: (?P<reason>.*)'),
    re.compile('^Diagnostic-Code: (?P<reason>.*)', re.MULTILINE),
    ]
emparse_list_from = re.compile('^From:', re.IGNORECASE|re.MULTILINE)
def emparse_list(fp, sub):
    data = fp.read()
    res = emparse_list_from.search(data)
    if res is None:
        from_index = len(data)
    else:
        from_index = res.start(0)
    errors = []
    emails = []
    reason = None
    for regexp in emparse_list_list:
        if type(regexp) is type(()):
            res = regexp[0].search(data, 0, from_index)
            if res is not None:
                try:
                    reason = res.group('reason')
                except IndexError:
                    pass
                while 1:
                    res = regexp[1].match(data, res.end(0), from_index)
                    if res is None:
                        break
                    emails.append(res.group('email'))
                break
        else:
            res = regexp.search(data, 0, from_index)
            if res is not None:
                emails.append(res.group('email'))
                try:
                    reason = res.group('reason')
                except IndexError:
                    pass
                break
    if not emails:
        raise Unparseable
    if not reason:
        reason = sub
        if reason[:15] == 'returned mail: ':
            reason = reason[15:]
        for regexp in emparse_list_reason:
            if type(regexp) is type(''):
                for i in range(len(emails)-1,-1,-1):
                    email = emails[i]
                    exp = re.compile(re.escape(email).join(regexp.split('<>')), re.MULTILINE)
                    res = exp.search(data)
                    if res is not None:
                        errors.append(' '.join((email.strip()+': '+res.group('reason')).split()))
                        del emails[i]
                continue
            res = regexp.search(data)
            if res is not None:
                reason = res.group('reason')
                break
    for email in emails:
        errors.append(' '.join((email.strip()+': '+reason).split()))
    return errors

EMPARSERS = [emparse_list]

def sort_numeric(a, b):
    a = int(a)
    b = int(b)
    if a < b:
        return -1
    elif a > b:
        return 1
    else:
        return 0

def parsedir(dir, modify):
    os.chdir(dir)
    pat = re.compile('^[0-9]*$')
    errordict = {}
    errorfirst = {}
    errorlast = {}
    nok = nwarn = nbad = 0

    # find all numeric file names and sort them
    files = list(filter(lambda fn, pat=pat: pat.match(fn) is not None, os.listdir('.')))
    files.sort(sort_numeric)

    for fn in files:
        # Lets try to parse the file.
        fp = open(fn)
        m = email.message_from_file(fp, _class=ErrorMessage)
        sender = m.getaddr('From')
        print('%s\t%-40s\t'%(fn, sender[1]), end=' ')

        if m.is_warning():
            fp.close()
            print('warning only')
            nwarn = nwarn + 1
            if modify:
                os.rename(fn, ','+fn)
##              os.unlink(fn)
            continue

        try:
            errors = m.get_errors()
        except Unparseable:
            print('** Not parseable')
            nbad = nbad + 1
            fp.close()
            continue
        print(len(errors), 'errors')

        # Remember them
        for e in errors:
            try:
                mm, dd = m.getdate('date')[1:1+2]
                date = '%s %02d' % (calendar.month_abbr[mm], dd)
            except:
                date = '??????'
            if e not in errordict:
                errordict[e] = 1
                errorfirst[e] = '%s (%s)' % (fn, date)
            else:
                errordict[e] = errordict[e] + 1
            errorlast[e] = '%s (%s)' % (fn, date)

        fp.close()
        nok = nok + 1
        if modify:
            os.rename(fn, ','+fn)
##          os.unlink(fn)

    print('--------------')
    print(nok, 'files parsed,',nwarn,'files warning-only,', end=' ')
    print(nbad,'files unparseable')
    print('--------------')
    list = []
    for e in errordict.keys():
        list.append((errordict[e], errorfirst[e], errorlast[e], e))
    list.sort()
    for num, first, last, e in list:
        print('%d %s - %s\t%s' % (num, first, last, e))

def main():
    modify = 0
    if len(sys.argv) > 1 and sys.argv[1] == '-d':
        modify = 1
        del sys.argv[1]
    if len(sys.argv) > 1:
        for folder in sys.argv[1:]:
            parsedir(folder, modify)
    else:
        parsedir('/ufs/jack/Mail/errorsinbox', modify)

if __name__ == '__main__' or sys.argv[0] == __name__:
    main()
r \ + "cannot change AutoPathSync while Safe Base slaves exist" + } + } + + set AutoPathSync {*}$args +} + namespace eval ::safe { - # internal variables + # internal variables (must not begin with "S") + + # AutoPathSync + # + # Set AutoPathSync to 0 to give a slave's ::auto_path the same meaning as + # for an unsafe interpreter: the package command will search its directories + # and first-level subdirectories for pkgIndex.tcl files; the auto-loader + # will search its directories for tclIndex files. The access path and + # module path will be maintained as separate values, and ::auto_path will + # not be updated when the user calls ::safe::interpAddToAccessPath to add to + # the access path. If the user specifies an access path when calling + # interpCreate, interpInit or interpConfigure, it is the user's + # responsibility to define the slave's auto_path. If these commands are + # called with no (or empty) access path, the slave's auto_path will be set + # to a tokenized form of the master's auto_path, and these directories and + # their first-level subdirectories will be added to the access path. + # + # Set to 1 for "traditional" behavior: a slave's entire access path and + # module path are copied to its ::auto_path, which is updated whenever + # the user calls ::safe::interpAddToAccessPath to add to the access path. + variable AutoPathSync 1 # Log command, set via 'setLogCmd'. Logging is disabled when empty. variable Log {} diff --git a/tests/safe.test b/tests/safe.test index 11ad2a9..fac52f1 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -17,6 +17,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +testConstraint AutoSyncDefined 1 + foreach i [interp slaves] { interp delete $i } @@ -180,22 +182,46 @@ test safe-6.3 {test safe interpreters knowledge of the world} { # leaking infos, but they still do... # high level general test -test safe-7.1 {tests that everything works at high level} -body { +test safe-7.1 {tests that everything works at high level with conventional AutoPathSync} -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::SetAutoPathSync] + safe::SetAutoPathSync 1 + } + set i [safe::interpCreate] + +} -body { # no error shall occur: # (because the default access_path shall include 1st level sub dirs so # package require in a slave works like in the master) set v [interp eval $i {package require http 2}] # no error shall occur: interp eval $i {http::config} - safe::interpDelete $i set v +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::SetAutoPathSync $SyncVal_TMP + } } -match glob -result 2.* -test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body { +test safe-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync} -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::SetAutoPathSync] + safe::SetAutoPathSync 1 + } else { + set SyncVal_TMP 1 + } +} -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] - # should add as p1 + # should add as p* (not p1 if master has a module path) set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] # an error shall occur (http is not anymore in the secure 0-level # provided deep path) @@ -203,6 +229,10 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body { [catch {interp eval $i {package require http 1}} msg] $msg \ [safe::interpConfigure $i]\ [safe::interpDelete $i] +} -cleanup { + if {$SyncExists} { + safe::SetAutoPathSync $SyncVal_TMP + } } -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" test safe-7.3 {check that safe subinterpreters work} { set i [safe::interpCreate] @@ -210,6 +240,64 @@ test safe-7.3 {check that safe subinterpreters work} { list [interp eval $j {join {o k} ""}] [safe::interpDelete $i] [interp exists $j] } {ok {} 0} +test safe-7.4 {tests specific path and positive search with conventional AutoPathSync} -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::SetAutoPathSync] + safe::SetAutoPathSync 1 + } else { + set SyncVal_TMP 1 + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if master has a module path) + set token2 [safe::interpAddToAccessPath $i [file join [info library] http1.0]] + # this time, unlike test safe-7.2, http 1.0 should be found + list $token1 $token2 \ + [catch {interp eval $i {package require http 1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] + # Note that the glob match elides directories (those from the module path) + # other than the first and last in the access path. +} -cleanup { + if {$SyncExists} { + safe::SetAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {}} {}" + +test safe-7.5 {tests positive and negative module loading with conventional AutoPathSync} -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::SetAutoPathSync] + safe::SetAutoPathSync 1 + } + + set i [safe::interpCreate] + + interp eval $i { + package forget platform::shell + package forget platform + catch {namespace delete ::platform} + } +} -body { + # Should raise an error (module ancestor directory issue) + set code1 [catch {interp eval $i {package require shell}} msg1] + # Should not raise an error + set code2 [catch {interp eval $i {package require platform::shell}} msg2] + return [list $code1 $msg1 $code2] +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::SetAutoPathSync $SyncVal_TMP + } +} -result {1 {can't find package shell} 0} + # test source control on file name set i "a" test safe-8.1 {safe source control on file} -setup { @@ -403,6 +491,8 @@ test safe-9.6 {interpConfigure widget like behaviour} -body { safe::interpConfigure $i]\ [safe::interpConfigure $i -deleteHook toto -nosta -nested 0 safe::interpConfigure $i] +} -cleanup { + safe::interpDelete $i } -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} catch {teststaticpkg Safepkg1 0 0} @@ -831,6 +921,247 @@ test safe-16.4 {Bug 3529949: defang ~user in globs} -setup { } -cleanup { safe::interpDelete $i } -result {} + +### 17. The first element in a slave's ::auto_path and access path must be [info library]. + +test safe-17.1 {Check that first element of slave auto_path (and access path) is Tcl Library} -setup { + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib1 $lib2] + + set i [safe::interpCreate] +} -body { + set autoList {} + set token [lindex [$i eval set ::auto_path] 0] + set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] + set accessList [lindex [safe::interpConfigure $i -accessPath] 1] + return [list [lindex $accessList 0] $auto0] +} -cleanup { + set ::auto_path $::auto_TMP + safe::interpDelete $i +} -result [list [info library] [info library]] + +test safe-17.2 {Check that first element of slave auto_path (and access path) is Tcl Library, even if not true for master} -setup { + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib2 $lib1] + # Unexpected order, should be reversed in the slave + + set i [safe::interpCreate] +} -body { + set autoList {} + set token [lindex [$i eval set ::auto_path] 0] + set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] + set accessList [lindex [safe::interpConfigure $i -accessPath] 1] + + return [list [lindex $accessList 0] $auto0] +} -cleanup { + set ::auto_path $::auto_TMP + safe::interpDelete $i +} -result [list [info library] [info library]] + +### 18. Tests for AutoSyncDefined without conventional AutoPathSync, i.e. with AutoPathSync off. + +test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without conventional AutoPathSync} -constraints AutoSyncDefined -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::SetAutoPathSync] + safe::SetAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined} + } + + # Without AutoPathSync, we need a more complete auto_path, because the slave will use the same value. + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib1 $lib2] + + set i [safe::interpCreate] +} -body { + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs + # so package require in a slave works like in the master) + set v [interp eval $i {package require http 1}] + # no error shall occur: + interp eval $i {http_config} + set v +} -cleanup { + set ::auto_path $::auto_TMP + safe::interpDelete $i + if {$SyncExists} { + safe::SetAutoPathSync $SyncVal_TMP + } +} -result 1.0 + +test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync} -constraints AutoSyncDefined -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::SetAutoPathSync] + safe::SetAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined} + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + set auto1 [interp eval $i {set ::auto_path}] + interp eval $i {set ::auto_path [list {$p(:0:)}]} + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p1 + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + # an error shall occur (http is not anymore in the secure 0-level + # provided deep path) + list $auto1 $token1 $token2 \ + [catch {interp eval $i {package require http 1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] +} -cleanup { + if {$SyncExists} { + safe::SetAutoPathSync $SyncVal_TMP + } +} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" + +test safe-18.3 {Check that default auto_path is the same as in the master interpreter without conventional AutoPathSync} -constraints AutoSyncDefined -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::SetAutoPathSync] + safe::SetAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined} + } + + set i [safe::interpCreate] + +} -body { + # This file's header sets auto_path to a single directory [info library], + # which is the one required by Safe Base to be present & first in the list. + + set ap {} + foreach token [$i eval set ::auto_path] { + lappend ap [dict get [set ::safe::S${i}(access_path,map)] $token] + } + return $ap +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::SetAutoPathSync $SyncVal_TMP + } +} -result [set ::auto_path] + +test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync} -constraints AutoSyncDefined -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::SetAutoPathSync] + safe::SetAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined} + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + + # should not have been set by Safe Base: + set auto1 [interp eval $i {set ::auto_path}] + + interp eval $i {set ::auto_path [list {$p(:0:)}]} + + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + + # should add as p* (not p1 if master has a module path) + set token2 [safe::interpAddToAccessPath $i [file join [info library] http1.0]] + + # should not have been changed by Safe Base: + set auto2 [interp eval $i {set ::auto_path}] + + # This time, unlike test safe-18.2 and the try above, http 1.0 should be found: + list $auto1 $auto2 $token1 $token2 \ + [catch {interp eval $i {package require http 1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] +} -cleanup { + if {$SyncExists} { + safe::SetAutoPathSync $SyncVal_TMP + } +} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {}} {}" + +test safe-18.5 {cf. safe-7.5 - tests positive and negative module loading without conventional AutoPathSync} -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::SetAutoPathSync] + safe::SetAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined} + } + + set i [safe::interpCreate] + + interp eval $i { + package forget platform::shell + package forget platform + catch {namespace delete ::platform} + } +} -body { + # Should raise an error (tests module ancestor directory rule) + set code1 [catch {interp eval $i {package require shell}} msg1] + # Should not raise an error + set code2 [catch {interp eval $i {package require platform::shell}} msg2] + return [list $code1 $msg1 $code2] +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::SetAutoPathSync $SyncVal_TMP + } +} -result {1 {can't find package shell} 0} + +### 19. Test tokenization of directories available to a slave. + +test safe-19.1 {Check that each directory of the default auto_path is a valid token} -setup { + set i [safe::interpCreate] +} -body { + set badTokens {} + foreach dir [$i eval {set ::auto_path}] { + if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { + # Match - OK - token has expected form + } else { + # No match - possibly an ordinary path has not been tokenized + lappend badTokens $dir + } + } + set badTokens +} -cleanup { + safe::interpDelete $i +} -result {} + +test safe-19.2 {Check that each directory of the module path is a valid token} -setup { + set i [safe::interpCreate] +} -body { + set badTokens {} + foreach dir [$i eval {::tcl::tm::path list}] { + if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { + # Match - OK - token has expected form + } else { + # No match - possibly an ordinary path has not been tokenized + lappend badTokens $dir + } + } + set badTokens +} -cleanup { + safe::interpDelete $i +} -result {} + set ::auto_path $saveAutoPath # cleanup -- cgit v0.12 From 40970bda3738a098f7adea63dcaed2ccb4ef15c0 Mon Sep 17 00:00:00 2001 From: kjnash Date: Thu, 9 Jul 2020 10:11:35 +0000 Subject: Add code for -autoPath option in Safe Base. --- library/safe.tcl | 150 ++++++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 132 insertions(+), 18 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index dcf3c82..a1fadb1 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -78,18 +78,29 @@ proc ::safe::InterpNested {} { # Interface/entry point function and front end for "Create" proc ::safe::interpCreate {args} { + variable AutoPathSync + if {$AutoPathSync} { + set autoPath {} + } set Args [::tcl::OptKeyParse ::safe::interpCreate $args] + + set withAutoPath [::tcl::OptProcArgGiven -autoPath] InterpCreate $slave $accessPath \ - [InterpStatics] [InterpNested] $deleteHook + [InterpStatics] [InterpNested] $deleteHook $autoPath $withAutoPath } proc ::safe::interpInit {args} { + variable AutoPathSync + if {$AutoPathSync} { + set autoPath {} + } set Args [::tcl::OptKeyParse ::safe::interpIC $args] if {![::interp exists $slave]} { return -code error "\"$slave\" is not an interpreter" } + set withAutoPath [::tcl::OptProcArgGiven -autoPath] InterpInit $slave $accessPath \ - [InterpStatics] [InterpNested] $deleteHook + [InterpStatics] [InterpNested] $deleteHook $autoPath $withAutoPath } # Check that the given slave is "one of us" @@ -115,6 +126,7 @@ proc ::safe::CheckInterp {slave} { # So this will be hopefully written and some integrated with opt1.0 # (hopefully for tcl8.1 ?) proc ::safe::interpConfigure {args} { + variable AutoPathSync switch [llength $args] { 1 { # If we have exactly 1 argument the semantic is to return all @@ -125,11 +137,17 @@ proc ::safe::interpConfigure {args} { CheckInterp $slave namespace upvar ::safe S$slave state - return [join [list \ + set TMP [list \ [list -accessPath $state(access_path)] \ [list -statics $state(staticsok)] \ [list -nested $state(nestedok)] \ - [list -deleteHook $state(cleanupHook)]]] + [list -deleteHook $state(cleanupHook)] \ + ] + if {!$AutoPathSync} { + set SLAP [DetokPath $slave [$slave eval set ::auto_path]] + lappend TMP [list -autoPath $SLAP] + } + return [join $TMP] } 2 { # If we have exactly 2 arguments the semantic is a "configure @@ -154,6 +172,14 @@ proc ::safe::interpConfigure {args} { -accessPath { return [list -accessPath $state(access_path)] } + -autoPath { + if {$AutoPathSync} { + return -code error "unknown flag $name (bug)" + } else { + set SLAP [DetokPath $slave [$slave eval set ::auto_path]] + return [list -autoPath $SLAP] + } + } -statics { return [list -statics $state(staticsok)] } @@ -194,9 +220,17 @@ proc ::safe::interpConfigure {args} { if {![::tcl::OptProcArgGiven -accessPath]} { set doreset 1 set accessPath $state(access_path) + # BUG? is doreset the wrong way round? } else { set doreset 0 } + if {(!$AutoPathSync) && (![::tcl::OptProcArgGiven -autoPath])} { + set SLAP [DetokPath $slave [$slave eval set ::auto_path]] + set autoPath $SLAP + } elseif {$AutoPathSync} { + set autoPath {} + } else { + } if { ![::tcl::OptProcArgGiven -statics] && ![::tcl::OptProcArgGiven -noStatics] @@ -217,7 +251,9 @@ proc ::safe::interpConfigure {args} { set deleteHook $state(cleanupHook) } # we can now reconfigure : - InterpSetConfig $slave $accessPath $statics $nested $deleteHook + set withAutoPath [::tcl::OptProcArgGiven -autoPath] + set res [InterpSetConfig $slave $accessPath $statics $nested $deleteHook $autoPath $withAutoPath] +puts stderr [list changed_map $res do_reset $doreset] # auto_reset the slave (to completly synch the new access_path) if {$doreset} { if {[catch {::interp eval $slave {auto_reset}} msg]} { @@ -263,6 +299,8 @@ proc ::safe::InterpCreate { staticsok nestedok deletehook + autoPath + withAutoPath } { # Create the slave. if {$slave ne ""} { @@ -274,7 +312,7 @@ proc ::safe::InterpCreate { Log $slave "Created" NOTICE # Initialize it. (returns slave name) - InterpInit $slave $access_path $staticsok $nestedok $deletehook + InterpInit $slave $access_path $staticsok $nestedok $deletehook $autoPath $withAutoPath } # @@ -290,8 +328,9 @@ proc ::safe::InterpCreate { # access_path, to make the first directory in the path suitable for use as # tcl_library, and (if ![SetAutoPathSync]), to set the slave's ::auto_path. -proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { +proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook autoPath withAutoPath} { global auto_path + variable AutoPathSync # determine and store the access path if empty if {$access_path eq ""} { @@ -321,11 +360,18 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # so by default it works the same). set access_path [AddSubDirs $access_path] } else { - set raw_auto_path {} + set raw_auto_path $autoPath + } + + if {$withAutoPath} { + set raw_auto_path $autoPath } Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\ nestedok=$nestedok deletehook=($deletehook)" NOTICE + if {!$AutoPathSync} { + Log $slave "Setting auto_path=($raw_auto_path)" NOTICE + } namespace upvar ::safe S$slave state @@ -335,7 +381,11 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # We save the virtual form separately as well, as syncing it with the # slave has to be defered until the necessary commands are present for # setup. - +if {[info exists state(access_path,map)]} { + set old_map_access_path $state(access_path,map) +} else { + set old_map_access_path {} +} set norm_access_path {} set slave_access_path {} set map_access_path {} @@ -352,7 +402,8 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { incr i } - # Set the slave auto_path. + # Set the slave auto_path to a tokenized raw_auto_path. + # Silently ignore any directories that are not in the access path. # If [SetAutoPathSync], SyncAccessPath will overwrite this value with the # full access path. # If ![SetAutoPathSync], Safe Base code will not change this value. @@ -364,6 +415,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { } ::interp eval $slave [list set auto_path $tokens_auto_path] + # Add the tcl::tm directories to the access path. set morepaths [::tcl::tm::list] set firstpass 1 while {[llength $morepaths]} { @@ -413,23 +465,50 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { set state(cleanupHook) $deletehook SyncAccessPath $slave + + set result [expr {[lrange $map_access_path 0 end] ne [lrange $old_map_access_path 0 end]}] + return $result +} + + +# +# DetokPath: +# Convert tokens to directories where possible. +# Leave undefined tokens unconverted. They are +# nonsense in both the slave and the master. +# +proc ::safe::DetokPath {slave tokenPath} { + namespace upvar ::safe S$slave state + + set slavePath {} + foreach token $tokenPath { + if {[dict exists $state(access_path,map) $token]} { + lappend slavePath [dict get $state(access_path,map) $token] + } else { + lappend slavePath $token + } + } + return $slavePath } # # -# FindInAccessPath: +# interpFindInAccessPath: # Search for a real directory and returns its virtual Id (including the # "$") +# +# When debugging, use TranslatePath for the inverse operation. proc ::safe::interpFindInAccessPath {slave path} { namespace upvar ::safe S$slave state if {![dict exists $state(access_path,remap) $path]} { - return -code error "$path not found in access path $access_path" + return -code error "$path not found in access path" } return [dict get $state(access_path,remap) $path] } + # # addToAccessPath: # add (if needed) a real directory to access path and return its @@ -465,9 +544,11 @@ proc ::safe::InterpInit { staticsok nestedok deletehook + autoPath + withAutoPath } { # Configure will generate an access_path when access_path is empty. - InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook + InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook $autoPath $withAutoPath # NB we need to add [namespace current], aliases are always absolute # paths. @@ -671,6 +752,7 @@ proc ::safe::SyncAccessPath {slave} { ::interp eval $slave [list \ set tcl_library [lindex $slave_access_path 0]] + return } # Returns the virtual token for directory number N. @@ -1109,16 +1191,21 @@ proc ::safe::Setup {} { # Setup the arguments parsing # #### + variable AutoPathSync # Share the descriptions - set temp [::tcl::OptKeyRegister { + set OptList { {-accessPath -list {} "access path for the slave"} {-noStatics "prevent loading of statically linked pkgs"} {-statics true "loading of statically linked pkgs"} {-nestedLoadOk "allow nested loading"} {-nested false "nested loading"} {-deleteHook -script {} "delete hook"} - }] + } + if {!$AutoPathSync} { + lappend OptList {-autoPath -list {} "::auto_path for the slave"} + } + set temp [::tcl::OptKeyRegister $OptList] # create case (slave is optional) ::tcl::OptKeyRegister { @@ -1157,11 +1244,23 @@ proc ::safe::Setup {} { # Accessor method for ::safe::SetAutoPathSync # Usage: ::safe::SetAutoPathSync ?newValue? +# Respond to changes by calling Setup again, precerving any +# caller-defined logging. This allows complete equivalence with +# prior Safe Base behavior if AutoPathSync is true. +# +# >>> WARNING <<< +# +# DO NOT CHANGE AutoPathSync EXCEPT BY THIS COMMAND - IT IS VITAL THAT WHENEVER +# THE VALUE CHANGES, THE EXISTING PARSE TOKENS ARE DELETED AND Setup IS CALLED +# AGAIN. +# (The initialization of AutoPathSync at the end of this file is acceptable +# because Setup has not yet been called.) proc ::safe::SetAutoPathSync {args} { variable AutoPathSync - if {[llength $args] == 1} { + if {[llength $args] == 0} { + } elseif {[llength $args] == 1} { set newValue [lindex $args 0] if {![string is boolean -strict $newValue]} { return -code error "new value must be a valid boolean" @@ -1169,11 +1268,22 @@ proc ::safe::SetAutoPathSync {args} { set args [expr {$newValue && $newValue}] if {([info vars ::safe::S*] ne {}) && ($args != $AutoPathSync)} { return -code error \ - "cannot change AutoPathSync while Safe Base slaves exist" + "cannot set new value while Safe Base slaves exist" + } + if {($args != $AutoPathSync)} { + set AutoPathSync {*}$args + ::tcl::OptKeyDelete ::safe::interpCreate + ::tcl::OptKeyDelete ::safe::interpIC + set TmpLog [setLogCmd] + Setup + setLogCmd $TmpLog } + } else { + set msg {wrong # args: should be "safe::SetAutoPathSync ?newValue?"} + return -code error $msg } - set AutoPathSync {*}$args + return $AutoPathSync } namespace eval ::safe { @@ -1219,6 +1329,10 @@ namespace eval ::safe { # staticsok : Value of option -statics # nestedok : Value of option -nested # cleanupHook : Value of option -deleteHook + # + # Because the slave can change its value of ::auto_path, the value of + # option -autoPath is not stored in the array but must be obtained from + # the slave. } ::safe::Setup -- cgit v0.12 -- cgit v0.12 From e2c60c3b2f641c71c3df876f2c1ee8280252e91b Mon Sep 17 00:00:00 2001 From: kjnash Date: Thu, 9 Jul 2020 11:13:41 +0000 Subject: Apply patch for new features other than -autoPath --- library/safe.tcl | 127 ++++++++++++++++++--- tests/safe.test | 339 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 444 insertions(+), 22 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index 470cfa3..9e9b40b 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -249,10 +249,11 @@ proc ::safe::interpConfigure {args} { # Optional Arguments : # + slave name : if empty, generated name will be used # + access_path: path list controlling where load/source can occur, -# if empty: the master auto_path will be used. +# if empty: the master auto_path and its subdirectories will be +# used. # + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx) # if 1 :static packages are ok. -# + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub) +# + nestedok : flag, if 0 :no loading to sub-sub interps (load xx xx sub) # if 1 : multiple levels are ok. # use the full name and no indent so auto_mkIndex can find us @@ -278,12 +279,16 @@ proc ::safe::InterpCreate { # # InterpSetConfig (was setAccessPath) : -# Sets up slave virtual auto_path and corresponding structure within +# Sets up slave virtual access path and corresponding structure within # the master. Also sets the tcl_library in the slave to be the first # directory in the path. # NB: If you change the path after the slave has been initialized you # probably need to call "auto_reset" in the slave in order that it gets # the right auto_index() array values. +# +# It is the caller's responsibility, if it supplies a non-empty value for +# access_path, to make the first directory in the path suitable for use as +# tcl_library, and (if ![SetAutoPathSync]), to set the slave's ::auto_path. proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { global auto_path @@ -309,10 +314,14 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { moved it to front of slave's access_path" NOTICE } + set raw_auto_path $access_path + # Add 1st level sub dirs (will searched by auto loading from tcl # code in the slave using glob and thus fail, so we add them here # so by default it works the same). set access_path [AddSubDirs $access_path] + } else { + set raw_auto_path {} } Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\ @@ -343,7 +352,20 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { incr i } + # Set the slave auto_path. + # If [SetAutoPathSync], SyncAccessPath will overwrite this value with the + # full access path. + # If ![SetAutoPathSync], Safe Base code will not change this value. + set tokens_auto_path {} + foreach dir $raw_auto_path { + if {[dict exists $remap_access_path $dir]} { + lappend tokens_auto_path [dict get $remap_access_path $dir] + } + } + ::interp eval $slave [list set auto_path $tokens_auto_path] + set morepaths [::tcl::tm::list] + set firstpass 1 while {[llength $morepaths]} { set addpaths $morepaths set morepaths {} @@ -361,7 +383,12 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { lappend map_access_path $token $dir lappend remap_access_path $dir $token lappend norm_access_path [file normalize $dir] - lappend slave_tm_path $token + if {$firstpass} { + # $dir is in [::tcl::tm::list] and belongs in the slave_tm_path. + # Later passes handle subdirectories, which belong in the + # access path but not in the module path. + lappend slave_tm_path $token + } incr i # [Bug 2854929] @@ -372,6 +399,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # subdirectories. lappend morepaths {*}[glob -nocomplain -directory $dir -type d *] } + set firstpass 0 } set state(access_path) $access_path @@ -545,6 +573,15 @@ proc ::safe::interpDelete {slave} { namespace upvar ::safe S$slave state + # Sub interpreters would be deleted automatically, but if they are managed + # by the Safe Base we also need to clean up, and this needs to be done + # independently of the cleanupHook. + foreach sub [interp slaves $slave] { + if {[info exists ::safe::S[list $slave $sub]]} { + ::safe::interpDelete [list $slave $sub] + } + } + # If the slave has a cleanup hook registered, call it. Check the # existance because we might be called to delete an interp which has # not been registered with us at all @@ -611,20 +648,23 @@ proc ::safe::setLogCmd {args} { # ------------------- END OF PUBLIC METHODS ------------ # -# Sets the slave auto_path to the master recorded value. Also sets -# tcl_library to the first token of the virtual path. +# Sets the slave auto_path to its recorded access path. Also sets +# tcl_library to the first token of the access path. # proc ::safe::SyncAccessPath {slave} { + variable AutoPathSync namespace upvar ::safe S$slave state set slave_access_path $state(access_path,slave) - ::interp eval $slave [list set auto_path $slave_access_path] + if {$AutoPathSync} { + ::interp eval $slave [list set auto_path $slave_access_path] - Log $slave "auto_path in $slave has been set to $slave_access_path"\ - NOTICE + Log $slave "auto_path in $slave has been set to $slave_access_path"\ + NOTICE + } # This code assumes that info library is the first element in the - # list of auto_path's. See -> InterpSetConfig for the code which + # list of access path's. See -> InterpSetConfig for the code which # ensures this condition. ::interp eval $slave [list \ @@ -688,6 +728,7 @@ proc ::safe::AliasFileSubcommand {slave subcommand name} { # AliasGlob is the target of the "glob" alias in safe interpreters. proc ::safe::AliasGlob {slave args} { + variable AutoPathSync Log $slave "GLOB ! $args" NOTICE set cmd {} set at 0 @@ -710,11 +751,15 @@ proc ::safe::AliasGlob {slave args} { while {$at < [llength $args]} { switch -glob -- [set opt [lindex $args $at]] { - -nocomplain - -- - -join - -tails { + -nocomplain - -- - -tails { lappend cmd $opt set got($opt) 1 incr at } + -join { + set got($opt) 1 + incr at + } -types - -type { lappend cmd -types [lindex $args [incr at]] incr at @@ -729,15 +774,20 @@ proc ::safe::AliasGlob {slave args} { incr at } pkgIndex.tcl { - # Oops, this is globbing a subdirectory in regular package - # search. That is not wanted. Abort, handler does catch - # already (because glob was not defined before). See - # package.tcl, lines 484ff in tclPkgUnknown. - return -code error "unknown command glob" + if {$AutoPathSync} { + # Oops, this is globbing a subdirectory in regular package + # search. That is not wanted. Abort, handler does catch + # already (because glob was not defined before). See + # package.tcl, lines 484ff in tclPkgUnknown. + return -code error "unknown command glob" + } else { + break + } } -* { Log $slave "Safe base rejecting glob option '$opt'" return -code error "Safe base rejecting glob option '$opt'" + # unsafe/unnecessary options rejected: -path } default { break @@ -761,7 +811,7 @@ proc ::safe::AliasGlob {slave args} { lappend cmd -directory $dir } - # Apply the -join semantics ourselves + # Apply the -join semantics ourselves (hence -join not copied to $cmd) if {$got(-join)} { set args [lreplace $args $at end [join [lrange $args $at end] "/"]] } @@ -1100,8 +1150,49 @@ proc ::safe::Setup {} { return } +# Accessor method for ::safe::SetAutoPathSync +# Usage: ::safe::SetAutoPathSync ?newValue? + +proc ::safe::SetAutoPathSync {args} { + variable AutoPathSync + + if {[llength $args] == 1} { + set newValue [lindex $args 0] + if {![string is boolean -strict $newValue]} { + return -code error "new value must be a valid boolean" + } + set args [expr {$newValue && $newValue}] + if {([info vars ::safe::S*] ne {}) && ($args != $AutoPathSync)} { + return -code error \ + "cannot change AutoPathSync while Safe Base slaves exist" + } + } + + set AutoPathSync {*}$args +} + namespace eval ::safe { - # internal variables + # internal variables (must not begin with "S") + + # AutoPathSync + # + # Set AutoPathSync to 0 to give a slave's ::auto_path the same meaning as + # for an unsafe interpreter: the package command will search its directories + # and first-level subdirectories for pkgIndex.tcl files; the auto-loader + # will search its directories for tclIndex files. The access path and + # module path will be maintained as separate values, and ::auto_path will + # not be updated when the user calls ::safe::interpAddToAccessPath to add to + # the access path. If the user specifies an access path when calling + # interpCreate, interpInit or interpConfigure, it is the user's + # responsibility to define the slave's auto_path. If these commands are + # called with no (or empty) access path, the slave's auto_path will be set + # to a tokenized form of the master's auto_path, and these directories and + # their first-level subdirectories will be added to the access path. + # + # Set to 1 for "traditional" behavior: a slave's entire access path and + # module path are copied to its ::auto_path, which is updated whenever + # the user calls ::safe::interpAddToAccessPath to add to the access path. + variable AutoPathSync 1 # Log command, set via 'setLogCmd'. Logging is disabled when empty. variable Log {} diff --git a/tests/safe.test b/tests/safe.test index 356e176..8fb0983 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -17,6 +17,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +testConstraint AutoSyncDefined 1 + foreach i [interp slaves] { interp delete $i } @@ -180,22 +182,46 @@ test safe-6.3 {test safe interpreters knowledge of the world} { # leaking infos, but they still do... # high level general test -test safe-7.1 {tests that everything works at high level} -body { +test safe-7.1 {tests that everything works at high level with conventional AutoPathSync} -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::SetAutoPathSync] + safe::SetAutoPathSync 1 + } + set i [safe::interpCreate] + +} -body { # no error shall occur: # (because the default access_path shall include 1st level sub dirs so # package require in a slave works like in the master) set v [interp eval $i {package require http 2}] # no error shall occur: interp eval $i {http::config} - safe::interpDelete $i set v +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::SetAutoPathSync $SyncVal_TMP + } } -match glob -result 2.* -test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body { +test safe-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync} -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::SetAutoPathSync] + safe::SetAutoPathSync 1 + } else { + set SyncVal_TMP 1 + } +} -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] - # should add as p1 + # should add as p* (not p1 if master has a module path) set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] # an error shall occur (http is not anymore in the secure 0-level # provided deep path) @@ -203,6 +229,10 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body { [catch {interp eval $i {package require http 1}} msg] $msg \ [safe::interpConfigure $i]\ [safe::interpDelete $i] +} -cleanup { + if {$SyncExists} { + safe::SetAutoPathSync $SyncVal_TMP + } } -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" test safe-7.3 {check that safe subinterpreters work} { set i [safe::interpCreate] @@ -210,6 +240,64 @@ test safe-7.3 {check that safe subinterpreters work} { list [interp eval $j {join {o k} ""}] [safe::interpDelete $i] [interp exists $j] } {ok {} 0} +test safe-7.4 {tests specific path and positive search with conventional AutoPathSync} -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::SetAutoPathSync] + safe::SetAutoPathSync 1 + } else { + set SyncVal_TMP 1 + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if master has a module path) + set token2 [safe::interpAddToAccessPath $i [file join [info library] http1.0]] + # this time, unlike test safe-7.2, http 1.0 should be found + list $token1 $token2 \ + [catch {interp eval $i {package require http 1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] + # Note that the glob match elides directories (those from the module path) + # other than the first and last in the access path. +} -cleanup { + if {$SyncExists} { + safe::SetAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {}} {}" + +test safe-7.5 {tests positive and negative module loading with conventional AutoPathSync} -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::SetAutoPathSync] + safe::SetAutoPathSync 1 + } + + set i [safe::interpCreate] + + interp eval $i { + package forget platform::shell + package forget platform + catch {namespace delete ::platform} + } +} -body { + # Should raise an error (module ancestor directory issue) + set code1 [catch {interp eval $i {package require shell}} msg1] + # Should not raise an error + set code2 [catch {interp eval $i {package require platform::shell}} msg2] + return [list $code1 $msg1 $code2] +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::SetAutoPathSync $SyncVal_TMP + } +} -result {1 {can't find package shell} 0} + # test source control on file name set i "a" test safe-8.1 {safe source control on file} -setup { @@ -403,6 +491,8 @@ test safe-9.6 {interpConfigure widget like behaviour} -body { safe::interpConfigure $i]\ [safe::interpConfigure $i -deleteHook toto -nosta -nested 0 safe::interpConfigure $i] +} -cleanup { + safe::interpDelete $i } -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} catch {teststaticpkg Safepkg1 0 0} @@ -827,6 +917,247 @@ test safe-16.4 {Bug 3529949: defang ~user in globs} -setup { } -cleanup { safe::interpDelete $i } -result {} + +### 17. The first element in a slave's ::auto_path and access path must be [info library]. + +test safe-17.1 {Check that first element of slave auto_path (and access path) is Tcl Library} -setup { + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib1 $lib2] + + set i [safe::interpCreate] +} -body { + set autoList {} + set token [lindex [$i eval set ::auto_path] 0] + set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] + set accessList [lindex [safe::interpConfigure $i -accessPath] 1] + return [list [lindex $accessList 0] $auto0] +} -cleanup { + set ::auto_path $::auto_TMP + safe::interpDelete $i +} -result [list [info library] [info library]] + +test safe-17.2 {Check that first element of slave auto_path (and access path) is Tcl Library, even if not true for master} -setup { + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib2 $lib1] + # Unexpected order, should be reversed in the slave + + set i [safe::interpCreate] +} -body { + set autoList {} + set token [lindex [$i eval set ::auto_path] 0] + set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] + set accessList [lindex [safe::interpConfigure $i -accessPath] 1] + + return [list [lindex $accessList 0] $auto0] +} -cleanup { + set ::auto_path $::auto_TMP + safe::interpDelete $i +} -result [list [info library] [info library]] + +### 18. Tests for AutoSyncDefined without conventional AutoPathSync, i.e. with AutoPathSync off. + +test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without conventional AutoPathSync} -constraints AutoSyncDefined -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::SetAutoPathSync] + safe::SetAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined} + } + + # Without AutoPathSync, we need a more complete auto_path, because the slave will use the same value. + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib1 $lib2] + + set i [safe::interpCreate] +} -body { + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs + # so package require in a slave works like in the master) + set v [interp eval $i {package require http 1}] + # no error shall occur: + interp eval $i {http_config} + set v +} -cleanup { + set ::auto_path $::auto_TMP + safe::interpDelete $i + if {$SyncExists} { + safe::SetAutoPathSync $SyncVal_TMP + } +} -result 1.0 + +test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync} -constraints AutoSyncDefined -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::SetAutoPathSync] + safe::SetAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined} + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + set auto1 [interp eval $i {set ::auto_path}] + interp eval $i {set ::auto_path [list {$p(:0:)}]} + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p1 + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + # an error shall occur (http is not anymore in the secure 0-level + # provided deep path) + list $auto1 $token1 $token2 \ + [catch {interp eval $i {package require http 1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] +} -cleanup { + if {$SyncExists} { + safe::SetAutoPathSync $SyncVal_TMP + } +} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" + +test safe-18.3 {Check that default auto_path is the same as in the master interpreter without conventional AutoPathSync} -constraints AutoSyncDefined -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::SetAutoPathSync] + safe::SetAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined} + } + + set i [safe::interpCreate] + +} -body { + # This file's header sets auto_path to a single directory [info library], + # which is the one required by Safe Base to be present & first in the list. + + set ap {} + foreach token [$i eval set ::auto_path] { + lappend ap [dict get [set ::safe::S${i}(access_path,map)] $token] + } + return $ap +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::SetAutoPathSync $SyncVal_TMP + } +} -result [set ::auto_path] + +test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync} -constraints AutoSyncDefined -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::SetAutoPathSync] + safe::SetAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined} + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + + # should not have been set by Safe Base: + set auto1 [interp eval $i {set ::auto_path}] + + interp eval $i {set ::auto_path [list {$p(:0:)}]} + + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + + # should add as p* (not p1 if master has a module path) + set token2 [safe::interpAddToAccessPath $i [file join [info library] http1.0]] + + # should not have been changed by Safe Base: + set auto2 [interp eval $i {set ::auto_path}] + + # This time, unlike test safe-18.2 and the try above, http 1.0 should be found: + list $auto1 $auto2 $token1 $token2 \ + [catch {interp eval $i {package require http 1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] +} -cleanup { + if {$SyncExists} { + safe::SetAutoPathSync $SyncVal_TMP + } +} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {}} {}" + +test safe-18.5 {cf. safe-7.5 - tests positive and negative module loading without conventional AutoPathSync} -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::SetAutoPathSync] + safe::SetAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined} + } + + set i [safe::interpCreate] + + interp eval $i { + package forget platform::shell + package forget platform + catch {namespace delete ::platform} + } +} -body { + # Should raise an error (tests module ancestor directory rule) + set code1 [catch {interp eval $i {package require shell}} msg1] + # Should not raise an error + set code2 [catch {interp eval $i {package require platform::shell}} msg2] + return [list $code1 $msg1 $code2] +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::SetAutoPathSync $SyncVal_TMP + } +} -result {1 {can't find package shell} 0} + +### 19. Test tokenization of directories available to a slave. + +test safe-19.1 {Check that each directory of the default auto_path is a valid token} -setup { + set i [safe::interpCreate] +} -body { + set badTokens {} + foreach dir [$i eval {set ::auto_path}] { + if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { + # Match - OK - token has expected form + } else { + # No match - possibly an ordinary path has not been tokenized + lappend badTokens $dir + } + } + set badTokens +} -cleanup { + safe::interpDelete $i +} -result {} + +test safe-19.2 {Check that each directory of the module path is a valid token} -setup { + set i [safe::interpCreate] +} -body { + set badTokens {} + foreach dir [$i eval {::tcl::tm::path list}] { + if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { + # Match - OK - token has expected form + } else { + # No match - possibly an ordinary path has not been tokenized + lappend badTokens $dir + } + } + set badTokens +} -cleanup { + safe::interpDelete $i +} -result {} + set ::auto_path $saveAutoPath # cleanup -- cgit v0.12 From 05389ab99699d81541bec827e0e419bf240fe81a Mon Sep 17 00:00:00 2001 From: kjnash Date: Thu, 9 Jul 2020 11:39:19 +0000 Subject: Add code for -autoPath option in Safe Base. --- library/safe.tcl | 150 ++++++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 132 insertions(+), 18 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index 9e9b40b..54f9cc9 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -78,18 +78,29 @@ proc ::safe::InterpNested {} { # Interface/entry point function and front end for "Create" proc ::safe::interpCreate {args} { + variable AutoPathSync + if {$AutoPathSync} { + set autoPath {} + } set Args [::tcl::OptKeyParse ::safe::interpCreate $args] + + set withAutoPath [::tcl::OptProcArgGiven -autoPath] InterpCreate $slave $accessPath \ - [InterpStatics] [InterpNested] $deleteHook + [InterpStatics] [InterpNested] $deleteHook $autoPath $withAutoPath } proc ::safe::interpInit {args} { + variable AutoPathSync + if {$AutoPathSync} { + set autoPath {} + } set Args [::tcl::OptKeyParse ::safe::interpIC $args] if {![::interp exists $slave]} { return -code error "\"$slave\" is not an interpreter" } + set withAutoPath [::tcl::OptProcArgGiven -autoPath] InterpInit $slave $accessPath \ - [InterpStatics] [InterpNested] $deleteHook + [InterpStatics] [InterpNested] $deleteHook $autoPath $withAutoPath } # Check that the given slave is "one of us" @@ -115,6 +126,7 @@ proc ::safe::CheckInterp {slave} { # So this will be hopefully written and some integrated with opt1.0 # (hopefully for tcl8.1 ?) proc ::safe::interpConfigure {args} { + variable AutoPathSync switch [llength $args] { 1 { # If we have exactly 1 argument the semantic is to return all @@ -125,11 +137,17 @@ proc ::safe::interpConfigure {args} { CheckInterp $slave namespace upvar ::safe S$slave state - return [join [list \ + set TMP [list \ [list -accessPath $state(access_path)] \ [list -statics $state(staticsok)] \ [list -nested $state(nestedok)] \ - [list -deleteHook $state(cleanupHook)]]] + [list -deleteHook $state(cleanupHook)] \ + ] + if {!$AutoPathSync} { + set SLAP [DetokPath $slave [$slave eval set ::auto_path]] + lappend TMP [list -autoPath $SLAP] + } + return [join $TMP] } 2 { # If we have exactly 2 arguments the semantic is a "configure @@ -154,6 +172,14 @@ proc ::safe::interpConfigure {args} { -accessPath { return [list -accessPath $state(access_path)] } + -autoPath { + if {$AutoPathSync} { + return -code error "unknown flag $name (bug)" + } else { + set SLAP [DetokPath $slave [$slave eval set ::auto_path]] + return [list -autoPath $SLAP] + } + } -statics { return [list -statics $state(staticsok)] } @@ -194,9 +220,17 @@ proc ::safe::interpConfigure {args} { if {![::tcl::OptProcArgGiven -accessPath]} { set doreset 1 set accessPath $state(access_path) + # BUG? is doreset the wrong way round? } else { set doreset 0 } + if {(!$AutoPathSync) && (![::tcl::OptProcArgGiven -autoPath])} { + set SLAP [DetokPath $slave [$slave eval set ::auto_path]] + set autoPath $SLAP + } elseif {$AutoPathSync} { + set autoPath {} + } else { + } if { ![::tcl::OptProcArgGiven -statics] && ![::tcl::OptProcArgGiven -noStatics] @@ -217,7 +251,9 @@ proc ::safe::interpConfigure {args} { set deleteHook $state(cleanupHook) } # we can now reconfigure : - InterpSetConfig $slave $accessPath $statics $nested $deleteHook + set withAutoPath [::tcl::OptProcArgGiven -autoPath] + set res [InterpSetConfig $slave $accessPath $statics $nested $deleteHook $autoPath $withAutoPath] +puts stderr [list changed_map $res do_reset $doreset] # auto_reset the slave (to completly synch the new access_path) if {$doreset} { if {[catch {::interp eval $slave {auto_reset}} msg]} { @@ -263,6 +299,8 @@ proc ::safe::InterpCreate { staticsok nestedok deletehook + autoPath + withAutoPath } { # Create the slave. if {$slave ne ""} { @@ -274,7 +312,7 @@ proc ::safe::InterpCreate { Log $slave "Created" NOTICE # Initialize it. (returns slave name) - InterpInit $slave $access_path $staticsok $nestedok $deletehook + InterpInit $slave $access_path $staticsok $nestedok $deletehook $autoPath $withAutoPath } # @@ -290,8 +328,9 @@ proc ::safe::InterpCreate { # access_path, to make the first directory in the path suitable for use as # tcl_library, and (if ![SetAutoPathSync]), to set the slave's ::auto_path. -proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { +proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook autoPath withAutoPath} { global auto_path + variable AutoPathSync # determine and store the access path if empty if {$access_path eq ""} { @@ -321,11 +360,18 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # so by default it works the same). set access_path [AddSubDirs $access_path] } else { - set raw_auto_path {} + set raw_auto_path $autoPath + } + + if {$withAutoPath} { + set raw_auto_path $autoPath } Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\ nestedok=$nestedok deletehook=($deletehook)" NOTICE + if {!$AutoPathSync} { + Log $slave "Setting auto_path=($raw_auto_path)" NOTICE + } namespace upvar ::safe S$slave state @@ -335,7 +381,11 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { # We save the virtual form separately as well, as syncing it with the # slave has to be defered until the necessary commands are present for # setup. - +if {[info exists state(access_path,map)]} { + set old_map_access_path $state(access_path,map) +} else { + set old_map_access_path {} +} set norm_access_path {} set slave_access_path {} set map_access_path {} @@ -352,7 +402,8 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { incr i } - # Set the slave auto_path. + # Set the slave auto_path to a tokenized raw_auto_path. + # Silently ignore any directories that are not in the access path. # If [SetAutoPathSync], SyncAccessPath will overwrite this value with the # full access path. # If ![SetAutoPathSync], Safe Base code will not change this value. @@ -364,6 +415,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { } ::interp eval $slave [list set auto_path $tokens_auto_path] + # Add the tcl::tm directories to the access path. set morepaths [::tcl::tm::list] set firstpass 1 while {[llength $morepaths]} { @@ -413,23 +465,50 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { set state(cleanupHook) $deletehook SyncAccessPath $slave + + set result [expr {[lrange $map_access_path 0 end] ne [lrange $old_map_access_path 0 end]}] + return $result +} + + +# +# DetokPath: +# Convert tokens to directories where possible. +# Leave undefined tokens unconverted. They are +# nonsense in both the slave and the master. +# +proc ::safe::DetokPath {slave tokenPath} { + namespace upvar ::safe S$slave state + + set slavePath {} + foreach token $tokenPath { + if {[dict exists $state(access_path,map) $token]} { + lappend slavePath [dict get $state(access_path,map) $token] + } else { + lappend slavePath $token + } + } + return $slavePath } # # -# FindInAccessPath: +# interpFindInAccessPath: # Search for a real directory and returns its virtual Id (including the # "$") +# +# When debugging, use TranslatePath for the inverse operation. proc ::safe::interpFindInAccessPath {slave path} { namespace upvar ::safe S$slave state if {![dict exists $state(access_path,remap) $path]} { - return -code error "$path not found in access path $access_path" + return -code error "$path not found in access path" } return [dict get $state(access_path,remap) $path] } + # # addToAccessPath: # add (if needed) a real directory to access path and return its @@ -465,9 +544,11 @@ proc ::safe::InterpInit { staticsok nestedok deletehook + autoPath + withAutoPath } { # Configure will generate an access_path when access_path is empty. - InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook + InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook $autoPath $withAutoPath # NB we need to add [namespace current], aliases are always absolute # paths. @@ -669,6 +750,7 @@ proc ::safe::SyncAccessPath {slave} { ::interp eval $slave [list \ set tcl_library [lindex $slave_access_path 0]] + return } # Returns the virtual token for directory number N. @@ -1104,16 +1186,21 @@ proc ::safe::Setup {} { # Setup the arguments parsing # #### + variable AutoPathSync # Share the descriptions - set temp [::tcl::OptKeyRegister { + set OptList { {-accessPath -list {} "access path for the slave"} {-noStatics "prevent loading of statically linked pkgs"} {-statics true "loading of statically linked pkgs"} {-nestedLoadOk "allow nested loading"} {-nested false "nested loading"} {-deleteHook -script {} "delete hook"} - }] + } + if {!$AutoPathSync} { + lappend OptList {-autoPath -list {} "::auto_path for the slave"} + } + set temp [::tcl::OptKeyRegister $OptList] # create case (slave is optional) ::tcl::OptKeyRegister { @@ -1152,11 +1239,23 @@ proc ::safe::Setup {} { # Accessor method for ::safe::SetAutoPathSync # Usage: ::safe::SetAutoPathSync ?newValue? +# Respond to changes by calling Setup again, precerving any +# caller-defined logging. This allows complete equivalence with +# prior Safe Base behavior if AutoPathSync is true. +# +# >>> WARNING <<< +# +# DO NOT CHANGE AutoPathSync EXCEPT BY THIS COMMAND - IT IS VITAL THAT WHENEVER +# THE VALUE CHANGES, THE EXISTING PARSE TOKENS ARE DELETED AND Setup IS CALLED +# AGAIN. +# (The initialization of AutoPathSync at the end of this file is acceptable +# because Setup has not yet been called.) proc ::safe::SetAutoPathSync {args} { variable AutoPathSync - if {[llength $args] == 1} { + if {[llength $args] == 0} { + } elseif {[llength $args] == 1} { set newValue [lindex $args 0] if {![string is boolean -strict $newValue]} { return -code error "new value must be a valid boolean" @@ -1164,11 +1263,22 @@ proc ::safe::SetAutoPathSync {args} { set args [expr {$newValue && $newValue}] if {([info vars ::safe::S*] ne {}) && ($args != $AutoPathSync)} { return -code error \ - "cannot change AutoPathSync while Safe Base slaves exist" + "cannot set new value while Safe Base slaves exist" + } + if {($args != $AutoPathSync)} { + set AutoPathSync {*}$args + ::tcl::OptKeyDelete ::safe::interpCreate + ::tcl::OptKeyDelete ::safe::interpIC + set TmpLog [setLogCmd] + Setup + setLogCmd $TmpLog } + } else { + set msg {wrong # args: should be "safe::SetAutoPathSync ?newValue?"} + return -code error $msg } - set AutoPathSync {*}$args + return $AutoPathSync } namespace eval ::safe { @@ -1214,6 +1324,10 @@ namespace eval ::safe { # staticsok : Value of option -statics # nestedok : Value of option -nested # cleanupHook : Value of option -deleteHook + # + # Because the slave can change its value of ::auto_path, the value of + # option -autoPath is not stored in the array but must be obtained from + # the slave. } ::safe::Setup -- cgit v0.12 From 2ccefe1d8265285eee3b36fb090840c55306ccde Mon Sep 17 00:00:00 2001 From: kjnash Date: Thu, 9 Jul 2020 16:26:35 +0000 Subject: Update safe(n) to document the changes. --- doc/safe.n | 135 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 133 insertions(+), 2 deletions(-) diff --git a/doc/safe.n b/doc/safe.n index b39f2c2..5b95eeb 100644 --- a/doc/safe.n +++ b/doc/safe.n @@ -23,10 +23,13 @@ safe \- Creating and manipulating safe interpreters .sp \fB::safe::interpFindInAccessPath\fR \fIslave\fR \fIdirectory\fR .sp +\fB::safe::setAutoPathSync\fR ?\fInewValue\fR? +.sp \fB::safe::setLogCmd\fR ?\fIcmd arg...\fR? .SS OPTIONS .PP ?\fB\-accessPath\fR \fIpathList\fR? +?\fB\-autoPath\fR \fIpathList\fR? ?\fB\-statics\fR \fIboolean\fR? ?\fB\-noStatics\fR? ?\fB\-nested\fR \fIboolean\fR? ?\fB\-nestedLoadOk\fR? ?\fB\-deleteHook\fR \fIscript\fR? @@ -140,6 +143,15 @@ $slave eval [list set tk_library \e .CE .RE .TP +\fB::safe::setAutoPathSync\fR ?\fInewValue\fR? +This command is used to get or set the "Sync Mode" of the Safe Base. +When an argument is supplied, the command returns an error if the argument +is not a boolean value, or if any Safe Base interpreters exist. Typically +the value will be set as part of initialization - boolean true for +"Sync Mode" on (the default), false for "Sync Mode" off. With "Sync Mode" +on, the Safe Base keeps each slave interpreter's ::auto_path synchronized +with its access path. See the section \fBSYNC MODE\fR below for details. +.TP \fB::safe::setLogCmd\fR ?\fIcmd arg...\fR? This command installs a script that will be called when interesting life cycle events occur for a safe interpreter. @@ -191,6 +203,13 @@ master for auto-loading. See the section \fBSECURITY\fR below for more detail about virtual paths, tokens and access control. .TP +\fB\-autoPath\fR \fIdirectoryList\fR +This option sets the list of directories in the safe interpreter's +::auto_path. The option is undefined if the Safe Base has "Sync Mode" on +- in that case the safe interpreter's ::auto_path is managed by the Safe +Base and is a tokenized form of its access path. +See the section \fBSYNC MODE\fR below for details. +.TP \fB\-statics\fR \fIboolean\fR This option specifies if the safe interpreter will be allowed to load statically linked packages (like \fBload {} Tk\fR). @@ -323,7 +342,8 @@ list will be assigned a token that will be set in the slave \fBauto_path\fR and the first element of that list will be set as the \fBtcl_library\fR for that slave. .PP -If the access path argument is not given or is the empty list, +If the access path argument is not given to \fB::safe::interpCreate\fR or +\fB::safe::interpInit\fR or is the empty list, the default behavior is to let the slave access the same packages as the master has access to (Or to be more precise: only packages written in Tcl (which by definition cannot be dangerous @@ -349,8 +369,119 @@ When the \fIaccessPath\fR is changed after the first creation or initialization (i.e. through \fBinterpConfigure -accessPath \fR\fIlist\fR), an \fBauto_reset\fR is automatically evaluated in the safe interpreter to synchronize its \fBauto_index\fR with the new token list. +.SH SYNC MODE +Before Tcl version 8.6.x, the Safe Base kept each safe interpreter's +::auto_path synchronized with a tokenized form of its access path. +Limitations of Tcl 8.4 and earlier made this feature necessary. This +definition of ::auto_path did not conform its specification in library(n) +and pkg_mkIndex(n), but nevertheless worked perfectly well for the discovery +and loading of packages. The introduction of Tcl modules in Tcl 8.5 added a +large number of directories to the access path, and it is inconvenient to +have these additional directories unnecessarily appended to the ::auto_path. +.PP +In order to preserve compatibility with existing code, this synchronization +of the ::auto_path and access path ("Sync Mode" on) is still the default. +However, the Safe Base offers the option of limiting the safe interpreter's +::auto_path to the much shorter list of directories that is necessary for +it to perform its function ("Sync Mode" off). Use the command +\fB::safe::setAutoPathSync\fR to choose the mode before creating any Safe +Base interpreters. +.PP +In either mode, the most convenient way to initialize a safe interpreter is +to call \fB::safe::interpCreate\fR or \fB::safe::interpInit\fR without the +\fB\-accessPath\fR or \fB\-autoPath\fR options (or with the \fB\-accessPath\fR +option set to the +empty list), which will give the safe interpreter the same access as the +master interpreter to packages, modules, and autoloader files. With +"Sync Mode" off, the ::auto_path will be set to a tokenized form of the master's +::auto_path. +.PP +With "Sync Mode" off, if a value is specified for \fB\-autoPath\fR, even the empty +list, in a call to \fB::safe::interpCreate\fR, \fB::safe::interpInit\fR, or +\fB::safe::interpConfigure\fR, it will be tokenized and used as the safe +interpreter's ::auto_path. Any directories that do not also belong to the +access path cannot be tokenized and will be silently ignored. +.PP +With "Sync Mode" off, if the access path is reset to the values in the +master interpreter by calling \fB::safe::interpConfigure\fR with arguments +\fB\-accessPath\fR {}, then the ::auto_path will also be reset unless the argument +\fB\-autoPath\fR is supplied to specify a different value. +.PP +With "Sync Mode" off, if a non-empty value of \fB\-accessPath\fR is supplied, the +safe interpreter's ::auto_path will be set to {} (by +\fB::safe::interpCreate\fR, \fB::safe::interpInit\fR) or left unchanged +(by \fB::safe::interpConfigure\fR). If the same command specifies a new +value for \fB\-autoPath\fR, it will be applied after the \fB\-accessPath\fR argument has +been processed. + +Examples of use with "Sync Mode" off: any of these commands will set the +::auto_path to a tokenized form of its value in the master interpreter: +.RS +.PP +.CS + safe::interpCreate foo + safe::interpCreate foo -accessPath {} + safe::interpInit bar + safe::interpInit bar -accessPath {} + safe::interpConfigure foo -accessPath {} +.CE +.RE +.TP +Example of use with "Sync Mode" off: when initializing a safe interpreter +with a non-empty access path, the ::auto_path will be set to {} unless its +own value is also specified: +.RS +.PP +.CS + safe::interpCreate foo -accessPath { + /usr/local/TclHome/lib/tcl8.6 + /usr/local/TclHome/lib/tcl8.6/http1.0 + /usr/local/TclHome/lib/tcl8.6/opt0.4 + /usr/local/TclHome/lib/tcl8.6/msgs + /usr/local/TclHome/lib/tcl8.6/encoding + /usr/local/TclHome/lib + } + + # The slave's ::auto_path must be given a suitable value: + + safe::interpConfigure foo -autoPath { + /usr/local/TclHome/lib/tcl8.6 + /usr/local/TclHome/lib + } + + # The two commands can be combined: + + safe::interpCreate foo -accessPath { + /usr/local/TclHome/lib/tcl8.6 + /usr/local/TclHome/lib/tcl8.6/http1.0 + /usr/local/TclHome/lib/tcl8.6/opt0.4 + /usr/local/TclHome/lib/tcl8.6/msgs + /usr/local/TclHome/lib/tcl8.6/encoding + /usr/local/TclHome/lib + } -autoPath { + /usr/local/TclHome/lib/tcl8.6 + /usr/local/TclHome/lib + } +.CE +.RE +.TP +Example of use with "Sync Mode" off: the command +\fBsafe::interpAddToAccessPath\fR does not change the safe interpreter's +::auto_path, and so any necessary change must be made by the script: +.RS +.PP +.CS + safe::interpAddToAccessPath foo /usr/local/TclHome/lib/extras/Img1.4.11 + + lassign [safe::interpConfigure foo -autoPath] DUM slaveAutoPath + lappend slaveAutoPath /usr/local/TclHome/lib/extras/Img1.4.11 + safe::interpConfigure foo -autoPath $slaveAutoPath +.CE +.RE +.TP .SH "SEE ALSO" -interp(n), library(n), load(n), package(n), source(n), unknown(n) +interp(n), library(n), load(n), package(n), pkg_mkIndex(n), source(n), +tm(n), unknown(n) .SH KEYWORDS alias, auto\-loading, auto_mkindex, load, master interpreter, safe interpreter, slave interpreter, source -- cgit v0.12 From a52e71f534a53b923ecdd96be5dec47ca9875544 Mon Sep 17 00:00:00 2001 From: kjnash Date: Thu, 9 Jul 2020 17:03:02 +0000 Subject: Rename command ::safe::SetAutoPathSync to ::safe::setAutoPathSync and add to library/tclIndex. --- library/safe.tcl | 16 +++++------ library/tclIndex | 1 + tests/safe.test | 82 ++++++++++++++++++++++++++++---------------------------- 3 files changed, 50 insertions(+), 49 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index a1fadb1..474dd01 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -326,7 +326,7 @@ proc ::safe::InterpCreate { # # It is the caller's responsibility, if it supplies a non-empty value for # access_path, to make the first directory in the path suitable for use as -# tcl_library, and (if ![SetAutoPathSync]), to set the slave's ::auto_path. +# tcl_library, and (if ![setAutoPathSync]), to set the slave's ::auto_path. proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook autoPath withAutoPath} { global auto_path @@ -404,9 +404,9 @@ if {[info exists state(access_path,map)]} { # Set the slave auto_path to a tokenized raw_auto_path. # Silently ignore any directories that are not in the access path. - # If [SetAutoPathSync], SyncAccessPath will overwrite this value with the + # If [setAutoPathSync], SyncAccessPath will overwrite this value with the # full access path. - # If ![SetAutoPathSync], Safe Base code will not change this value. + # If ![setAutoPathSync], Safe Base code will not change this value. set tokens_auto_path {} foreach dir $raw_auto_path { if {[dict exists $remap_access_path $dir]} { @@ -1242,9 +1242,9 @@ proc ::safe::Setup {} { return } -# Accessor method for ::safe::SetAutoPathSync -# Usage: ::safe::SetAutoPathSync ?newValue? -# Respond to changes by calling Setup again, precerving any +# Accessor method for ::safe::AutoPathSync +# Usage: ::safe::setAutoPathSync ?newValue? +# Respond to changes by calling Setup again, preserving any # caller-defined logging. This allows complete equivalence with # prior Safe Base behavior if AutoPathSync is true. # @@ -1256,7 +1256,7 @@ proc ::safe::Setup {} { # (The initialization of AutoPathSync at the end of this file is acceptable # because Setup has not yet been called.) -proc ::safe::SetAutoPathSync {args} { +proc ::safe::setAutoPathSync {args} { variable AutoPathSync if {[llength $args] == 0} { @@ -1279,7 +1279,7 @@ proc ::safe::SetAutoPathSync {args} { setLogCmd $TmpLog } } else { - set msg {wrong # args: should be "safe::SetAutoPathSync ?newValue?"} + set msg {wrong # args: should be "safe::setAutoPathSync ?newValue?"} return -code error $msg } diff --git a/library/tclIndex b/library/tclIndex index 0409d9b..0d2db02 100644 --- a/library/tclIndex +++ b/library/tclIndex @@ -61,6 +61,7 @@ set auto_index(::safe::DirInAccessPath) [list source [file join $dir safe.tcl]] set auto_index(::safe::Subset) [list source [file join $dir safe.tcl]] set auto_index(::safe::AliasSubset) [list source [file join $dir safe.tcl]] set auto_index(::safe::AliasEncoding) [list source [file join $dir safe.tcl]] +set auto_index(::safe::setAutoPathSync) [list source [file join $dir safe.tcl]] set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]] set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]] set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]] diff --git a/tests/safe.test b/tests/safe.test index fac52f1..2a910fd 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -184,11 +184,11 @@ test safe-6.3 {test safe interpreters knowledge of the world} { # high level general test test safe-7.1 {tests that everything works at high level with conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::SetAutoPathSync] - safe::SetAutoPathSync 1 + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 } set i [safe::interpCreate] @@ -204,16 +204,16 @@ test safe-7.1 {tests that everything works at high level with conventional AutoP } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::SetAutoPathSync $SyncVal_TMP + safe::setAutoPathSync $SyncVal_TMP } } -match glob -result 2.* test safe-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::SetAutoPathSync] - safe::SetAutoPathSync 1 + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 } else { set SyncVal_TMP 1 } @@ -231,7 +231,7 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath with conventio [safe::interpDelete $i] } -cleanup { if {$SyncExists} { - safe::SetAutoPathSync $SyncVal_TMP + safe::setAutoPathSync $SyncVal_TMP } } -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" test safe-7.3 {check that safe subinterpreters work} { @@ -242,11 +242,11 @@ test safe-7.3 {check that safe subinterpreters work} { test safe-7.4 {tests specific path and positive search with conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::SetAutoPathSync] - safe::SetAutoPathSync 1 + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 } else { set SyncVal_TMP 1 } @@ -265,17 +265,17 @@ test safe-7.4 {tests specific path and positive search with conventional AutoPat # other than the first and last in the access path. } -cleanup { if {$SyncExists} { - safe::SetAutoPathSync $SyncVal_TMP + safe::setAutoPathSync $SyncVal_TMP } } -match glob -result "{\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {}} {}" test safe-7.5 {tests positive and negative module loading with conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::SetAutoPathSync] - safe::SetAutoPathSync 1 + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 } set i [safe::interpCreate] @@ -294,7 +294,7 @@ test safe-7.5 {tests positive and negative module loading with conventional Auto } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::SetAutoPathSync $SyncVal_TMP + safe::setAutoPathSync $SyncVal_TMP } } -result {1 {can't find package shell} 0} @@ -966,13 +966,13 @@ test safe-17.2 {Check that first element of slave auto_path (and access path) is test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without conventional AutoPathSync} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::SetAutoPathSync] - safe::SetAutoPathSync 0 + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 } else { - error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } # Without AutoPathSync, we need a more complete auto_path, because the slave will use the same value. @@ -994,19 +994,19 @@ test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without set ::auto_path $::auto_TMP safe::interpDelete $i if {$SyncExists} { - safe::SetAutoPathSync $SyncVal_TMP + safe::setAutoPathSync $SyncVal_TMP } } -result 1.0 test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::SetAutoPathSync] - safe::SetAutoPathSync 0 + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 } else { - error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] @@ -1024,19 +1024,19 @@ test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPat [safe::interpDelete $i] } -cleanup { if {$SyncExists} { - safe::SetAutoPathSync $SyncVal_TMP + safe::setAutoPathSync $SyncVal_TMP } } -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" test safe-18.3 {Check that default auto_path is the same as in the master interpreter without conventional AutoPathSync} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::SetAutoPathSync] - safe::SetAutoPathSync 0 + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 } else { - error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } set i [safe::interpCreate] @@ -1053,19 +1053,19 @@ test safe-18.3 {Check that default auto_path is the same as in the master interp } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::SetAutoPathSync $SyncVal_TMP + safe::setAutoPathSync $SyncVal_TMP } } -result [set ::auto_path] test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::SetAutoPathSync] - safe::SetAutoPathSync 0 + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 } else { - error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] @@ -1091,19 +1091,19 @@ test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_ [safe::interpDelete $i] } -cleanup { if {$SyncExists} { - safe::SetAutoPathSync $SyncVal_TMP + safe::setAutoPathSync $SyncVal_TMP } } -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {}} {}" test safe-18.5 {cf. safe-7.5 - tests positive and negative module loading without conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::SetAutoPathSync] - safe::SetAutoPathSync 0 + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 } else { - error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } set i [safe::interpCreate] @@ -1122,7 +1122,7 @@ test safe-18.5 {cf. safe-7.5 - tests positive and negative module loading withou } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::SetAutoPathSync $SyncVal_TMP + safe::setAutoPathSync $SyncVal_TMP } } -result {1 {can't find package shell} 0} -- cgit v0.12 From 541671a2f136159742365818e09d29f6be51f96b Mon Sep 17 00:00:00 2001 From: kjnash Date: Thu, 9 Jul 2020 17:37:34 +0000 Subject: Revise tests safe-18.2 and safe-18.4 to allow for -autoPath in interpConfigure output. --- tests/safe.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/safe.test b/tests/safe.test index 2a910fd..ce70bf9 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1026,7 +1026,7 @@ test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPat if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" +} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" test safe-18.3 {Check that default auto_path is the same as in the master interpreter without conventional AutoPathSync} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. @@ -1093,7 +1093,7 @@ test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_ if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {}} {}" +} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" test safe-18.5 {cf. safe-7.5 - tests positive and negative module loading without conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. -- cgit v0.12 From 4ca3e59e50cd57a6c696d5bb9810787733a0415d Mon Sep 17 00:00:00 2001 From: kjnash Date: Thu, 9 Jul 2020 17:48:16 +0000 Subject: Update safe(n) to document the changes. --- doc/safe.n | 135 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 133 insertions(+), 2 deletions(-) diff --git a/doc/safe.n b/doc/safe.n index b39f2c2..5b95eeb 100644 --- a/doc/safe.n +++ b/doc/safe.n @@ -23,10 +23,13 @@ safe \- Creating and manipulating safe interpreters .sp \fB::safe::interpFindInAccessPath\fR \fIslave\fR \fIdirectory\fR .sp +\fB::safe::setAutoPathSync\fR ?\fInewValue\fR? +.sp \fB::safe::setLogCmd\fR ?\fIcmd arg...\fR? .SS OPTIONS .PP ?\fB\-accessPath\fR \fIpathList\fR? +?\fB\-autoPath\fR \fIpathList\fR? ?\fB\-statics\fR \fIboolean\fR? ?\fB\-noStatics\fR? ?\fB\-nested\fR \fIboolean\fR? ?\fB\-nestedLoadOk\fR? ?\fB\-deleteHook\fR \fIscript\fR? @@ -140,6 +143,15 @@ $slave eval [list set tk_library \e .CE .RE .TP +\fB::safe::setAutoPathSync\fR ?\fInewValue\fR? +This command is used to get or set the "Sync Mode" of the Safe Base. +When an argument is supplied, the command returns an error if the argument +is not a boolean value, or if any Safe Base interpreters exist. Typically +the value will be set as part of initialization - boolean true for +"Sync Mode" on (the default), false for "Sync Mode" off. With "Sync Mode" +on, the Safe Base keeps each slave interpreter's ::auto_path synchronized +with its access path. See the section \fBSYNC MODE\fR below for details. +.TP \fB::safe::setLogCmd\fR ?\fIcmd arg...\fR? This command installs a script that will be called when interesting life cycle events occur for a safe interpreter. @@ -191,6 +203,13 @@ master for auto-loading. See the section \fBSECURITY\fR below for more detail about virtual paths, tokens and access control. .TP +\fB\-autoPath\fR \fIdirectoryList\fR +This option sets the list of directories in the safe interpreter's +::auto_path. The option is undefined if the Safe Base has "Sync Mode" on +- in that case the safe interpreter's ::auto_path is managed by the Safe +Base and is a tokenized form of its access path. +See the section \fBSYNC MODE\fR below for details. +.TP \fB\-statics\fR \fIboolean\fR This option specifies if the safe interpreter will be allowed to load statically linked packages (like \fBload {} Tk\fR). @@ -323,7 +342,8 @@ list will be assigned a token that will be set in the slave \fBauto_path\fR and the first element of that list will be set as the \fBtcl_library\fR for that slave. .PP -If the access path argument is not given or is the empty list, +If the access path argument is not given to \fB::safe::interpCreate\fR or +\fB::safe::interpInit\fR or is the empty list, the default behavior is to let the slave access the same packages as the master has access to (Or to be more precise: only packages written in Tcl (which by definition cannot be dangerous @@ -349,8 +369,119 @@ When the \fIaccessPath\fR is changed after the first creation or initialization (i.e. through \fBinterpConfigure -accessPath \fR\fIlist\fR), an \fBauto_reset\fR is automatically evaluated in the safe interpreter to synchronize its \fBauto_index\fR with the new token list. +.SH SYNC MODE +Before Tcl version 8.6.x, the Safe Base kept each safe interpreter's +::auto_path synchronized with a tokenized form of its access path. +Limitations of Tcl 8.4 and earlier made this feature necessary. This +definition of ::auto_path did not conform its specification in library(n) +and pkg_mkIndex(n), but nevertheless worked perfectly well for the discovery +and loading of packages. The introduction of Tcl modules in Tcl 8.5 added a +large number of directories to the access path, and it is inconvenient to +have these additional directories unnecessarily appended to the ::auto_path. +.PP +In order to preserve compatibility with existing code, this synchronization +of the ::auto_path and access path ("Sync Mode" on) is still the default. +However, the Safe Base offers the option of limiting the safe interpreter's +::auto_path to the much shorter list of directories that is necessary for +it to perform its function ("Sync Mode" off). Use the command +\fB::safe::setAutoPathSync\fR to choose the mode before creating any Safe +Base interpreters. +.PP +In either mode, the most convenient way to initialize a safe interpreter is +to call \fB::safe::interpCreate\fR or \fB::safe::interpInit\fR without the +\fB\-accessPath\fR or \fB\-autoPath\fR options (or with the \fB\-accessPath\fR +option set to the +empty list), which will give the safe interpreter the same access as the +master interpreter to packages, modules, and autoloader files. With +"Sync Mode" off, the ::auto_path will be set to a tokenized form of the master's +::auto_path. +.PP +With "Sync Mode" off, if a value is specified for \fB\-autoPath\fR, even the empty +list, in a call to \fB::safe::interpCreate\fR, \fB::safe::interpInit\fR, or +\fB::safe::interpConfigure\fR, it will be tokenized and used as the safe +interpreter's ::auto_path. Any directories that do not also belong to the +access path cannot be tokenized and will be silently ignored. +.PP +With "Sync Mode" off, if the access path is reset to the values in the +master interpreter by calling \fB::safe::interpConfigure\fR with arguments +\fB\-accessPath\fR {}, then the ::auto_path will also be reset unless the argument +\fB\-autoPath\fR is supplied to specify a different value. +.PP +With "Sync Mode" off, if a non-empty value of \fB\-accessPath\fR is supplied, the +safe interpreter's ::auto_path will be set to {} (by +\fB::safe::interpCreate\fR, \fB::safe::interpInit\fR) or left unchanged +(by \fB::safe::interpConfigure\fR). If the same command specifies a new +value for \fB\-autoPath\fR, it will be applied after the \fB\-accessPath\fR argument has +been processed. + +Examples of use with "Sync Mode" off: any of these commands will set the +::auto_path to a tokenized form of its value in the master interpreter: +.RS +.PP +.CS + safe::interpCreate foo + safe::interpCreate foo -accessPath {} + safe::interpInit bar + safe::interpInit bar -accessPath {} + safe::interpConfigure foo -accessPath {} +.CE +.RE +.TP +Example of use with "Sync Mode" off: when initializing a safe interpreter +with a non-empty access path, the ::auto_path will be set to {} unless its +own value is also specified: +.RS +.PP +.CS + safe::interpCreate foo -accessPath { + /usr/local/TclHome/lib/tcl8.6 + /usr/local/TclHome/lib/tcl8.6/http1.0 + /usr/local/TclHome/lib/tcl8.6/opt0.4 + /usr/local/TclHome/lib/tcl8.6/msgs + /usr/local/TclHome/lib/tcl8.6/encoding + /usr/local/TclHome/lib + } + + # The slave's ::auto_path must be given a suitable value: + + safe::interpConfigure foo -autoPath { + /usr/local/TclHome/lib/tcl8.6 + /usr/local/TclHome/lib + } + + # The two commands can be combined: + + safe::interpCreate foo -accessPath { + /usr/local/TclHome/lib/tcl8.6 + /usr/local/TclHome/lib/tcl8.6/http1.0 + /usr/local/TclHome/lib/tcl8.6/opt0.4 + /usr/local/TclHome/lib/tcl8.6/msgs + /usr/local/TclHome/lib/tcl8.6/encoding + /usr/local/TclHome/lib + } -autoPath { + /usr/local/TclHome/lib/tcl8.6 + /usr/local/TclHome/lib + } +.CE +.RE +.TP +Example of use with "Sync Mode" off: the command +\fBsafe::interpAddToAccessPath\fR does not change the safe interpreter's +::auto_path, and so any necessary change must be made by the script: +.RS +.PP +.CS + safe::interpAddToAccessPath foo /usr/local/TclHome/lib/extras/Img1.4.11 + + lassign [safe::interpConfigure foo -autoPath] DUM slaveAutoPath + lappend slaveAutoPath /usr/local/TclHome/lib/extras/Img1.4.11 + safe::interpConfigure foo -autoPath $slaveAutoPath +.CE +.RE +.TP .SH "SEE ALSO" -interp(n), library(n), load(n), package(n), source(n), unknown(n) +interp(n), library(n), load(n), package(n), pkg_mkIndex(n), source(n), +tm(n), unknown(n) .SH KEYWORDS alias, auto\-loading, auto_mkindex, load, master interpreter, safe interpreter, slave interpreter, source -- cgit v0.12 From a6ad8c5f1b59fd374e129d9643732581744475b8 Mon Sep 17 00:00:00 2001 From: kjnash Date: Thu, 9 Jul 2020 17:56:33 +0000 Subject: Rename command ::safe::SetAutoPathSync to ::safe::setAutoPathSync and add to library/tclIndex. --- library/safe.tcl | 14 +++++----- library/tclIndex | 1 + tests/safe.test | 82 ++++++++++++++++++++++++++++---------------------------- 3 files changed, 49 insertions(+), 48 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index 54f9cc9..84db786 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -326,7 +326,7 @@ proc ::safe::InterpCreate { # # It is the caller's responsibility, if it supplies a non-empty value for # access_path, to make the first directory in the path suitable for use as -# tcl_library, and (if ![SetAutoPathSync]), to set the slave's ::auto_path. +# tcl_library, and (if ![setAutoPathSync]), to set the slave's ::auto_path. proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook autoPath withAutoPath} { global auto_path @@ -404,9 +404,9 @@ if {[info exists state(access_path,map)]} { # Set the slave auto_path to a tokenized raw_auto_path. # Silently ignore any directories that are not in the access path. - # If [SetAutoPathSync], SyncAccessPath will overwrite this value with the + # If [setAutoPathSync], SyncAccessPath will overwrite this value with the # full access path. - # If ![SetAutoPathSync], Safe Base code will not change this value. + # If ![setAutoPathSync], Safe Base code will not change this value. set tokens_auto_path {} foreach dir $raw_auto_path { if {[dict exists $remap_access_path $dir]} { @@ -1237,8 +1237,8 @@ proc ::safe::Setup {} { return } -# Accessor method for ::safe::SetAutoPathSync -# Usage: ::safe::SetAutoPathSync ?newValue? +# Accessor method for ::safe::AutoPathSync +# Usage: ::safe::setAutoPathSync ?newValue? # Respond to changes by calling Setup again, precerving any # caller-defined logging. This allows complete equivalence with # prior Safe Base behavior if AutoPathSync is true. @@ -1251,7 +1251,7 @@ proc ::safe::Setup {} { # (The initialization of AutoPathSync at the end of this file is acceptable # because Setup has not yet been called.) -proc ::safe::SetAutoPathSync {args} { +proc ::safe::setAutoPathSync {args} { variable AutoPathSync if {[llength $args] == 0} { @@ -1274,7 +1274,7 @@ proc ::safe::SetAutoPathSync {args} { setLogCmd $TmpLog } } else { - set msg {wrong # args: should be "safe::SetAutoPathSync ?newValue?"} + set msg {wrong # args: should be "safe::setAutoPathSync ?newValue?"} return -code error $msg } diff --git a/library/tclIndex b/library/tclIndex index 87a2814..6bb3fa6 100644 --- a/library/tclIndex +++ b/library/tclIndex @@ -61,6 +61,7 @@ set auto_index(::safe::DirInAccessPath) [list ::tcl::Pkg::source [file join $dir set auto_index(::safe::Subset) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::AliasSubset) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::AliasEncoding) [list ::tcl::Pkg::source [file join $dir safe.tcl]] +set auto_index(::safe::setAutoPathSync) [list source [file join $dir safe.tcl]] set auto_index(tcl_wordBreakAfter) [list ::tcl::Pkg::source [file join $dir word.tcl]] set auto_index(tcl_wordBreakBefore) [list ::tcl::Pkg::source [file join $dir word.tcl]] set auto_index(tcl_endOfWord) [list ::tcl::Pkg::source [file join $dir word.tcl]] diff --git a/tests/safe.test b/tests/safe.test index 8fb0983..4fd3eef 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -184,11 +184,11 @@ test safe-6.3 {test safe interpreters knowledge of the world} { # high level general test test safe-7.1 {tests that everything works at high level with conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::SetAutoPathSync] - safe::SetAutoPathSync 1 + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 } set i [safe::interpCreate] @@ -204,16 +204,16 @@ test safe-7.1 {tests that everything works at high level with conventional AutoP } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::SetAutoPathSync $SyncVal_TMP + safe::setAutoPathSync $SyncVal_TMP } } -match glob -result 2.* test safe-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::SetAutoPathSync] - safe::SetAutoPathSync 1 + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 } else { set SyncVal_TMP 1 } @@ -231,7 +231,7 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath with conventio [safe::interpDelete $i] } -cleanup { if {$SyncExists} { - safe::SetAutoPathSync $SyncVal_TMP + safe::setAutoPathSync $SyncVal_TMP } } -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" test safe-7.3 {check that safe subinterpreters work} { @@ -242,11 +242,11 @@ test safe-7.3 {check that safe subinterpreters work} { test safe-7.4 {tests specific path and positive search with conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::SetAutoPathSync] - safe::SetAutoPathSync 1 + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 } else { set SyncVal_TMP 1 } @@ -265,17 +265,17 @@ test safe-7.4 {tests specific path and positive search with conventional AutoPat # other than the first and last in the access path. } -cleanup { if {$SyncExists} { - safe::SetAutoPathSync $SyncVal_TMP + safe::setAutoPathSync $SyncVal_TMP } } -match glob -result "{\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {}} {}" test safe-7.5 {tests positive and negative module loading with conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::SetAutoPathSync] - safe::SetAutoPathSync 1 + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 } set i [safe::interpCreate] @@ -294,7 +294,7 @@ test safe-7.5 {tests positive and negative module loading with conventional Auto } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::SetAutoPathSync $SyncVal_TMP + safe::setAutoPathSync $SyncVal_TMP } } -result {1 {can't find package shell} 0} @@ -962,13 +962,13 @@ test safe-17.2 {Check that first element of slave auto_path (and access path) is test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without conventional AutoPathSync} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::SetAutoPathSync] - safe::SetAutoPathSync 0 + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 } else { - error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } # Without AutoPathSync, we need a more complete auto_path, because the slave will use the same value. @@ -990,19 +990,19 @@ test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without set ::auto_path $::auto_TMP safe::interpDelete $i if {$SyncExists} { - safe::SetAutoPathSync $SyncVal_TMP + safe::setAutoPathSync $SyncVal_TMP } } -result 1.0 test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::SetAutoPathSync] - safe::SetAutoPathSync 0 + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 } else { - error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] @@ -1020,19 +1020,19 @@ test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPat [safe::interpDelete $i] } -cleanup { if {$SyncExists} { - safe::SetAutoPathSync $SyncVal_TMP + safe::setAutoPathSync $SyncVal_TMP } } -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" test safe-18.3 {Check that default auto_path is the same as in the master interpreter without conventional AutoPathSync} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::SetAutoPathSync] - safe::SetAutoPathSync 0 + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 } else { - error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } set i [safe::interpCreate] @@ -1049,19 +1049,19 @@ test safe-18.3 {Check that default auto_path is the same as in the master interp } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::SetAutoPathSync $SyncVal_TMP + safe::setAutoPathSync $SyncVal_TMP } } -result [set ::auto_path] test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::SetAutoPathSync] - safe::SetAutoPathSync 0 + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 } else { - error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] @@ -1087,19 +1087,19 @@ test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_ [safe::interpDelete $i] } -cleanup { if {$SyncExists} { - safe::SetAutoPathSync $SyncVal_TMP + safe::setAutoPathSync $SyncVal_TMP } } -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {}} {}" test safe-18.5 {cf. safe-7.5 - tests positive and negative module loading without conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::SetAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::SetAutoPathSync] - safe::SetAutoPathSync 0 + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 } else { - error {This test is meaningful only if the command ::safe::SetAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } set i [safe::interpCreate] @@ -1118,7 +1118,7 @@ test safe-18.5 {cf. safe-7.5 - tests positive and negative module loading withou } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::SetAutoPathSync $SyncVal_TMP + safe::setAutoPathSync $SyncVal_TMP } } -result {1 {can't find package shell} 0} -- cgit v0.12 From 4d4cf2d35a338f40c1a4063d43cab631c796ebf3 Mon Sep 17 00:00:00 2001 From: kjnash Date: Thu, 9 Jul 2020 18:51:24 +0000 Subject: Revise tests safe-18.[24] to allow for -autoPath in interpConfigure output. Use opt in place of http 1.0 in positive/negative package search tests safe-7.[124], safe-18.[124]. --- tests/safe.test | 47 +++++++++++++++++++++++++---------------------- 1 file changed, 25 insertions(+), 22 deletions(-) diff --git a/tests/safe.test b/tests/safe.test index 4fd3eef..869b9a4 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -197,16 +197,17 @@ test safe-7.1 {tests that everything works at high level with conventional AutoP # no error shall occur: # (because the default access_path shall include 1st level sub dirs so # package require in a slave works like in the master) - set v [interp eval $i {package require http 2}] + set v [interp eval $i {package require opt}] # no error shall occur: - interp eval $i {http::config} + interp eval $i {::tcl::Lempty {a list}} set v } -cleanup { safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result 2.* +} -match glob -result 0.4.* + test safe-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -223,17 +224,17 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath with conventio set token1 [safe::interpAddToAccessPath $i [info library]] # should add as p* (not p1 if master has a module path) set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] - # an error shall occur (http is not anymore in the secure 0-level + # an error shall occur (opt is not anymore in the secure 0-level # provided deep path) list $token1 $token2 \ - [catch {interp eval $i {package require http 1}} msg] $msg \ + [catch {interp eval $i {package require opt}} msg] $msg \ [safe::interpConfigure $i]\ [safe::interpDelete $i] } -cleanup { if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" +} -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package opt} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" test safe-7.3 {check that safe subinterpreters work} { set i [safe::interpCreate] set j [safe::interpCreate [list $i x]] @@ -255,10 +256,10 @@ test safe-7.4 {tests specific path and positive search with conventional AutoPat # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] # should add as p* (not p1 if master has a module path) - set token2 [safe::interpAddToAccessPath $i [file join [info library] http1.0]] - # this time, unlike test safe-7.2, http 1.0 should be found + set token2 [safe::interpAddToAccessPath $i [file join [info library] opt]] + # this time, unlike test safe-7.2, opt should be found list $token1 $token2 \ - [catch {interp eval $i {package require http 1}} msg] $msg \ + [catch {interp eval $i {package require opt}} msg] $msg \ [safe::interpConfigure $i]\ [safe::interpDelete $i] # Note that the glob match elides directories (those from the module path) @@ -267,7 +268,7 @@ test safe-7.4 {tests specific path and positive search with conventional AutoPat if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {}} {}" +} -match glob -result "{\$p(:0:)} {\$p(:*:)} 0 0.4.* {-accessPath {[list $tcl_library *$tcl_library/opt]} -statics 0 -nested 1 -deleteHook {}} {}" test safe-7.5 {tests positive and negative module loading with conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. @@ -980,11 +981,11 @@ test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without set i [safe::interpCreate] } -body { # no error shall occur: - # (because the default access_path shall include 1st level sub dirs - # so package require in a slave works like in the master) - set v [interp eval $i {package require http 1}] + # (because the default access_path shall include 1st level sub dirs so + # package require in a slave works like in the master) + set v [interp eval $i {package require opt}] # no error shall occur: - interp eval $i {http_config} + interp eval $i {::tcl::Lempty {a list}} set v } -cleanup { set ::auto_path $::auto_TMP @@ -992,7 +993,7 @@ test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -result 1.0 +} -match glob -result 0.4.* test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. @@ -1012,17 +1013,18 @@ test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPat set token1 [safe::interpAddToAccessPath $i [info library]] # should add as p1 set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] - # an error shall occur (http is not anymore in the secure 0-level + # an error shall occur (opt is not anymore in the secure 0-level # provided deep path) list $auto1 $token1 $token2 \ - [catch {interp eval $i {package require http 1}} msg] $msg \ + [catch {interp eval $i {package require opt}} msg] $msg \ [safe::interpConfigure $i]\ [safe::interpDelete $i] } -cleanup { if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" +} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {can't find package opt} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" + test safe-18.3 {Check that default auto_path is the same as in the master interpreter without conventional AutoPathSync} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. @@ -1075,21 +1077,21 @@ test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_ set token1 [safe::interpAddToAccessPath $i [info library]] # should add as p* (not p1 if master has a module path) - set token2 [safe::interpAddToAccessPath $i [file join [info library] http1.0]] + set token2 [safe::interpAddToAccessPath $i [file join [info library] opt]] # should not have been changed by Safe Base: set auto2 [interp eval $i {set ::auto_path}] - # This time, unlike test safe-18.2 and the try above, http 1.0 should be found: + # This time, unlike test safe-18.2 and the try above, opt should be found: list $auto1 $auto2 $token1 $token2 \ - [catch {interp eval $i {package require http 1}} msg] $msg \ + [catch {interp eval $i {package require opt}} msg] $msg \ [safe::interpConfigure $i]\ [safe::interpDelete $i] } -cleanup { if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {}} {}" +} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 0.4.* {-accessPath {[list $tcl_library *$tcl_library/opt]} -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" test safe-18.5 {cf. safe-7.5 - tests positive and negative module loading without conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. @@ -1167,3 +1169,4 @@ return # Local Variables: # mode: tcl # End: + -- cgit v0.12 From 586ba274757dbac124ef994fd13adf1fd0a9cbe7 Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 14 Jul 2020 16:15:19 +0000 Subject: Sync with bugfixes and tests pushed upstream via safe-bugfixes-8-6 to core-8-6-branch. --- library/safe.tcl | 70 ++++-- library/tm.tcl | 6 +- tests/safe.test | 733 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 770 insertions(+), 39 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index 474dd01..cf2c164 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -218,11 +218,10 @@ proc ::safe::interpConfigure {args} { # Get the current (and not the default) values of whatever has # not been given: if {![::tcl::OptProcArgGiven -accessPath]} { - set doreset 1 + set doreset 0 set accessPath $state(access_path) - # BUG? is doreset the wrong way round? } else { - set doreset 0 + set doreset 1 } if {(!$AutoPathSync) && (![::tcl::OptProcArgGiven -autoPath])} { set SLAP [DetokPath $slave [$slave eval set ::auto_path]] @@ -252,8 +251,7 @@ proc ::safe::interpConfigure {args} { } # we can now reconfigure : set withAutoPath [::tcl::OptProcArgGiven -autoPath] - set res [InterpSetConfig $slave $accessPath $statics $nested $deleteHook $autoPath $withAutoPath] -puts stderr [list changed_map $res do_reset $doreset] + set slave_tm_rel [InterpSetConfig $slave $accessPath $statics $nested $deleteHook $autoPath $withAutoPath] # auto_reset the slave (to completly synch the new access_path) if {$doreset} { if {[catch {::interp eval $slave {auto_reset}} msg]} { @@ -261,6 +259,26 @@ puts stderr [list changed_map $res do_reset $doreset] } else { Log $slave "successful auto_reset" NOTICE } + + # Sync the paths used to search for Tcl modules. + ::interp eval $slave {tcl::tm::path remove {*}[tcl::tm::list]} + if {[llength $state(tm_path_slave)] > 0} { + ::interp eval $slave [list \ + ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]] + } + + # Wherever possible, refresh package/module data. + # - Ideally [package ifneeded $pkg $ver {}] would clear the + # stale data from the interpreter, but instead it sets a + # nonsense empty script. + # - We cannot purge stale package data, but we can overwrite + # it where we have fresh data. Any remaining stale data will + # do no harm but the error messages may be cryptic. + ::interp eval $slave [list catch {package require NOEXIST}] + foreach rel $slave_tm_rel { + set cmd [list package require [string map {/ ::} $rel]::NOEXIST] + ::interp eval $slave [list catch $cmd] + } } } } @@ -381,16 +399,13 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook au # We save the virtual form separately as well, as syncing it with the # slave has to be defered until the necessary commands are present for # setup. -if {[info exists state(access_path,map)]} { - set old_map_access_path $state(access_path,map) -} else { - set old_map_access_path {} -} set norm_access_path {} set slave_access_path {} set map_access_path {} set remap_access_path {} set slave_tm_path {} + set slave_tm_roots {} + set slave_tm_rel {} set i 0 foreach dir $access_path { @@ -426,6 +441,13 @@ if {[info exists state(access_path,map)]} { # Prevent the addition of dirs on the tm list to the # result if they are already known. if {[dict exists $remap_access_path $dir]} { + if {$firstpass} { + # $dir is in [::tcl::tm::list] and belongs in the slave_tm_path. + # Later passes handle subdirectories, which belong in the + # access path but not in the module path. + lappend slave_tm_path [dict get $remap_access_path $dir] + lappend slave_tm_roots [file normalize $dir] [file normalize $dir] + } continue } @@ -440,6 +462,7 @@ if {[info exists state(access_path,map)]} { # Later passes handle subdirectories, which belong in the # access path but not in the module path. lappend slave_tm_path $token + lappend slave_tm_roots [file normalize $dir] [file normalize $dir] } incr i @@ -450,6 +473,14 @@ if {[info exists state(access_path,map)]} { # 'platform/shell-X.tm', i.e arbitrarily deep # subdirectories. lappend morepaths {*}[glob -nocomplain -directory $dir -type d *] + foreach sub [glob -nocomplain -directory $dir -type d *] { + lappend slave_tm_roots [file normalize $sub] [dict get $slave_tm_roots $dir] + set lenny [string length [dict get $slave_tm_roots $dir]] + set relpath [string range [file normalize $sub] $lenny+1 end] + if {$relpath ni $slave_tm_rel} { + lappend slave_tm_rel $relpath + } + } } set firstpass 0 } @@ -465,9 +496,7 @@ if {[info exists state(access_path,map)]} { set state(cleanupHook) $deletehook SyncAccessPath $slave - - set result [expr {[lrange $map_access_path 0 end] ne [lrange $old_map_access_path 0 end]}] - return $result + return $slave_tm_rel } @@ -656,15 +685,6 @@ proc ::safe::interpDelete {slave} { namespace upvar ::safe S$slave state - # Sub interpreters would be deleted automatically, but if they are managed - # by the Safe Base we also need to clean up, and this needs to be done - # independently of the cleanupHook. - foreach sub [interp slaves $slave] { - if {[info exists ::safe::S[list $slave $sub]]} { - ::safe::interpDelete [list $slave $sub] - } - } - # If the slave has a cleanup hook registered, call it. Check the # existance because we might be called to delete an interp which has # not been registered with us at all @@ -835,15 +855,11 @@ proc ::safe::AliasGlob {slave args} { while {$at < [llength $args]} { switch -glob -- [set opt [lindex $args $at]] { - -nocomplain - -- - -tails { + -nocomplain - -- - -join - -tails { lappend cmd $opt set got($opt) 1 incr at } - -join { - set got($opt) 1 - incr at - } -types - -type { lappend cmd -types [lindex $args [incr at]] incr at diff --git a/library/tm.tcl b/library/tm.tcl index 1802bb9..3861532 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -238,12 +238,16 @@ proc ::tcl::tm::UnknownHandler {original name args} { continue } - if {[package ifneeded $pkgname $pkgversion] ne {}} { + if { ([package ifneeded $pkgname $pkgversion] ne {}) + && (![interp issafe]) + } { # There's already a provide script registered for # this version of this package. Since all units of # code claiming to be the same version of the same # package ought to be identical, just stick with # the one we already have. + # This does not apply to Safe Base interpreters because + # the token-to-directory mapping may have changed. continue } diff --git a/tests/safe.test b/tests/safe.test index ce70bf9..2de29fd 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -26,6 +26,8 @@ foreach i [interp slaves] { set saveAutoPath $::auto_path set ::auto_path [info library] +set TestsDir [file normalize [file dirname [info script]]] + # Force actual loading of the safe package because we use un exported (and # thus un-autoindexed) APIs in this test result arguments: catch {safe::interpConfigure} @@ -181,31 +183,164 @@ test safe-6.3 {test safe interpreters knowledge of the world} { # More test should be added to check that hostname, nameofexecutable, aren't # leaking infos, but they still do... +# Tests 7.0* test the example files before using them to test safe interpreters. + +test safe-7.0a {example tclIndex commands, test in master interpreter} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0 auto1] [file join $TestsDir auto0 auto2] +} -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 +} -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {0 ok1 0 ok2} + +test safe-7.0b {example tclIndex commands, negative test in master interpreter} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] +} -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 +} -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}} + +test safe-7.0c {example pkgIndex.tcl packages, test in master interpreter, child directories} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 +} -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} + +test safe-7.0d {example pkgIndex.tcl packages, test in master interpreter, main directories} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 +} -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} + +test safe-7.0e {example modules packages, test in master interpreter, replace path} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + set out0 [test0::try0] + set out1 [mod1::test1::try1] + set out2 [mod2::test2::try2] + + list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + catch {namespace delete ::test0} + catch {namespace delete ::mod1} +} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} + +test safe-7.0f {example modules packages, test in master interpreter, append to path} -setup { + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + set out0 [test0::try0] + set out1 [mod1::test1::try1] + set out2 [mod2::test2::try2] + + list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + catch {namespace delete ::test0} + catch {namespace delete ::mod1} +} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} + # high level general test +# Use example packages not http1.0 test safe-7.1 {tests that everything works at high level with conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 1 } - + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] set i [safe::interpCreate] - + set ::auto_path $tmpAutoPath } -body { # no error shall occur: # (because the default access_path shall include 1st level sub dirs so # package require in a slave works like in the master) - set v [interp eval $i {package require http 2}] + set v [interp eval $i {package require SafeTestPackage1}] # no error shall occur: - interp eval $i {http::config} + interp eval $i {HeresPackage1} set v } -cleanup { safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } +} -match glob -result 1.2.3 +# high level general test +test safe-7.1http {tests that everything works at high level, uses http 2} -body { + set i [safe::interpCreate] + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs so + # package require in a slave works like in the master) + set v [interp eval $i {package require http 2}] + # no error shall occur: + interp eval $i {http::config} + safe::interpDelete $i + set v } -match glob -result 2.* test safe-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. @@ -223,16 +358,34 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath with conventio set token1 [safe::interpAddToAccessPath $i [info library]] # should add as p* (not p1 if master has a module path) set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] - # an error shall occur (http is not anymore in the secure 0-level + # should add as p* (not p2 if master has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]] + # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level # provided deep path) - list $token1 $token2 \ - [catch {interp eval $i {package require http 1}} msg] $msg \ + list $token1 $token2 $token3 \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ [safe::interpConfigure $i]\ [safe::interpDelete $i] } -cleanup { if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } +} -match glob -result "{\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 1\ + {can't find package SafeTestPackage1}\ + {-accessPath {[list $tcl_library */dummy/unixlike/test/path $TestsDir/auto0]}\ + -statics 0 -nested 1 -deleteHook {}} {}" +test safe-7.2http {tests specific path and interpFind/AddToAccessPath, uses http1.0} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p1 + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + # an error shall occur (http is not anymore in the secure 0-level + # provided deep path) + list $token1 $token2 \ + [catch {interp eval $i {package require http 1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] } -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" test safe-7.3 {check that safe subinterpreters work} { set i [safe::interpCreate] @@ -255,10 +408,10 @@ test safe-7.4 {tests specific path and positive search with conventional AutoPat # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] # should add as p* (not p1 if master has a module path) - set token2 [safe::interpAddToAccessPath $i [file join [info library] http1.0]] - # this time, unlike test safe-7.2, http 1.0 should be found + set token2 [safe::interpAddToAccessPath $i [file join $TestsDir auto0 auto1]] + # this time, unlike test safe-7.2, SafeTestPackage1 should be found list $token1 $token2 \ - [catch {interp eval $i {package require http 1}} msg] $msg \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ [safe::interpConfigure $i]\ [safe::interpDelete $i] # Note that the glob match elides directories (those from the module path) @@ -267,6 +420,20 @@ test safe-7.4 {tests specific path and positive search with conventional AutoPat if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } +} -match glob -result "{\$p(:0:)} {\$p(:*:)} 0 1.2.3\ + {-accessPath {[list $tcl_library * $TestsDir/auto0/auto1]}\ + -statics 0 -nested 1 -deleteHook {}} {}" +test safe-7.4http {tests specific path and positive search, uses http1.0} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p1 + set token2 [safe::interpAddToAccessPath $i [file join [info library] http1.0]] + # this time, unlike test safe-7.2, http should be found + list $token1 $token2 \ + [catch {interp eval $i {package require http 1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] } -match glob -result "{\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {}} {}" test safe-7.5 {tests positive and negative module loading with conventional AutoPathSync} -setup { @@ -494,6 +661,549 @@ test safe-9.6 {interpConfigure widget like behaviour} -body { } -cleanup { safe::interpDelete $i } -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} +test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { + # this test shall work, believed equivalent to 9.6 + set i [safe::interpCreate \ + -noStatics \ + -nestedLoadOk \ + -deleteHook {foo bar} \ + ] + + safe::interpConfigure $i -accessPath /foo/bar + set a [safe::interpConfigure $i] + set b [safe::interpConfigure $i -aCCess] + set c [safe::interpConfigure $i -nested] + set d [safe::interpConfigure $i -statics] + set e [safe::interpConfigure $i -DEL] + safe::interpConfigure $i -accessPath /blah -statics 1 + set f [safe::interpConfigure $i] + safe::interpConfigure $i -deleteHook toto -nosta -nested 0 + set g [safe::interpConfigure $i] + + list $a $b $c $d $e $f $g +} -cleanup { + safe::interpDelete $i +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} + +test safe-9.8 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset)} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Load and run the commands. + # This guarantees the test will pass even if the tokens are swapped. + set code1 [catch {interp eval $i {report1}} msg1] + set code2 [catch {interp eval $i {report2}} msg2] + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + + # Inspect. + set confB [safe::interpConfigure $i] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB +} -cleanup { + safe::interpDelete $i +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 ok1 0 ok2\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto2 $TestsDir/auto0/auto1]*}\ + -statics 1 -nested 0 -deleteHook {}}" + +test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset)} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Do not load the commands. With the tokens swapped, the test + # will pass only if the Safe Base has called auto_reset. + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + + # Inspect. + set confB [safe::interpConfigure $i] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load and run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB +} -cleanup { + safe::interpDelete $i +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 ok1 0 ok2\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto2 $TestsDir/auto0/auto1]*}\ + -statics 1 -nested 0 -deleteHook {}}" + +test safe-9.10 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement} -setup { +} -body { + # For complete correspondence to safe-9.10opt, include auto0 in access path. + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}. + # This would have no effect because the records in Pkg of these directories + # were from access as children of {$p(:1:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + + # Inspect. + set confB [safe::interpConfigure $i] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB \ + $code5 $msg5 $code6 $msg6 + +} -cleanup { + safe::interpDelete $i +} -match glob -result "{\$p(:2:)} {\$p(:3:)} {\$p(:3:)} {\$p(:2:)} 0 1.2.3 0 2.3.4\ + {-accessPath {[list $tcl_library $TestsDir/auto0 $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library $TestsDir/auto0 $TestsDir/auto0/auto2 $TestsDir/auto0/auto1]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + 0 OK1 0 OK2" + +test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + + # Inspect. + set confB [safe::interpConfigure $i] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB \ + $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 1.2.3 0 2.3.4\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto2 $TestsDir/auto0/auto1]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + 0 OK1 0 OK2" + +test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed} -setup { +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library] + + # Inspect. + set confB [safe::interpConfigure $i] + set code4 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]} path4] + set code5 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]} path5] + + # Try to load the packages. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] + set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6] + + list $path1 $path2 $code4 $path4 $code5 $path5 $code3 $msg3 $code6 $msg6 $confA $confB +} -cleanup { + safe::interpDelete $i +} -match glob -result "{\$p(:1:)} {\$p(:2:)} 1 {* not found in access path}\ + 1 {* not found in access path} 1 {*} 1 {*}\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library]*} -statics 1 -nested 0 -deleteHook {}}" + +test safe-9.20 {check module loading} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list $path0 $path1 $path2 -- $modsA -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {-accessPath {[list $tcl_library $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]*}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" + +test safe-9.21 {interpConfigure change the access path; check module loading; stale data case 1} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + + # Inspect. + set confB [safe::interpConfigure $i] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Load pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/auto1 \ + $TestsDir/auto0/auto2 \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" + +test safe-9.22 {interpConfigure change the access path; check module loading; stale data case 0} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + + # Inspect. + set confB [safe::interpConfigure $i] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/auto1 \ + $TestsDir/auto0/auto2 \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" + +test safe-9.23 {interpConfigure change the access path; check module loading; stale data case 3} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + + # Inspect. + set confB [safe::interpConfigure $i] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Refresh stale pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + $out0 $out1 $out2 + +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/auto1 \ + $TestsDir/auto0/auto2 \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" + +test safe-9.24 {interpConfigure change the access path; check module loading; stale data case 2 (worst case)} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + + # Inspect. + set confB [safe::interpConfigure $i] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/auto1 \ + $TestsDir/auto0/auto2 \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" + catch {teststaticpkg Safepkg1 0 0} test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { @@ -1164,6 +1874,7 @@ test safe-19.2 {Check that each directory of the module path is a valid token} - set ::auto_path $saveAutoPath +unset saveAutoPath TestsDir # cleanup ::tcltest::cleanupTests return -- cgit v0.12 From b1d03f8f36eac45fe770b94db11c95d3e17eedf5 Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 14 Jul 2020 16:49:10 +0000 Subject: Sync with bugfixes and tests pushed upstream via safe-extra-tests-8-7 and safe-bugfixes-8-6 to core-8-branch --- library/safe.tcl | 57 +- library/tm.tcl | 7 +- tests/safe.test | 2191 ++++++++++++++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 2167 insertions(+), 88 deletions(-) diff --git a/library/safe.tcl b/library/safe.tcl index 84db786..9218380 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -218,11 +218,10 @@ proc ::safe::interpConfigure {args} { # Get the current (and not the default) values of whatever has # not been given: if {![::tcl::OptProcArgGiven -accessPath]} { - set doreset 1 + set doreset 0 set accessPath $state(access_path) - # BUG? is doreset the wrong way round? } else { - set doreset 0 + set doreset 1 } if {(!$AutoPathSync) && (![::tcl::OptProcArgGiven -autoPath])} { set SLAP [DetokPath $slave [$slave eval set ::auto_path]] @@ -252,15 +251,35 @@ proc ::safe::interpConfigure {args} { } # we can now reconfigure : set withAutoPath [::tcl::OptProcArgGiven -autoPath] - set res [InterpSetConfig $slave $accessPath $statics $nested $deleteHook $autoPath $withAutoPath] -puts stderr [list changed_map $res do_reset $doreset] - # auto_reset the slave (to completly synch the new access_path) + set slave_tm_rel [InterpSetConfig $slave $accessPath $statics $nested $deleteHook $autoPath $withAutoPath] + + # auto_reset the slave (to completely synch the new access_path) tests safe-9.8 safe-9.9 if {$doreset} { if {[catch {::interp eval $slave {auto_reset}} msg]} { Log $slave "auto_reset failed: $msg" } else { Log $slave "successful auto_reset" NOTICE } + + # Sync the paths used to search for Tcl modules. + ::interp eval $slave {tcl::tm::path remove {*}[tcl::tm::list]} + if {[llength $state(tm_path_slave)] > 0} { + ::interp eval $slave [list \ + ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]] + } + + # Wherever possible, refresh package/module data. + # - Ideally [package ifneeded $pkg $ver {}] would clear the + # stale data from the interpreter, but instead it sets a + # nonsense empty script. + # - We cannot purge stale package data, but we can overwrite + # it where we have fresh data. Any remaining stale data will + # do no harm but the error messages may be cryptic. + ::interp eval $slave [list catch {package require NOEXIST}] + foreach rel $slave_tm_rel { + set cmd [list package require [string map {/ ::} $rel]::NOEXIST] + ::interp eval $slave [list catch $cmd] + } } } } @@ -381,16 +400,13 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook au # We save the virtual form separately as well, as syncing it with the # slave has to be defered until the necessary commands are present for # setup. -if {[info exists state(access_path,map)]} { - set old_map_access_path $state(access_path,map) -} else { - set old_map_access_path {} -} set norm_access_path {} set slave_access_path {} set map_access_path {} set remap_access_path {} set slave_tm_path {} + set slave_tm_roots {} + set slave_tm_rel {} set i 0 foreach dir $access_path { @@ -426,6 +442,13 @@ if {[info exists state(access_path,map)]} { # Prevent the addition of dirs on the tm list to the # result if they are already known. if {[dict exists $remap_access_path $dir]} { + if {$firstpass} { + # $dir is in [::tcl::tm::list] and belongs in the slave_tm_path. + # Later passes handle subdirectories, which belong in the + # access path but not in the module path. + lappend slave_tm_path [dict get $remap_access_path $dir] + lappend slave_tm_roots [file normalize $dir] [file normalize $dir] + } continue } @@ -440,6 +463,7 @@ if {[info exists state(access_path,map)]} { # Later passes handle subdirectories, which belong in the # access path but not in the module path. lappend slave_tm_path $token + lappend slave_tm_roots [file normalize $dir] [file normalize $dir] } incr i @@ -450,6 +474,14 @@ if {[info exists state(access_path,map)]} { # 'platform/shell-X.tm', i.e arbitrarily deep # subdirectories. lappend morepaths {*}[glob -nocomplain -directory $dir -type d *] + foreach sub [glob -nocomplain -directory $dir -type d *] { + lappend slave_tm_roots [file normalize $sub] [dict get $slave_tm_roots $dir] + set lenny [string length [dict get $slave_tm_roots $dir]] + set relpath [string range [file normalize $sub] $lenny+1 end] + if {$relpath ni $slave_tm_rel} { + lappend slave_tm_rel $relpath + } + } } set firstpass 0 } @@ -466,8 +498,7 @@ if {[info exists state(access_path,map)]} { SyncAccessPath $slave - set result [expr {[lrange $map_access_path 0 end] ne [lrange $old_map_access_path 0 end]}] - return $result + return $slave_tm_rel } diff --git a/library/tm.tcl b/library/tm.tcl index 1802bb9..94ebb46 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -237,13 +237,16 @@ proc ::tcl::tm::UnknownHandler {original name args} { # acceptable to "package vcompare". continue } - - if {[package ifneeded $pkgname $pkgversion] ne {}} { + if { ([package ifneeded $pkgname $pkgversion] ne {}) + && (![interp issafe]) + } { # There's already a provide script registered for # this version of this package. Since all units of # code claiming to be the same version of the same # package ought to be identical, just stick with # the one we already have. + # This does not apply to Safe Base interpreters because + # the token-to-directory mapping may have changed. continue } diff --git a/tests/safe.test b/tests/safe.test index 869b9a4..75dc2bf 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -26,7 +26,63 @@ foreach i [interp slaves] { set saveAutoPath $::auto_path set ::auto_path [info library] -# Force actual loading of the safe package because we use un exported (and +# The defunct package http 1.0 was convenient for testing package loading. +# - Replaced here with tests using example packages provided in subdirectory +# auto0 of the tests directory, which are independent of any changes +# made to the packages provided with Tcl. +# - These are tests 7.1 7.2 7.4 9.10 9.12 18.1 18.2 18.4 +# - Tests 7.0[a-f] test the example packages themselves before they +# are used to test Safe Base interpreters. +# - Alternatively use packages opt and (from cookiejar) tcl::idna. +# - These alternative tests have suffix "opt". +# - These are 7.[124]opt, 9.1[02]opt, 18.[124]opt. +# - Tests 7.[124]opt, 9.1[02]opt, 18.[124]opt use "package require opt". +# - Tests 9.1[02]opt also use "package require tcl::idna". +# +# When using package opt for testing positive/negative package search: +# - The directory location and the error message depend on whether +# and how the package is installed. + +# Error message for tests 7.2opt, 18.2opt for "package require opt". +if {[string match *zipfs:/* [info library]]} { + # pkgIndex.tcl is in [info library] + # file to be sourced is in [info library]/opt* + set pkgOptErrMsg {permission denied} +} else { + # pkgIndex.tcl and file to be sourced are + # both in [info library]/opt* + set pkgOptErrMsg {can't find package opt} +} + +# Directory of opt for tests 7.4opt, 9.10opt, 9.12opt, 18.4opt +# for "package require opt". +if {[file exists [file join [info library] opt0.4]]} { + # Installed files in lib8.7/opt0.4 + set pkgOptDir opt0.4 +} elseif {[file exists [file join [info library] opt]]} { + # Installed files in zipfs, or source files used by "make test" + set pkgOptDir opt +} else { + error {cannot find opt library} +} + +# Directory of cookiejar for tests 9.10opt, 9.12opt +# for "package require tcl::idna". +if {[file exists [file join [info library] cookiejar0.2]]} { + # Installed files in lib8.7/cookiejar0.2 + set pkgJarDir cookiejar0.2 +} elseif {[file exists [file join [info library] cookiejar]]} { + # Installed files in zipfs, or source files used by "make test" + set pkgJarDir cookiejar +} else { + error {cannot find cookiejar library} +} + +set TestsDir [file normalize [file dirname [info script]]] +set ZipMountPoint [zipfs root]auto-files +zipfs mount $ZipMountPoint [file join $TestsDir auto-files.zip] + +# Force actual loading of the safe package because we use un-exported (and # thus un-autoindexed) APIs in this test result arguments: catch {safe::interpConfigure} @@ -181,8 +237,247 @@ test safe-6.3 {test safe interpreters knowledge of the world} { # More test should be added to check that hostname, nameofexecutable, aren't # leaking infos, but they still do... +# Tests 7.0* test the example files before using them to test safe interpreters. + +test safe-7.0a {example tclIndex commands, test in master interpreter} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0 auto1] [file join $TestsDir auto0 auto2] +} -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 +} -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {0 ok1 0 ok2} + +test safe-7.0b {example tclIndex commands, negative test in master interpreter} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] +} -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 +} -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}} + +test safe-7.0c {example pkgIndex.tcl packages, test in master interpreter, child directories} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 +} -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} + +test safe-7.0d {example pkgIndex.tcl packages, test in master interpreter, main directories} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 +} -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} + +test safe-7.0e {example modules packages, test in master interpreter, replace path} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + set out0 [test0::try0] + set out1 [mod1::test1::try1] + set out2 [mod2::test2::try2] + + list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + catch {namespace delete ::test0} + catch {namespace delete ::mod1} +} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} + +test safe-7.0f {example modules packages, test in master interpreter, append to path} -setup { + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + set out0 [test0::try0] + set out1 [mod1::test1::try1] + set out2 [mod2::test2::try2] + + list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + catch {namespace delete ::test0} + catch {namespace delete ::mod1} +} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} + +test safe-7.0az {example tclIndex commands, test in master interpreter; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2] +} -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 +} -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {0 ok1 0 ok2} + +test safe-7.0bz {example tclIndex commands, negative test in master interpreter; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0] +} -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 +} -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}} + +test safe-7.0cz {example pkgIndex.tcl packages, test in master interpreter, child directories; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 +} -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} + +test safe-7.0dz {example pkgIndex.tcl packages, test in master interpreter, main directories; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 +} -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} + +test safe-7.0ez {example modules packages, test in master interpreter, replace path; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + set out0 [test0::try0] + set out1 [mod1::test1::try1] + set out2 [mod2::test2::try2] + + list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + catch {namespace delete ::test0} + catch {namespace delete ::mod1} +} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} + +test safe-7.0fz {example modules packages, test in master interpreter, append to path; zipfs} -setup { + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + # Try to load the modules and run a command from each one. + set code0 [catch {package require test0} msg0] + set code1 [catch {package require mod1::test1} msg1] + set code2 [catch {package require mod2::test2} msg2] + set out0 [test0::try0] + set out1 [mod1::test1::try1] + set out2 [mod2::test2::try2] + + list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + catch {package forget test0} + catch {package forget mod1::test1} + catch {package forget mod2::test2} + catch {namespace delete ::test0} + catch {namespace delete ::mod1} +} -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} + + # high level general test -test safe-7.1 {tests that everything works at high level with conventional AutoPathSync} -setup { +test safe-7.1opt {tests that everything works at high level with conventional AutoPathSync, use pkg opt} -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -208,7 +503,67 @@ test safe-7.1 {tests that everything works at high level with conventional AutoP } } -match glob -result 0.4.* -test safe-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync} -setup { +# high level general test +# Use example packages not tcl8.x/opt +test safe-7.1 {tests that everything works at high level with conventional AutoPathSync} -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] + set i [safe::interpCreate] + set ::auto_path $tmpAutoPath +} -body { + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs so + # package require in a slave works like in the master) + set v [interp eval $i {package require SafeTestPackage1}] + # no error shall occur: + interp eval $i {HeresPackage1} + set v +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result 1.2.3 + +# high level general test +# Use zipped example packages not tcl8.x/opt +test safe-7.1z {tests that everything works at high level with conventional AutoPathSync; zipfs} -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $TestsDir auto0] + set i [safe::interpCreate] + set ::auto_path $tmpAutoPath +} -body { + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs so + # package require in a slave works like in the master) + set v [interp eval $i {package require SafeTestPackage1}] + # no error shall occur: + interp eval $i {HeresPackage1} + set v +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result 1.2.3 + +test safe-7.2opt {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync, use pkg opt} -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -234,14 +589,83 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath with conventio if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package opt} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}" +} -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {$pkgOptErrMsg}\ + {-accessPath {[list $tcl_library */dummy/unixlike/test/path]}\ + -statics 0 -nested 1 -deleteHook {}} {}" + +test safe-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync} -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } else { + set SyncVal_TMP 1 + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if master has a module path) + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + # should add as p* (not p2 if master has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]] + # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level + # provided deep path) + list $token1 $token2 $token3 \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] +} -cleanup { + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 1\ + {can't find package SafeTestPackage1}\ + {-accessPath {[list $tcl_library */dummy/unixlike/test/path $TestsDir/auto0]}\ + -statics 0 -nested 1 -deleteHook {}} {}" + +test safe-7.2z {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync; zipfs} -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } else { + set SyncVal_TMP 1 + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if master has a module path) + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + # should add as p* (not p2 if master has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]] + # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level + # provided deep path) + list $token1 $token2 $token3 \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] +} -cleanup { + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 1\ + {can't find package SafeTestPackage1}\ + {-accessPath {[list $tcl_library */dummy/unixlike/test/path $TestsDir/auto0]}\ + -statics 0 -nested 1 -deleteHook {}} {}" + test safe-7.3 {check that safe subinterpreters work} { set i [safe::interpCreate] set j [safe::interpCreate [list $i x]] list [interp eval $j {join {o k} ""}] [safe::interpDelete $i] [interp exists $j] } {ok {} 0} -test safe-7.4 {tests specific path and positive search with conventional AutoPathSync} -setup { +test safe-7.4opt {tests specific path and positive search with conventional AutoPathSync, use pkg opt} -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -256,8 +680,8 @@ test safe-7.4 {tests specific path and positive search with conventional AutoPat # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] # should add as p* (not p1 if master has a module path) - set token2 [safe::interpAddToAccessPath $i [file join [info library] opt]] - # this time, unlike test safe-7.2, opt should be found + set token2 [safe::interpAddToAccessPath $i [file join [info library] $pkgOptDir]] + # this time, unlike test safe-7.2opt, opt should be found list $token1 $token2 \ [catch {interp eval $i {package require opt}} msg] $msg \ [safe::interpConfigure $i]\ @@ -268,7 +692,71 @@ test safe-7.4 {tests specific path and positive search with conventional AutoPat if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{\$p(:0:)} {\$p(:*:)} 0 0.4.* {-accessPath {[list $tcl_library *$tcl_library/opt]} -statics 0 -nested 1 -deleteHook {}} {}" +} -match glob -result "{\$p(:0:)} {\$p(:*:)} 0 0.4.*\ + {-accessPath {[list $tcl_library *$tcl_library/$pkgOptDir]}\ + -statics 0 -nested 1 -deleteHook {}} {}" + +test safe-7.4 {tests specific path and positive search with conventional AutoPathSync} -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } else { + set SyncVal_TMP 1 + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if master has a module path) + set token2 [safe::interpAddToAccessPath $i [file join $TestsDir auto0 auto1]] + # this time, unlike test safe-7.2, SafeTestPackage1 should be found + list $token1 $token2 \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] + # Note that the glob match elides directories (those from the module path) + # other than the first and last in the access path. +} -cleanup { + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:0:)} {\$p(:*:)} 0 1.2.3\ + {-accessPath {[list $tcl_library * $TestsDir/auto0/auto1]}\ + -statics 0 -nested 1 -deleteHook {}} {}" + +test safe-7.4z {tests specific path and positive search with conventional AutoPathSync; zipfs} -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } else { + set SyncVal_TMP 1 + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if master has a module path) + set token2 [safe::interpAddToAccessPath $i [file join $TestsDir auto0 auto1]] + # this time, unlike test safe-7.2z, SafeTestPackage1 should be found + list $token1 $token2 \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] + # Note that the glob match elides directories (those from the module path) + # other than the first and last in the access path. +} -cleanup { + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:0:)} {\$p(:*:)} 0 1.2.3\ + {-accessPath {[list $tcl_library * $TestsDir/auto0/auto1]}\ + -statics 0 -nested 1 -deleteHook {}} {}" test safe-7.5 {tests positive and negative module loading with conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. @@ -439,62 +927,1377 @@ test safe-9.1 {safe interps' deleteHook} -setup { # mark that we've been here (successfully) set res $args } - safe::interpCreate $i -deleteHook "testDelHook arg1 arg2" - list [interp eval $i exit] $res -} -result {{} {arg1 arg2 a}} -test safe-9.2 {safe interps' error in deleteHook} -setup { - catch {safe::interpDelete $i} - set res {} - set log {} - proc safe-test-log {str} {lappend ::log $str} - set prevlog [safe::setLogCmd] -} -body { - proc testDelHook {args} { - global res - # the interp still exists at that point - interp eval a {set delete 1} - # mark that we've been here (successfully) - set res $args - # create an exception - error "being catched" + safe::interpCreate $i -deleteHook "testDelHook arg1 arg2" + list [interp eval $i exit] $res +} -result {{} {arg1 arg2 a}} +test safe-9.2 {safe interps' error in deleteHook} -setup { + catch {safe::interpDelete $i} + set res {} + set log {} + proc safe-test-log {str} {lappend ::log $str} + set prevlog [safe::setLogCmd] +} -body { + proc testDelHook {args} { + global res + # the interp still exists at that point + interp eval a {set delete 1} + # mark that we've been here (successfully) + set res $args + # create an exception + error "being catched" + } + safe::interpCreate $i -deleteHook "testDelHook arg1 arg2" + safe::setLogCmd safe-test-log + list [safe::interpDelete $i] $res $log +} -cleanup { + safe::setLogCmd $prevlog + unset log +} -result {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}}} +test safe-9.3 {dual specification of statics} -returnCodes error -body { + safe::interpCreate -stat true -nostat +} -result {conflicting values given for -statics and -noStatics} +test safe-9.4 {dual specification of statics} { + # no error shall occur + safe::interpDelete [safe::interpCreate -stat false -nostat] +} {} +test safe-9.5 {dual specification of nested} -returnCodes error -body { + safe::interpCreate -nested 0 -nestedload +} -result {conflicting values given for -nested and -nestedLoadOk} +test safe-9.6 {interpConfigure widget like behaviour} -body { + # this test shall work, don't try to "fix it" unless you *really* know what + # you are doing (ie you are me :p) -- dl + list [set i [safe::interpCreate \ + -noStatics \ + -nestedLoadOk \ + -deleteHook {foo bar}] + safe::interpConfigure $i -accessPath /foo/bar + safe::interpConfigure $i]\ + [safe::interpConfigure $i -aCCess]\ + [safe::interpConfigure $i -nested]\ + [safe::interpConfigure $i -statics]\ + [safe::interpConfigure $i -DEL]\ + [safe::interpConfigure $i -accessPath /blah -statics 1 + safe::interpConfigure $i]\ + [safe::interpConfigure $i -deleteHook toto -nosta -nested 0 + safe::interpConfigure $i] +} -cleanup { + safe::interpDelete $i +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} + +test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { + # this test shall work, believed equivalent to 9.6 + set i [safe::interpCreate \ + -noStatics \ + -nestedLoadOk \ + -deleteHook {foo bar} \ + ] + + safe::interpConfigure $i -accessPath /foo/bar + set a [safe::interpConfigure $i] + set b [safe::interpConfigure $i -aCCess] + set c [safe::interpConfigure $i -nested] + set d [safe::interpConfigure $i -statics] + set e [safe::interpConfigure $i -DEL] + safe::interpConfigure $i -accessPath /blah -statics 1 + set f [safe::interpConfigure $i] + safe::interpConfigure $i -deleteHook toto -nosta -nested 0 + set g [safe::interpConfigure $i] + + list $a $b $c $d $e $f $g +} -cleanup { + safe::interpDelete $i +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} + +test safe-9.8 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset)} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Load and run the commands. + # This guarantees the test will pass even if the tokens are swapped. + set code1 [catch {interp eval $i {report1}} msg1] + set code2 [catch {interp eval $i {report2}} msg2] + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + + # Inspect. + set confB [safe::interpConfigure $i] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 ok1 0 ok2\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto2 $TestsDir/auto0/auto1]*}\ + -statics 1 -nested 0 -deleteHook {}}" + +test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset)} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Do not load the commands. With the tokens swapped, the test + # will pass only if the Safe Base has called auto_reset. + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + + # Inspect. + set confB [safe::interpConfigure $i] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load and run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 ok1 0 ok2\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto2 $TestsDir/auto0/auto1]*}\ + -statics 1 -nested 0 -deleteHook {}}" + +test safe-9.10opt {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, use pkg opt and tcl::idna} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $tcl_library $pkgOptDir] \ + [file join $tcl_library $pkgJarDir]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]] + set path2 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + # This has no effect because the records in Pkg of these directories were from access as children of {$p(:0:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $tcl_library $pkgJarDir] \ + [file join $tcl_library $pkgOptDir]] + + # Inspect. + set confB [safe::interpConfigure $i] + set path3 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]] + set path4 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require tcl::idna}} msg3] + set code4 [catch {interp eval $i {package require opt}} msg4] + set code5 [catch {interp eval $i {::tcl::Lempty {a list}}} msg5] + set code6 [catch {interp eval $i {::tcl::idna::IDNAencode example.com}} msg6] + + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 \ + $confA $confB $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 1.* 0 0.4.*\ + {-accessPath {[list $tcl_library $tcl_library/$pkgOptDir $tcl_library/$pkgJarDir]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library $tcl_library/$pkgJarDir $tcl_library/$pkgOptDir]*}\ + -statics 1 -nested 0 -deleteHook {}} 0 0 0 example.com" + +test safe-9.10 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } +} -body { + # For complete correspondence to safe-9.10opt, include auto0 in access path. + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}. + # This would have no effect because the records in Pkg of these directories + # were from access as children of {$p(:1:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + + # Inspect. + set confB [safe::interpConfigure $i] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB \ + $code5 $msg5 $code6 $msg6 + +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:2:)} {\$p(:3:)} {\$p(:3:)} {\$p(:2:)} 0 1.2.3 0 2.3.4\ + {-accessPath {[list $tcl_library $TestsDir/auto0 $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library $TestsDir/auto0 $TestsDir/auto0/auto2 $TestsDir/auto0/auto1]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + 0 OK1 0 OK2" + +test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + + # Inspect. + set confB [safe::interpConfigure $i] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB \ + $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 1.2.3 0 2.3.4\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto2 $TestsDir/auto0/auto1]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + 0 OK1 0 OK2" + +test safe-9.12opt {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, use pkg opt and tcl::idna} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $tcl_library $pkgOptDir] \ + [file join $tcl_library $pkgJarDir]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]] + set path2 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library] + + # Inspect. + set confB [safe::interpConfigure $i] + set code4 [catch {::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]} path4] + set code5 [catch {::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]} path5] + + # Try to load the packages. + set code3 [catch {interp eval $i {package require opt}} msg3] + set code6 [catch {interp eval $i {package require tcl::idna}} msg6] + + list $path1 $path2 $code4 $path4 $code5 $path5 $code3 $msg3 $code6 $msg6 $confA $confB +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} 1 {* not found in access path}\ + 1 {* not found in access path} 1 {*} 1 {*}\ + {-accessPath {[list $tcl_library $tcl_library/$pkgOptDir $tcl_library/$pkgJarDir]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library]*} -statics 1 -nested 0 -deleteHook {}}" + +test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library] + + # Inspect. + set confB [safe::interpConfigure $i] + set code4 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]} path4] + set code5 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]} path5] + + # Try to load the packages. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] + set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6] + + list $path1 $path2 $code4 $path4 $code5 $path5 $code3 $msg3 $code6 $msg6 $confA $confB +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} 1 {* not found in access path}\ + 1 {* not found in access path} 1 {*} 1 {*}\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library]*} -statics 1 -nested 0 -deleteHook {}}" + +test safe-9.20 {check module loading} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list $path0 $path1 $path2 -- $modsA -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {-accessPath {[list $tcl_library $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]*}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" + +test safe-9.21 {interpConfigure change the access path; check module loading; stale data case 1} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + + # Inspect. + set confB [safe::interpConfigure $i] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Load pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/auto1 \ + $TestsDir/auto0/auto2 \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" + +test safe-9.22 {interpConfigure change the access path; check module loading; stale data case 0} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + + # Inspect. + set confB [safe::interpConfigure $i] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/auto1 \ + $TestsDir/auto0/auto2 \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" + +test safe-9.23 {interpConfigure change the access path; check module loading; stale data case 3} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + + # Inspect. + set confB [safe::interpConfigure $i] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Refresh stale pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + $out0 $out1 $out2 + +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/auto1 \ + $TestsDir/auto0/auto2 \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" + +test safe-9.24 {interpConfigure change the access path; check module loading; stale data case 2 (worst case)} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + + # Inspect. + set confB [safe::interpConfigure $i] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/auto1 \ + $TestsDir/auto0/auto2 \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" + + +test safe-9.8z {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset); zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Load and run the commands. + # This guarantees the test will pass even if the tokens are swapped. + set code1 [catch {interp eval $i {report1}} msg1] + set code2 [catch {interp eval $i {report2}} msg2] + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + + # Inspect. + set confB [safe::interpConfigure $i] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 ok1 0 ok2\ + {-accessPath {[list $tcl_library $ZipMountPoint/auto0/auto1 $ZipMountPoint/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library $ZipMountPoint/auto0/auto2 $ZipMountPoint/auto0/auto1]*}\ + -statics 1 -nested 0 -deleteHook {}}" + +test safe-9.9z {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset); zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Do not load the commands. With the tokens swapped, the test + # will pass only if the Safe Base has called auto_reset. + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + + # Inspect. + set confB [safe::interpConfigure $i] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load and run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 ok1 0 ok2\ + {-accessPath {[list $tcl_library $ZipMountPoint/auto0/auto1 $ZipMountPoint/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library $ZipMountPoint/auto0/auto2 $ZipMountPoint/auto0/auto1]*}\ + -statics 1 -nested 0 -deleteHook {}}" + +test safe-9.10z {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement; zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } +} -body { + # For complete correspondence to safe-9.10opt, include auto0 in access path. + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0] \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}. + # This would have no effect because the records in Pkg of these directories + # were from access as children of {$p(:1:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0] \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + + # Inspect. + set confB [safe::interpConfigure $i] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB \ + $code5 $msg5 $code6 $msg6 + +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:2:)} {\$p(:3:)} {\$p(:3:)} {\$p(:2:)} 0 1.2.3 0 2.3.4\ + {-accessPath {[list $tcl_library $ZipMountPoint/auto0 $ZipMountPoint/auto0/auto1 $ZipMountPoint/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library $ZipMountPoint/auto0 $ZipMountPoint/auto0/auto2 $ZipMountPoint/auto0/auto1]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + 0 OK1 0 OK2" + +test safe-9.11z {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0; zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + + # Inspect. + set confB [safe::interpConfigure $i] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB \ + $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 1.2.3 0 2.3.4\ + {-accessPath {[list $tcl_library $ZipMountPoint/auto0/auto1 $ZipMountPoint/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library $ZipMountPoint/auto0/auto2 $ZipMountPoint/auto0/auto1]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + 0 OK1 0 OK2" + +test safe-9.12z {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed; zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library] + + # Inspect. + set confB [safe::interpConfigure $i] + set code4 [catch {::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]} path4] + set code5 [catch {::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]} path5] + + # Try to load the packages. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] + set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6] + + list $path1 $path2 $code4 $path4 $code5 $path5 $code3 $msg3 $code6 $msg6 $confA $confB +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} 1 {* not found in access path}\ + 1 {* not found in access path} 1 {*} 1 {*}\ + {-accessPath {[list $tcl_library $ZipMountPoint/auto0/auto1 $ZipMountPoint/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library]*} -statics 1 -nested 0 -deleteHook {}}" + +test safe-9.20z {check module loading; zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list $path0 $path1 $path2 -- $modsA -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {-accessPath {[list $tcl_library $ZipMountPoint/auto0/modules \ + $ZipMountPoint/auto0/modules/mod1 \ + $ZipMountPoint/auto0/modules/mod2]*}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" + +test safe-9.21z {interpConfigure change the access path; check module loading; stale data case 1; zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] + + # Inspect. + set confB [safe::interpConfigure $i] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Load pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {-accessPath {[list $tcl_library \ + $ZipMountPoint/auto0/modules \ + $ZipMountPoint/auto0/modules/mod1 \ + $ZipMountPoint/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + {-accessPath {[list $tcl_library \ + $ZipMountPoint/auto0/auto1 \ + $ZipMountPoint/auto0/auto2 \ + $ZipMountPoint/auto0/modules \ + $ZipMountPoint/auto0/modules/mod1 \ + $ZipMountPoint/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" + +test safe-9.22z {interpConfigure change the access path; check module loading; stale data case 0; zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] + + # Inspect. + set confB [safe::interpConfigure $i] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {-accessPath {[list $tcl_library \ + $ZipMountPoint/auto0/modules \ + $ZipMountPoint/auto0/modules/mod1 \ + $ZipMountPoint/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + {-accessPath {[list $tcl_library \ + $ZipMountPoint/auto0/auto1 \ + $ZipMountPoint/auto0/auto2 \ + $ZipMountPoint/auto0/modules \ + $ZipMountPoint/auto0/modules/mod1 \ + $ZipMountPoint/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" + +test safe-9.23z {interpConfigure change the access path; check module loading; stale data case 3; zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path } - safe::interpCreate $i -deleteHook "testDelHook arg1 arg2" - safe::setLogCmd safe-test-log - list [safe::interpDelete $i] $res $log + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] + + # Inspect. + set confB [safe::interpConfigure $i] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Refresh stale pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + $out0 $out1 $out2 + } -cleanup { - safe::setLogCmd $prevlog - unset log -} -result {{} {arg1 arg2 a} {{NOTICE for slave a : About to delete} {ERROR for slave a : Delete hook error (being catched)} {NOTICE for slave a : Deleted}}} -test safe-9.3 {dual specification of statics} -returnCodes error -body { - safe::interpCreate -stat true -nostat -} -result {conflicting values given for -statics and -noStatics} -test safe-9.4 {dual specification of statics} { - # no error shall occur - safe::interpDelete [safe::interpCreate -stat false -nostat] -} {} -test safe-9.5 {dual specification of nested} -returnCodes error -body { - safe::interpCreate -nested 0 -nestedload -} -result {conflicting values given for -nested and -nestedLoadOk} -test safe-9.6 {interpConfigure widget like behaviour} -body { - # this test shall work, don't try to "fix it" unless you *really* know what - # you are doing (ie you are me :p) -- dl - list [set i [safe::interpCreate \ - -noStatics \ - -nestedLoadOk \ - -deleteHook {foo bar}] - safe::interpConfigure $i -accessPath /foo/bar - safe::interpConfigure $i]\ - [safe::interpConfigure $i -aCCess]\ - [safe::interpConfigure $i -nested]\ - [safe::interpConfigure $i -statics]\ - [safe::interpConfigure $i -DEL]\ - [safe::interpConfigure $i -accessPath /blah -statics 1 - safe::interpConfigure $i]\ - [safe::interpConfigure $i -deleteHook toto -nosta -nested 0 - safe::interpConfigure $i] + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {-accessPath {[list $tcl_library \ + $ZipMountPoint/auto0/modules \ + $ZipMountPoint/auto0/modules/mod1 \ + $ZipMountPoint/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + {-accessPath {[list $tcl_library \ + $ZipMountPoint/auto0/auto1 \ + $ZipMountPoint/auto0/auto2 \ + $ZipMountPoint/auto0/modules \ + $ZipMountPoint/auto0/modules/mod1 \ + $ZipMountPoint/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" + +test safe-9.24z {interpConfigure change the access path; check module loading; stale data case 2 (worst case); zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] + + # Inspect. + set confB [safe::interpConfigure $i] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + $out0 $out1 $out2 } -cleanup { + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } safe::interpDelete $i -} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {-accessPath {[list $tcl_library \ + $ZipMountPoint/auto0/modules \ + $ZipMountPoint/auto0/modules/mod1 \ + $ZipMountPoint/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + {-accessPath {[list $tcl_library \ + $ZipMountPoint/auto0/auto1 \ + $ZipMountPoint/auto0/auto2 \ + $ZipMountPoint/auto0/modules \ + $ZipMountPoint/auto0/modules/mod1 \ + $ZipMountPoint/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" catch {teststaticpkg Safepkg1 0 0} test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { @@ -961,7 +2764,7 @@ test safe-17.2 {Check that first element of slave auto_path (and access path) is ### 18. Tests for AutoSyncDefined without conventional AutoPathSync, i.e. with AutoPathSync off. -test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without conventional AutoPathSync} -constraints AutoSyncDefined -setup { +test safe-18.1opt {cf. safe-7.1opt - tests that everything works at high level without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -972,13 +2775,15 @@ test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } - # Without AutoPathSync, we need a more complete auto_path, because the slave will use the same value. + # Without AutoPathSync, we need a more complete auto_path, + # because the slave will use the same value. set lib1 [info library] set lib2 [file dirname $lib1] set ::auto_TMP $::auto_path set ::auto_path [list $lib1 $lib2] set i [safe::interpCreate] + set ::auto_path $::auto_TMP } -body { # no error shall occur: # (because the default access_path shall include 1st level sub dirs so @@ -988,14 +2793,48 @@ test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without interp eval $i {::tcl::Lempty {a list}} set v } -cleanup { - set ::auto_path $::auto_TMP safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } } -match glob -result 0.4.* -test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync} -constraints AutoSyncDefined -setup { +test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without conventional AutoPathSync} -constraints AutoSyncDefined -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + + # Without AutoPathSync, we need a more complete auto_path, + # because the slave will use the same value. + set lib1 [info library] + set lib2 [file join $TestsDir auto0] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib1 $lib2] + + set i [safe::interpCreate] + set ::auto_path $::auto_TMP +} -body { + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs so + # package require in a slave works like in the master) + set v [interp eval $i {package require SafeTestPackage1}] + # no error shall occur: + interp eval $i HeresPackage1 + set v +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result 1.2.3 + +test safe-18.2opt {cf. safe-7.2opt - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -1011,7 +2850,7 @@ test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPat interp eval $i {set ::auto_path [list {$p(:0:)}]} # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] - # should add as p1 + # should add as p* (not p1 if master has a module path) set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] # an error shall occur (opt is not anymore in the secure 0-level # provided deep path) @@ -1023,8 +2862,46 @@ test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPat if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {can't find package opt} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" +} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {$pkgOptErrMsg}\ + {-accessPath {[list $tcl_library */dummy/unixlike/test/path]}\ + -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" + +test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync} -constraints AutoSyncDefined -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + set auto1 [interp eval $i {set ::auto_path}] + interp eval $i {set ::auto_path [list {$p(:0:)}]} + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if master has a module path) + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + # should add as p* (not p2 if master has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]] + # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level + # provided deep path) + list $auto1 $token1 $token2 $token3 \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] +} -cleanup { + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)}\ + 1 {can't find package SafeTestPackage1}\ + {-accessPath {[list $tcl_library \ + */dummy/unixlike/test/path \ + $TestsDir/auto0]}\ + -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" test safe-18.3 {Check that default auto_path is the same as in the master interpreter without conventional AutoPathSync} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. @@ -1053,9 +2930,9 @@ test safe-18.3 {Check that default auto_path is the same as in the master interp if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -result [set ::auto_path] +} -result $::auto_path -test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync} -constraints AutoSyncDefined -setup { +test safe-18.4opt {cf. safe-7.4opt - tests specific path and positive search and auto_path without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -1077,12 +2954,12 @@ test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_ set token1 [safe::interpAddToAccessPath $i [info library]] # should add as p* (not p1 if master has a module path) - set token2 [safe::interpAddToAccessPath $i [file join [info library] opt]] + set token2 [safe::interpAddToAccessPath $i [file join [info library] $pkgOptDir]] # should not have been changed by Safe Base: set auto2 [interp eval $i {set ::auto_path}] - # This time, unlike test safe-18.2 and the try above, opt should be found: + # This time, unlike test safe-18.2opt and the try above, opt should be found: list $auto1 $auto2 $token1 $token2 \ [catch {interp eval $i {package require opt}} msg] $msg \ [safe::interpConfigure $i]\ @@ -1091,7 +2968,55 @@ test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_ if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 0.4.* {-accessPath {[list $tcl_library *$tcl_library/opt]} -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" +} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 0.4.*\ + {-accessPath {[list $tcl_library *$tcl_library/$pkgOptDir]}\ + -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" + +test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync} -constraints AutoSyncDefined -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + + # should not have been set by Safe Base: + set auto1 [interp eval $i {set ::auto_path}] + + interp eval $i {set ::auto_path [list {$p(:0:)}]} + + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + + # should add as p* (not p1 if master has a module path) + set token2 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]] + + # should add as p* (not p2 if master has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0 auto1]] + + # should not have been changed by Safe Base: + set auto2 [interp eval $i {set ::auto_path}] + + set auto3 [interp eval $i [list set ::auto_path [list {$p(:0:)} $token2]]] + + # This time, unlike test safe-18.2 and the try above, SafeTestPackage1 should be found: + list $auto1 $auto2 $token1 $token2 $token3 \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] +} -cleanup { + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 0 1.2.3\ + {-accessPath {[list $tcl_library *$TestsDir/auto0 $TestsDir/auto0/auto1]}\ + -statics 0 -nested 1 -deleteHook {}\ + -autoPath {[list $tcl_library $TestsDir/auto0]}} {}" test safe-18.5 {cf. safe-7.5 - tests positive and negative module loading without conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. @@ -1124,6 +3049,125 @@ test safe-18.5 {cf. safe-7.5 - tests positive and negative module loading withou } } -result {1 {can't find package shell} 0} +test safe-18.1z {cf. safe-7.1 - tests that everything works at high level without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + + # Without AutoPathSync, we need a more complete auto_path, + # because the slave will use the same value. + set lib1 [info library] + set lib2 [file join $ZipMountPoint auto0] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib1 $lib2] + + set i [safe::interpCreate] + set ::auto_path $::auto_TMP +} -body { + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs so + # package require in a slave works like in the master) + set v [interp eval $i {package require SafeTestPackage1}] + # no error shall occur: + interp eval $i HeresPackage1 + set v +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result 1.2.3 + +test safe-18.2z {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + set auto1 [interp eval $i {set ::auto_path}] + interp eval $i {set ::auto_path [list {$p(:0:)}]} + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if master has a module path) + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + # should add as p* (not p2 if master has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0]] + # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level + # provided deep path) + list $auto1 $token1 $token2 $token3 \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] +} -cleanup { + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)}\ + 1 {can't find package SafeTestPackage1}\ + {-accessPath {[list $tcl_library \ + */dummy/unixlike/test/path \ + $ZipMountPoint/auto0]}\ + -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" + +test safe-18.4z {cf. safe-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + + # should not have been set by Safe Base: + set auto1 [interp eval $i {set ::auto_path}] + + interp eval $i {set ::auto_path [list {$p(:0:)}]} + + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + + # should add as p* (not p1 if master has a module path) + set token2 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0]] + + # should add as p* (not p2 if master has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0 auto1]] + + # should not have been changed by Safe Base: + set auto2 [interp eval $i {set ::auto_path}] + + set auto3 [interp eval $i [list set ::auto_path [list {$p(:0:)} $token2]]] + + # This time, unlike test safe-18.2 and the try above, SafeTestPackage1 should be found: + list $auto1 $auto2 $token1 $token2 $token3 \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] +} -cleanup { + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 0 1.2.3\ + {-accessPath {[list $tcl_library *$ZipMountPoint/auto0 $ZipMountPoint/auto0/auto1]}\ + -statics 0 -nested 1 -deleteHook {}\ + -autoPath {[list $tcl_library $ZipMountPoint/auto0]}} {}" + + ### 19. Test tokenization of directories available to a slave. test safe-19.1 {Check that each directory of the default auto_path is a valid token} -setup { @@ -1160,8 +3204,10 @@ test safe-19.2 {Check that each directory of the module path is a valid token} - safe::interpDelete $i } -result {} - + set ::auto_path $saveAutoPath +zipfs unmount ${ZipMountPoint} +unset pkgOptErrMsg pkgOptDir pkgJarDir saveAutoPath TestsDir ZipMountPoint # cleanup ::tcltest::cleanupTests return @@ -1169,4 +3215,3 @@ return # Local Variables: # mode: tcl # End: - -- cgit v0.12 From eeb4747a4dc3cef279db5fd9c9415ebca8091b72 Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 14 Jul 2020 16:57:38 +0000 Subject: Rearrange tests in tests/safe.test to agree with upstream order --- tests/safe.test | 1550 +++++++++++++++++++++++++++---------------------------- 1 file changed, 748 insertions(+), 802 deletions(-) diff --git a/tests/safe.test b/tests/safe.test index 75dc2bf..9e942be 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -253,7 +253,20 @@ test safe-7.0a {example tclIndex commands, test in master interpreter} -setup { set ::auto_path $tmpAutoPath auto_reset } -match glob -result {0 ok1 0 ok2} - +test safe-7.0az {example tclIndex commands, test in master interpreter; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2] +} -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 +} -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {0 ok1 0 ok2} test safe-7.0b {example tclIndex commands, negative test in master interpreter} -setup { set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0] @@ -268,7 +281,20 @@ test safe-7.0b {example tclIndex commands, negative test in master interpreter} set ::auto_path $tmpAutoPath auto_reset } -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}} - +test safe-7.0bz {example tclIndex commands, negative test in master interpreter; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0] +} -body { + # Try to load the commands. + set code3 [catch report1 msg3] + set code4 [catch report2 msg4] + list $code3 $msg3 $code4 $msg4 +} -cleanup { + catch {rename report1 {}} + catch {rename report2 {}} + set ::auto_path $tmpAutoPath + auto_reset +} -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}} test safe-7.0c {example pkgIndex.tcl packages, test in master interpreter, child directories} -setup { set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0] @@ -287,7 +313,24 @@ test safe-7.0c {example pkgIndex.tcl packages, test in master interpreter, child catch {rename HeresPackage1 {}} catch {rename HeresPackage2 {}} } -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} +test safe-7.0cz {example pkgIndex.tcl packages, test in master interpreter, child directories; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 +} -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} test safe-7.0d {example pkgIndex.tcl packages, test in master interpreter, main directories} -setup { set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0 auto1] \ @@ -307,7 +350,25 @@ test safe-7.0d {example pkgIndex.tcl packages, test in master interpreter, main catch {rename HeresPackage1 {}} catch {rename HeresPackage2 {}} } -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} +test safe-7.0dz {example pkgIndex.tcl packages, test in master interpreter, main directories; zipfs} -setup { + set tmpAutoPath $::auto_path + lappend ::auto_path [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2] +} -body { + # Try to load the packages and run a command from each one. + set code3 [catch {package require SafeTestPackage1} msg3] + set code4 [catch {package require SafeTestPackage2} msg4] + set code5 [catch HeresPackage1 msg5] + set code6 [catch HeresPackage2 msg6] + list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 +} -cleanup { + set ::auto_path $tmpAutoPath + catch {package forget SafeTestPackage1} + catch {package forget SafeTestPackage2} + catch {rename HeresPackage1 {}} + catch {rename HeresPackage2 {}} +} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} test safe-7.0e {example modules packages, test in master interpreter, replace path} -setup { set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -335,9 +396,12 @@ test safe-7.0e {example modules packages, test in master interpreter, replace pa catch {namespace delete ::test0} catch {namespace delete ::mod1} } -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} - -test safe-7.0f {example modules packages, test in master interpreter, append to path} -setup { - tcl::tm::path add [file join $TestsDir auto0 modules] +test safe-7.0ez {example modules packages, test in master interpreter, replace path; zipfs} -setup { + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $ZipMountPoint auto0 modules] } -body { # Try to load the modules and run a command from each one. set code0 [catch {package require test0} msg0] @@ -349,89 +413,18 @@ test safe-7.0f {example modules packages, test in master interpreter, append to list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 } -cleanup { - tcl::tm::path remove [file join $TestsDir auto0 modules] + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } catch {package forget test0} catch {package forget mod1::test1} catch {package forget mod2::test2} catch {namespace delete ::test0} catch {namespace delete ::mod1} } -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} - -test safe-7.0az {example tclIndex commands, test in master interpreter; zipfs} -setup { - set tmpAutoPath $::auto_path - lappend ::auto_path [file join $ZipMountPoint auto0 auto1] [file join $ZipMountPoint auto0 auto2] -} -body { - # Try to load the commands. - set code3 [catch report1 msg3] - set code4 [catch report2 msg4] - list $code3 $msg3 $code4 $msg4 -} -cleanup { - catch {rename report1 {}} - catch {rename report2 {}} - set ::auto_path $tmpAutoPath - auto_reset -} -match glob -result {0 ok1 0 ok2} - -test safe-7.0bz {example tclIndex commands, negative test in master interpreter; zipfs} -setup { - set tmpAutoPath $::auto_path - lappend ::auto_path [file join $ZipMountPoint auto0] -} -body { - # Try to load the commands. - set code3 [catch report1 msg3] - set code4 [catch report2 msg4] - list $code3 $msg3 $code4 $msg4 -} -cleanup { - catch {rename report1 {}} - catch {rename report2 {}} - set ::auto_path $tmpAutoPath - auto_reset -} -match glob -result {1 {invalid command name "report1"} 1 {invalid command name "report2"}} - -test safe-7.0cz {example pkgIndex.tcl packages, test in master interpreter, child directories; zipfs} -setup { - set tmpAutoPath $::auto_path - lappend ::auto_path [file join $ZipMountPoint auto0] -} -body { - # Try to load the packages and run a command from each one. - set code3 [catch {package require SafeTestPackage1} msg3] - set code4 [catch {package require SafeTestPackage2} msg4] - set code5 [catch HeresPackage1 msg5] - set code6 [catch HeresPackage2 msg6] - - list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 -} -cleanup { - set ::auto_path $tmpAutoPath - catch {package forget SafeTestPackage1} - catch {package forget SafeTestPackage2} - catch {rename HeresPackage1 {}} - catch {rename HeresPackage2 {}} -} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} - -test safe-7.0dz {example pkgIndex.tcl packages, test in master interpreter, main directories; zipfs} -setup { - set tmpAutoPath $::auto_path - lappend ::auto_path [file join $ZipMountPoint auto0 auto1] \ - [file join $ZipMountPoint auto0 auto2] -} -body { - # Try to load the packages and run a command from each one. - set code3 [catch {package require SafeTestPackage1} msg3] - set code4 [catch {package require SafeTestPackage2} msg4] - set code5 [catch HeresPackage1 msg5] - set code6 [catch HeresPackage2 msg6] - - list $code3 $msg3 $code4 $msg4 $code5 $msg5 $code6 $msg6 -} -cleanup { - set ::auto_path $tmpAutoPath - catch {package forget SafeTestPackage1} - catch {package forget SafeTestPackage2} - catch {rename HeresPackage1 {}} - catch {rename HeresPackage2 {}} -} -match glob -result {0 1.2.3 0 2.3.4 0 OK1 0 OK2} - -test safe-7.0ez {example modules packages, test in master interpreter, replace path; zipfs} -setup { - set oldTm [tcl::tm::path list] - foreach path $oldTm { - tcl::tm::path remove $path - } - tcl::tm::path add [file join $ZipMountPoint auto0 modules] +test safe-7.0f {example modules packages, test in master interpreter, append to path} -setup { + tcl::tm::path add [file join $TestsDir auto0 modules] } -body { # Try to load the modules and run a command from each one. set code0 [catch {package require test0} msg0] @@ -443,17 +436,13 @@ test safe-7.0ez {example modules packages, test in master interpreter, replace p list $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $out0 $out1 $out2 } -cleanup { - tcl::tm::path remove [file join $ZipMountPoint auto0 modules] - foreach path [lreverse $oldTm] { - tcl::tm::path add $path - } + tcl::tm::path remove [file join $TestsDir auto0 modules] catch {package forget test0} catch {package forget mod1::test1} catch {package forget mod2::test2} catch {namespace delete ::test0} catch {namespace delete ::mod1} } -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} - test safe-7.0fz {example modules packages, test in master interpreter, append to path; zipfs} -setup { tcl::tm::path add [file join $ZipMountPoint auto0 modules] } -body { @@ -475,34 +464,6 @@ test safe-7.0fz {example modules packages, test in master interpreter, append to catch {namespace delete ::mod1} } -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} - -# high level general test -test safe-7.1opt {tests that everything works at high level with conventional AutoPathSync, use pkg opt} -setup { - # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - - if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 - } - - set i [safe::interpCreate] - -} -body { - # no error shall occur: - # (because the default access_path shall include 1st level sub dirs so - # package require in a slave works like in the master) - set v [interp eval $i {package require opt}] - # no error shall occur: - interp eval $i {::tcl::Lempty {a list}} - set v -} -cleanup { - safe::interpDelete $i - if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP - } -} -match glob -result 0.4.* - # high level general test # Use example packages not tcl8.x/opt test safe-7.1 {tests that everything works at high level with conventional AutoPathSync} -setup { @@ -532,7 +493,6 @@ test safe-7.1 {tests that everything works at high level with conventional AutoP safe::setAutoPathSync $SyncVal_TMP } } -match glob -result 1.2.3 - # high level general test # Use zipped example packages not tcl8.x/opt test safe-7.1z {tests that everything works at high level with conventional AutoPathSync; zipfs} -setup { @@ -562,37 +522,32 @@ test safe-7.1z {tests that everything works at high level with conventional Auto safe::setAutoPathSync $SyncVal_TMP } } -match glob -result 1.2.3 - -test safe-7.2opt {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync, use pkg opt} -setup { +# high level general test +test safe-7.1opt {tests that everything works at high level with conventional AutoPathSync, use pkg opt} -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 1 - } else { - set SyncVal_TMP 1 } + + set i [safe::interpCreate] + } -body { - set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] - # should not add anything (p0) - set token1 [safe::interpAddToAccessPath $i [info library]] - # should add as p* (not p1 if master has a module path) - set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] - # an error shall occur (opt is not anymore in the secure 0-level - # provided deep path) - list $token1 $token2 \ - [catch {interp eval $i {package require opt}} msg] $msg \ - [safe::interpConfigure $i]\ - [safe::interpDelete $i] + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs so + # package require in a slave works like in the master) + set v [interp eval $i {package require opt}] + # no error shall occur: + interp eval $i {::tcl::Lempty {a list}} + set v } -cleanup { + safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {$pkgOptErrMsg}\ - {-accessPath {[list $tcl_library */dummy/unixlike/test/path]}\ - -statics 0 -nested 1 -deleteHook {}} {}" - +} -match glob -result 0.4.* test safe-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -625,7 +580,6 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath with conventio {can't find package SafeTestPackage1}\ {-accessPath {[list $tcl_library */dummy/unixlike/test/path $TestsDir/auto0]}\ -statics 0 -nested 1 -deleteHook {}} {}" - test safe-7.2z {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync; zipfs} -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -658,14 +612,7 @@ test safe-7.2z {tests specific path and interpFind/AddToAccessPath with conventi {can't find package SafeTestPackage1}\ {-accessPath {[list $tcl_library */dummy/unixlike/test/path $TestsDir/auto0]}\ -statics 0 -nested 1 -deleteHook {}} {}" - -test safe-7.3 {check that safe subinterpreters work} { - set i [safe::interpCreate] - set j [safe::interpCreate [list $i x]] - list [interp eval $j {join {o k} ""}] [safe::interpDelete $i] [interp exists $j] -} {ok {} 0} - -test safe-7.4opt {tests specific path and positive search with conventional AutoPathSync, use pkg opt} -setup { +test safe-7.2opt {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync, use pkg opt} -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -680,22 +627,25 @@ test safe-7.4opt {tests specific path and positive search with conventional Auto # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] # should add as p* (not p1 if master has a module path) - set token2 [safe::interpAddToAccessPath $i [file join [info library] $pkgOptDir]] - # this time, unlike test safe-7.2opt, opt should be found + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + # an error shall occur (opt is not anymore in the secure 0-level + # provided deep path) list $token1 $token2 \ [catch {interp eval $i {package require opt}} msg] $msg \ [safe::interpConfigure $i]\ [safe::interpDelete $i] - # Note that the glob match elides directories (those from the module path) - # other than the first and last in the access path. } -cleanup { if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{\$p(:0:)} {\$p(:*:)} 0 0.4.*\ - {-accessPath {[list $tcl_library *$tcl_library/$pkgOptDir]}\ +} -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {$pkgOptErrMsg}\ + {-accessPath {[list $tcl_library */dummy/unixlike/test/path]}\ -statics 0 -nested 1 -deleteHook {}} {}" - +test safe-7.3 {check that safe subinterpreters work} { + set i [safe::interpCreate] + set j [safe::interpCreate [list $i x]] + list [interp eval $j {join {o k} ""}] [safe::interpDelete $i] [interp exists $j] +} {ok {} 0} test safe-7.4 {tests specific path and positive search with conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -726,7 +676,6 @@ test safe-7.4 {tests specific path and positive search with conventional AutoPat } -match glob -result "{\$p(:0:)} {\$p(:*:)} 0 1.2.3\ {-accessPath {[list $tcl_library * $TestsDir/auto0/auto1]}\ -statics 0 -nested 1 -deleteHook {}} {}" - test safe-7.4z {tests specific path and positive search with conventional AutoPathSync; zipfs} -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -757,8 +706,38 @@ test safe-7.4z {tests specific path and positive search with conventional AutoPa } -match glob -result "{\$p(:0:)} {\$p(:*:)} 0 1.2.3\ {-accessPath {[list $tcl_library * $TestsDir/auto0/auto1]}\ -statics 0 -nested 1 -deleteHook {}} {}" - -test safe-7.5 {tests positive and negative module loading with conventional AutoPathSync} -setup { +test safe-7.4opt {tests specific path and positive search with conventional AutoPathSync, use pkg opt} -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } else { + set SyncVal_TMP 1 + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if master has a module path) + set token2 [safe::interpAddToAccessPath $i [file join [info library] $pkgOptDir]] + # this time, unlike test safe-7.2opt, opt should be found + list $token1 $token2 \ + [catch {interp eval $i {package require opt}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] + # Note that the glob match elides directories (those from the module path) + # other than the first and last in the access path. +} -cleanup { + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:0:)} {\$p(:*:)} 0 0.4.*\ + {-accessPath {[list $tcl_library *$tcl_library/$pkgOptDir]}\ + -statics 0 -nested 1 -deleteHook {}} {}" + +test safe-7.5 {tests positive and negative module loading with conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -983,7 +962,6 @@ test safe-9.6 {interpConfigure widget like behaviour} -body { } -cleanup { safe::interpDelete $i } -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} - test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { # this test shall work, believed equivalent to 9.6 set i [safe::interpCreate \ @@ -1007,7 +985,6 @@ test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { } -cleanup { safe::interpDelete $i } -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}} {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}} {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}} {-accessPath * -statics 0 -nested 0 -deleteHook toto}} - test safe-9.8 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset)} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { @@ -1057,7 +1034,55 @@ test safe-9.8 {interpConfigure change the access path; tclIndex commands unaffec -statics 1 -nested 0 -deleteHook {}}\ {-accessPath {[list $tcl_library $TestsDir/auto0/auto2 $TestsDir/auto0/auto1]*}\ -statics 1 -nested 0 -deleteHook {}}" +test safe-9.8z {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset); zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Load and run the commands. + # This guarantees the test will pass even if the tokens are swapped. + set code1 [catch {interp eval $i {report1}} msg1] + set code2 [catch {interp eval $i {report2}} msg2] + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + + # Inspect. + set confB [safe::interpConfigure $i] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 ok1 0 ok2\ + {-accessPath {[list $tcl_library $ZipMountPoint/auto0/auto1 $ZipMountPoint/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library $ZipMountPoint/auto0/auto2 $ZipMountPoint/auto0/auto1]*}\ + -statics 1 -nested 0 -deleteHook {}}" test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset)} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { @@ -1105,8 +1130,7 @@ test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffec -statics 1 -nested 0 -deleteHook {}}\ {-accessPath {[list $tcl_library $TestsDir/auto0/auto2 $TestsDir/auto0/auto1]*}\ -statics 1 -nested 0 -deleteHook {}}" - -test safe-9.10opt {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, use pkg opt and tcl::idna} -setup { +test safe-9.9z {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset); zipfs} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -1114,47 +1138,45 @@ test safe-9.10opt {interpConfigure change the access path; pkgIndex.tcl packages } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ - [file join $tcl_library $pkgOptDir] \ - [file join $tcl_library $pkgJarDir]]] + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] # Inspect. set confA [safe::interpConfigure $i] - set path1 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]] - set path2 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] - # Load pkgIndex.tcl data. - catch {interp eval $i {package require NOEXIST}} + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Do not load the commands. With the tokens swapped, the test + # will pass only if the Safe Base has called auto_reset. # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. - # This has no effect because the records in Pkg of these directories were from access as children of {$p(:0:)}. safe::interpConfigure $i -accessPath [list $tcl_library \ - [file join $tcl_library $pkgJarDir] \ - [file join $tcl_library $pkgOptDir]] + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] # Inspect. set confB [safe::interpConfigure $i] - set path3 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]] - set path4 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] - # Try to load the packages and run a command from each one. - set code3 [catch {interp eval $i {package require tcl::idna}} msg3] - set code4 [catch {interp eval $i {package require opt}} msg4] - set code5 [catch {interp eval $i {::tcl::Lempty {a list}}} msg5] - set code6 [catch {interp eval $i {::tcl::idna::IDNAencode example.com}} msg6] + # Load and run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] - list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 \ - $confA $confB $code5 $msg5 $code6 $msg6 + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB } -cleanup { safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 1.* 0 0.4.*\ - {-accessPath {[list $tcl_library $tcl_library/$pkgOptDir $tcl_library/$pkgJarDir]*}\ +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 ok1 0 ok2\ + {-accessPath {[list $tcl_library $ZipMountPoint/auto0/auto1 $ZipMountPoint/auto0/auto2]*}\ -statics 1 -nested 0 -deleteHook {}}\ - {-accessPath {[list $tcl_library $tcl_library/$pkgJarDir $tcl_library/$pkgOptDir]*}\ - -statics 1 -nested 0 -deleteHook {}} 0 0 0 example.com" - + {-accessPath {[list $tcl_library $ZipMountPoint/auto0/auto2 $ZipMountPoint/auto0/auto1]*}\ + -statics 1 -nested 0 -deleteHook {}}" test safe-9.10 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { @@ -1210,35 +1232,40 @@ test safe-9.10 {interpConfigure change the access path; pkgIndex.tcl packages un {-accessPath {[list $tcl_library $TestsDir/auto0 $TestsDir/auto0/auto2 $TestsDir/auto0/auto1]*}\ -statics 1 -nested 0 -deleteHook {}}\ 0 OK1 0 OK2" - -test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0} -setup { +test safe-9.10z {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement; zipfs} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 1 } } -body { + # For complete correspondence to safe-9.10opt, include auto0 in access path. set i [safe::interpCreate -accessPath [list $tcl_library \ - [file join $TestsDir auto0 auto1] \ - [file join $TestsDir auto0 auto2]]] + [file join $ZipMountPoint auto0] \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] # Inspect. set confA [safe::interpConfigure $i] - set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] - set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] # Load pkgIndex.tcl data. catch {interp eval $i {package require NOEXIST}} - # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}. + # This would have no effect because the records in Pkg of these directories + # were from access as children of {$p(:1:)}. safe::interpConfigure $i -accessPath [list $tcl_library \ - [file join $TestsDir auto0 auto2] \ - [file join $TestsDir auto0 auto1]] + [file join $ZipMountPoint auto0] \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] # Inspect. set confB [safe::interpConfigure $i] - set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] - set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] # Try to load the packages and run a command from each one. set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] @@ -1248,19 +1275,19 @@ test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages un list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB \ $code5 $msg5 $code6 $msg6 + } -cleanup { safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 1.2.3 0 2.3.4\ - {-accessPath {[list $tcl_library $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ +} -match glob -result "{\$p(:2:)} {\$p(:3:)} {\$p(:3:)} {\$p(:2:)} 0 1.2.3 0 2.3.4\ + {-accessPath {[list $tcl_library $ZipMountPoint/auto0 $ZipMountPoint/auto0/auto1 $ZipMountPoint/auto0/auto2]*}\ -statics 1 -nested 0 -deleteHook {}}\ - {-accessPath {[list $tcl_library $TestsDir/auto0/auto2 $TestsDir/auto0/auto1]*}\ + {-accessPath {[list $tcl_library $ZipMountPoint/auto0 $ZipMountPoint/auto0/auto2 $ZipMountPoint/auto0/auto1]*}\ -statics 1 -nested 0 -deleteHook {}}\ 0 OK1 0 OK2" - -test safe-9.12opt {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, use pkg opt and tcl::idna} -setup { +test safe-9.10opt {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, use pkg opt and tcl::idna} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -1279,31 +1306,36 @@ test safe-9.12opt {interpConfigure change the access path; pkgIndex.tcl packages # Load pkgIndex.tcl data. catch {interp eval $i {package require NOEXIST}} - # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. - safe::interpConfigure $i -accessPath [list $tcl_library] + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + # This has no effect because the records in Pkg of these directories were from access as children of {$p(:0:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $tcl_library $pkgJarDir] \ + [file join $tcl_library $pkgOptDir]] # Inspect. set confB [safe::interpConfigure $i] - set code4 [catch {::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]} path4] - set code5 [catch {::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]} path5] + set path3 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]] + set path4 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]] - # Try to load the packages. - set code3 [catch {interp eval $i {package require opt}} msg3] - set code6 [catch {interp eval $i {package require tcl::idna}} msg6] + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require tcl::idna}} msg3] + set code4 [catch {interp eval $i {package require opt}} msg4] + set code5 [catch {interp eval $i {::tcl::Lempty {a list}}} msg5] + set code6 [catch {interp eval $i {::tcl::idna::IDNAencode example.com}} msg6] - list $path1 $path2 $code4 $path4 $code5 $path5 $code3 $msg3 $code6 $msg6 $confA $confB + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 \ + $confA $confB $code5 $msg5 $code6 $msg6 } -cleanup { safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{\$p(:1:)} {\$p(:2:)} 1 {* not found in access path}\ - 1 {* not found in access path} 1 {*} 1 {*}\ +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 1.* 0 0.4.*\ {-accessPath {[list $tcl_library $tcl_library/$pkgOptDir $tcl_library/$pkgJarDir]*}\ -statics 1 -nested 0 -deleteHook {}}\ - {-accessPath {[list $tcl_library]*} -statics 1 -nested 0 -deleteHook {}}" - -test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed} -setup { + {-accessPath {[list $tcl_library $tcl_library/$pkgJarDir $tcl_library/$pkgOptDir]*}\ + -statics 1 -nested 0 -deleteHook {}} 0 0 0 example.com" +test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -1322,79 +1354,210 @@ test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages fa # Load pkgIndex.tcl data. catch {interp eval $i {package require NOEXIST}} - # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. - safe::interpConfigure $i -accessPath [list $tcl_library] + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] # Inspect. set confB [safe::interpConfigure $i] - set code4 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]} path4] - set code5 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]} path5] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] - # Try to load the packages. - set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] - set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6] + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] - list $path1 $path2 $code4 $path4 $code5 $path5 $code3 $msg3 $code6 $msg6 $confA $confB + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB \ + $code5 $msg5 $code6 $msg6 } -cleanup { safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{\$p(:1:)} {\$p(:2:)} 1 {* not found in access path}\ - 1 {* not found in access path} 1 {*} 1 {*}\ +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 1.2.3 0 2.3.4\ {-accessPath {[list $tcl_library $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ -statics 1 -nested 0 -deleteHook {}}\ - {-accessPath {[list $tcl_library]*} -statics 1 -nested 0 -deleteHook {}}" - -test safe-9.20 {check module loading} -setup { + {-accessPath {[list $tcl_library $TestsDir/auto0/auto2 $TestsDir/auto0/auto1]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + 0 OK1 0 OK2" +test safe-9.11z {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0; zipfs} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 1 } - set oldTm [tcl::tm::path list] - foreach path $oldTm { - tcl::tm::path remove $path - } - tcl::tm::path add [file join $TestsDir auto0 modules] } -body { - set i [safe::interpCreate -accessPath [list $tcl_library]] + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] # Inspect. set confA [safe::interpConfigure $i] - set modsA [interp eval $i {tcl::tm::path list}] - set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] - set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] - set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] - # Try to load the packages and run a command from each one. - set code0 [catch {interp eval $i {package require test0}} msg0] - set code1 [catch {interp eval $i {package require mod1::test1}} msg1] - set code2 [catch {interp eval $i {package require mod2::test2}} msg2] - set out0 [interp eval $i {test0::try0}] - set out1 [interp eval $i {mod1::test1::try1}] - set out2 [interp eval $i {mod2::test2::try2}] + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} - list $path0 $path1 $path2 -- $modsA -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $out0 $out1 $out2 -} -cleanup { - tcl::tm::path remove [file join $TestsDir auto0 modules] - foreach path [lreverse $oldTm] { - tcl::tm::path add $path + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto2] \ + [file join $ZipMountPoint auto0 auto1]] + + # Inspect. + set confB [safe::interpConfigure $i] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB \ + $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 1.2.3 0 2.3.4\ + {-accessPath {[list $tcl_library $ZipMountPoint/auto0/auto1 $ZipMountPoint/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library $ZipMountPoint/auto0/auto2 $ZipMountPoint/auto0/auto1]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + 0 OK1 0 OK2" +test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 } +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library] + + # Inspect. + set confB [safe::interpConfigure $i] + set code4 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]} path4] + set code5 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]} path5] + + # Try to load the packages. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] + set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6] + + list $path1 $path2 $code4 $path4 $code5 $path5 $code3 $msg3 $code6 $msg6 $confA $confB +} -cleanup { safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ - 0 0.5 0 1.0 0 2.0 --\ - {-accessPath {[list $tcl_library $TestsDir/auto0/modules \ - $TestsDir/auto0/modules/mod1 \ - $TestsDir/auto0/modules/mod2]*}\ - -statics 1 -nested 0 -deleteHook {}} --\ - res0 res1 res2" +} -match glob -result "{\$p(:1:)} {\$p(:2:)} 1 {* not found in access path}\ + 1 {* not found in access path} 1 {*} 1 {*}\ + {-accessPath {[list $tcl_library $TestsDir/auto0/auto1 $TestsDir/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library]*} -statics 1 -nested 0 -deleteHook {}}" +test safe-9.12z {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed; zipfs} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]]] -test safe-9.21 {interpConfigure change the access path; check module loading; stale data case 1} -setup { + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library] + + # Inspect. + set confB [safe::interpConfigure $i] + set code4 [catch {::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]} path4] + set code5 [catch {::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]} path5] + + # Try to load the packages. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] + set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6] + + list $path1 $path2 $code4 $path4 $code5 $path5 $code3 $msg3 $code6 $msg6 $confA $confB +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} 1 {* not found in access path}\ + 1 {* not found in access path} 1 {*} 1 {*}\ + {-accessPath {[list $tcl_library $ZipMountPoint/auto0/auto1 $ZipMountPoint/auto0/auto2]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library]*} -statics 1 -nested 0 -deleteHook {}}" +test safe-9.12opt {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, use pkg opt and tcl::idna} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $tcl_library $pkgOptDir] \ + [file join $tcl_library $pkgJarDir]]] + + # Inspect. + set confA [safe::interpConfigure $i] + set path1 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]] + set path2 [::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library] + + # Inspect. + set confB [safe::interpConfigure $i] + set code4 [catch {::safe::interpFindInAccessPath $i [file join $tcl_library $pkgOptDir]} path4] + set code5 [catch {::safe::interpFindInAccessPath $i [file join $tcl_library $pkgJarDir]} path5] + + # Try to load the packages. + set code3 [catch {interp eval $i {package require opt}} msg3] + set code6 [catch {interp eval $i {package require tcl::idna}} msg6] + + list $path1 $path2 $code4 $path4 $code5 $path5 $code3 $msg3 $code6 $msg6 $confA $confB +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{\$p(:1:)} {\$p(:2:)} 1 {* not found in access path}\ + 1 {* not found in access path} 1 {*} 1 {*}\ + {-accessPath {[list $tcl_library $tcl_library/$pkgOptDir $tcl_library/$pkgJarDir]*}\ + -statics 1 -nested 0 -deleteHook {}}\ + {-accessPath {[list $tcl_library]*} -statics 1 -nested 0 -deleteHook {}}" +test safe-9.20 {check module loading} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -1415,24 +1578,6 @@ test safe-9.21 {interpConfigure change the access path; check module loading; st set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] - # Add to access path. - # This injects more tokens, pushing modules to higher token numbers. - safe::interpConfigure $i -accessPath [list $tcl_library \ - [file join $TestsDir auto0 auto1] \ - [file join $TestsDir auto0 auto2]] - - # Inspect. - set confB [safe::interpConfigure $i] - set modsB [interp eval $i {tcl::tm::path list}] - set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] - set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] - set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] - - # Load pkg data. - catch {interp eval $i {package require NOEXIST}} - catch {interp eval $i {package require mod1::NOEXIST}} - catch {interp eval $i {package require mod2::NOEXIST}} - # Try to load the packages and run a command from each one. set code0 [catch {interp eval $i {package require test0}} msg0] set code1 [catch {interp eval $i {package require mod1::test1}} msg1] @@ -1441,9 +1586,8 @@ test safe-9.21 {interpConfigure change the access path; check module loading; st set out1 [interp eval $i {mod1::test1::try1}] set out2 [interp eval $i {mod2::test2::try2}] - list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ - $out0 $out1 $out2 + list $path0 $path1 $path2 -- $modsA -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $out0 $out1 $out2 } -cleanup { tcl::tm::path remove [file join $TestsDir auto0 modules] foreach path [lreverse $oldTm] { @@ -1454,23 +1598,13 @@ test safe-9.21 {interpConfigure change the access path; check module loading; st safe::setAutoPathSync $SyncVal_TMP } } -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ - {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ 0 0.5 0 1.0 0 2.0 --\ - {-accessPath {[list $tcl_library \ - $TestsDir/auto0/modules \ - $TestsDir/auto0/modules/mod1 \ - $TestsDir/auto0/modules/mod2]}\ - -statics 1 -nested 0 -deleteHook {}} --\ - {-accessPath {[list $tcl_library \ - $TestsDir/auto0/auto1 \ - $TestsDir/auto0/auto2 \ - $TestsDir/auto0/modules \ + {-accessPath {[list $tcl_library $TestsDir/auto0/modules \ $TestsDir/auto0/modules/mod1 \ - $TestsDir/auto0/modules/mod2]}\ + $TestsDir/auto0/modules/mod2]*}\ -statics 1 -nested 0 -deleteHook {}} --\ res0 res1 res2" - -test safe-9.22 {interpConfigure change the access path; check module loading; stale data case 0} -setup { +test safe-9.20z {check module loading; zipfs} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -1480,29 +1614,16 @@ test safe-9.22 {interpConfigure change the access path; check module loading; st foreach path $oldTm { tcl::tm::path remove $path } - tcl::tm::path add [file join $TestsDir auto0 modules] + tcl::tm::path add [file join $ZipMountPoint auto0 modules] } -body { set i [safe::interpCreate -accessPath [list $tcl_library]] # Inspect. set confA [safe::interpConfigure $i] set modsA [interp eval $i {tcl::tm::path list}] - set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] - set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] - set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] - - # Add to access path. - # This injects more tokens, pushing modules to higher token numbers. - safe::interpConfigure $i -accessPath [list $tcl_library \ - [file join $TestsDir auto0 auto1] \ - [file join $TestsDir auto0 auto2]] - - # Inspect. - set confB [safe::interpConfigure $i] - set modsB [interp eval $i {tcl::tm::path list}] - set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] - set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] - set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] # Try to load the packages and run a command from each one. set code0 [catch {interp eval $i {package require test0}} msg0] @@ -1512,11 +1633,10 @@ test safe-9.22 {interpConfigure change the access path; check module loading; st set out1 [interp eval $i {mod1::test1::try1}] set out2 [interp eval $i {mod2::test2::try2}] - list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ - $out0 $out1 $out2 + list $path0 $path1 $path2 -- $modsA -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $out0 $out1 $out2 } -cleanup { - tcl::tm::path remove [file join $TestsDir auto0 modules] + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] foreach path [lreverse $oldTm] { tcl::tm::path add $path } @@ -1525,23 +1645,13 @@ test safe-9.22 {interpConfigure change the access path; check module loading; st safe::setAutoPathSync $SyncVal_TMP } } -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ - {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ 0 0.5 0 1.0 0 2.0 --\ - {-accessPath {[list $tcl_library \ - $TestsDir/auto0/modules \ - $TestsDir/auto0/modules/mod1 \ - $TestsDir/auto0/modules/mod2]}\ - -statics 1 -nested 0 -deleteHook {}} --\ - {-accessPath {[list $tcl_library \ - $TestsDir/auto0/auto1 \ - $TestsDir/auto0/auto2 \ - $TestsDir/auto0/modules \ - $TestsDir/auto0/modules/mod1 \ - $TestsDir/auto0/modules/mod2]}\ + {-accessPath {[list $tcl_library $ZipMountPoint/auto0/modules \ + $ZipMountPoint/auto0/modules/mod1 \ + $ZipMountPoint/auto0/modules/mod2]*}\ -statics 1 -nested 0 -deleteHook {}} --\ res0 res1 res2" - -test safe-9.23 {interpConfigure change the access path; check module loading; stale data case 3} -setup { +test safe-9.21 {interpConfigure change the access path; check module loading; stale data case 1} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -1562,11 +1672,6 @@ test safe-9.23 {interpConfigure change the access path; check module loading; st set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] - # Force the interpreter to acquire pkg data which will soon become stale. - catch {interp eval $i {package require NOEXIST}} - catch {interp eval $i {package require mod1::NOEXIST}} - catch {interp eval $i {package require mod2::NOEXIST}} - # Add to access path. # This injects more tokens, pushing modules to higher token numbers. safe::interpConfigure $i -accessPath [list $tcl_library \ @@ -1580,7 +1685,7 @@ test safe-9.23 {interpConfigure change the access path; check module loading; st set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] - # Refresh stale pkg data. + # Load pkg data. catch {interp eval $i {package require NOEXIST}} catch {interp eval $i {package require mod1::NOEXIST}} catch {interp eval $i {package require mod2::NOEXIST}} @@ -1596,7 +1701,6 @@ test safe-9.23 {interpConfigure change the access path; check module loading; st list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ $out0 $out1 $out2 - } -cleanup { tcl::tm::path remove [file join $TestsDir auto0 modules] foreach path [lreverse $oldTm] { @@ -1610,20 +1714,19 @@ test safe-9.23 {interpConfigure change the access path; check module loading; st {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ 0 0.5 0 1.0 0 2.0 --\ {-accessPath {[list $tcl_library \ - $TestsDir/auto0/modules \ - $TestsDir/auto0/modules/mod1 \ - $TestsDir/auto0/modules/mod2]}\ - -statics 1 -nested 0 -deleteHook {}} --\ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ {-accessPath {[list $tcl_library \ - $TestsDir/auto0/auto1 \ - $TestsDir/auto0/auto2 \ - $TestsDir/auto0/modules \ - $TestsDir/auto0/modules/mod1 \ - $TestsDir/auto0/modules/mod2]}\ + $TestsDir/auto0/auto1 \ + $TestsDir/auto0/auto2 \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ -statics 1 -nested 0 -deleteHook {}} --\ res0 res1 res2" - -test safe-9.24 {interpConfigure change the access path; check module loading; stale data case 2 (worst case)} -setup { +test safe-9.21z {interpConfigure change the access path; check module loading; stale data case 1; zipfs} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -1633,34 +1736,34 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st foreach path $oldTm { tcl::tm::path remove $path } - tcl::tm::path add [file join $TestsDir auto0 modules] + tcl::tm::path add [file join $ZipMountPoint auto0 modules] } -body { set i [safe::interpCreate -accessPath [list $tcl_library]] # Inspect. set confA [safe::interpConfigure $i] set modsA [interp eval $i {tcl::tm::path list}] - set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] - set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] - set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] - - # Force the interpreter to acquire pkg data which will soon become stale. - catch {interp eval $i {package require NOEXIST}} - catch {interp eval $i {package require mod1::NOEXIST}} - catch {interp eval $i {package require mod2::NOEXIST}} + set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] # Add to access path. # This injects more tokens, pushing modules to higher token numbers. safe::interpConfigure $i -accessPath [list $tcl_library \ - [file join $TestsDir auto0 auto1] \ - [file join $TestsDir auto0 auto2]] + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] # Inspect. set confB [safe::interpConfigure $i] set modsB [interp eval $i {tcl::tm::path list}] - set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] - set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] - set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + + # Load pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} # Try to load the packages and run a command from each one. set code0 [catch {interp eval $i {package require test0}} msg0] @@ -1674,7 +1777,7 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ $out0 $out1 $out2 } -cleanup { - tcl::tm::path remove [file join $TestsDir auto0 modules] + tcl::tm::path remove [file join $ZipMountPoint auto0 modules] foreach path [lreverse $oldTm] { tcl::tm::path add $path } @@ -1686,267 +1789,89 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ 0 0.5 0 1.0 0 2.0 --\ {-accessPath {[list $tcl_library \ - $TestsDir/auto0/modules \ - $TestsDir/auto0/modules/mod1 \ - $TestsDir/auto0/modules/mod2]}\ + $ZipMountPoint/auto0/modules \ + $ZipMountPoint/auto0/modules/mod1 \ + $ZipMountPoint/auto0/modules/mod2]}\ -statics 1 -nested 0 -deleteHook {}} --\ {-accessPath {[list $tcl_library \ - $TestsDir/auto0/auto1 \ - $TestsDir/auto0/auto2 \ - $TestsDir/auto0/modules \ - $TestsDir/auto0/modules/mod1 \ - $TestsDir/auto0/modules/mod2]}\ - -statics 1 -nested 0 -deleteHook {}} --\ - res0 res1 res2" - - -test safe-9.8z {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset); zipfs} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 - } -} -body { - set i [safe::interpCreate -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0 auto1] \ - [file join $ZipMountPoint auto0 auto2]]] - - # Inspect. - set confA [safe::interpConfigure $i] - set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] - set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] - - # Load auto_load data. - interp eval $i {catch nonExistentCommand} - - # Load and run the commands. - # This guarantees the test will pass even if the tokens are swapped. - set code1 [catch {interp eval $i {report1}} msg1] - set code2 [catch {interp eval $i {report2}} msg2] - - # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. - safe::interpConfigure $i -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0 auto2] \ - [file join $ZipMountPoint auto0 auto1]] - - # Inspect. - set confB [safe::interpConfigure $i] - set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] - set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] - - # Run the commands. - set code3 [catch {interp eval $i {report1}} msg3] - set code4 [catch {interp eval $i {report2}} msg4] - - list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB -} -cleanup { - safe::interpDelete $i - if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP - } -} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 ok1 0 ok2\ - {-accessPath {[list $tcl_library $ZipMountPoint/auto0/auto1 $ZipMountPoint/auto0/auto2]*}\ - -statics 1 -nested 0 -deleteHook {}}\ - {-accessPath {[list $tcl_library $ZipMountPoint/auto0/auto2 $ZipMountPoint/auto0/auto1]*}\ - -statics 1 -nested 0 -deleteHook {}}" - -test safe-9.9z {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset); zipfs} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 - } -} -body { - set i [safe::interpCreate -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0 auto1] \ - [file join $ZipMountPoint auto0 auto2]]] - - # Inspect. - set confA [safe::interpConfigure $i] - set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] - set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] - - # Load auto_load data. - interp eval $i {catch nonExistentCommand} - - # Do not load the commands. With the tokens swapped, the test - # will pass only if the Safe Base has called auto_reset. - - # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. - safe::interpConfigure $i -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0 auto2] \ - [file join $ZipMountPoint auto0 auto1]] - - # Inspect. - set confB [safe::interpConfigure $i] - set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] - set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] - - # Load and run the commands. - set code3 [catch {interp eval $i {report1}} msg3] - set code4 [catch {interp eval $i {report2}} msg4] - - list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB -} -cleanup { - safe::interpDelete $i - if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP - } -} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 ok1 0 ok2\ - {-accessPath {[list $tcl_library $ZipMountPoint/auto0/auto1 $ZipMountPoint/auto0/auto2]*}\ - -statics 1 -nested 0 -deleteHook {}}\ - {-accessPath {[list $tcl_library $ZipMountPoint/auto0/auto2 $ZipMountPoint/auto0/auto1]*}\ - -statics 1 -nested 0 -deleteHook {}}" - -test safe-9.10z {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement; zipfs} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 - } -} -body { - # For complete correspondence to safe-9.10opt, include auto0 in access path. - set i [safe::interpCreate -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0] \ - [file join $ZipMountPoint auto0 auto1] \ - [file join $ZipMountPoint auto0 auto2]]] - - # Inspect. - set confA [safe::interpConfigure $i] - set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0]] - set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] - set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] - - # Load pkgIndex.tcl data. - catch {interp eval $i {package require NOEXIST}} - - # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}. - # This would have no effect because the records in Pkg of these directories - # were from access as children of {$p(:1:)}. - safe::interpConfigure $i -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0] \ - [file join $ZipMountPoint auto0 auto2] \ - [file join $ZipMountPoint auto0 auto1]] - - # Inspect. - set confB [safe::interpConfigure $i] - set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] - set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] - - # Try to load the packages and run a command from each one. - set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] - set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] - set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] - set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] - - list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB \ - $code5 $msg5 $code6 $msg6 - -} -cleanup { - safe::interpDelete $i - if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP - } -} -match glob -result "{\$p(:2:)} {\$p(:3:)} {\$p(:3:)} {\$p(:2:)} 0 1.2.3 0 2.3.4\ - {-accessPath {[list $tcl_library $ZipMountPoint/auto0 $ZipMountPoint/auto0/auto1 $ZipMountPoint/auto0/auto2]*}\ - -statics 1 -nested 0 -deleteHook {}}\ - {-accessPath {[list $tcl_library $ZipMountPoint/auto0 $ZipMountPoint/auto0/auto2 $ZipMountPoint/auto0/auto1]*}\ - -statics 1 -nested 0 -deleteHook {}}\ - 0 OK1 0 OK2" - -test safe-9.11z {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0; zipfs} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 - } -} -body { - set i [safe::interpCreate -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0 auto1] \ - [file join $ZipMountPoint auto0 auto2]]] - - # Inspect. - set confA [safe::interpConfigure $i] - set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] - set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] - - # Load pkgIndex.tcl data. - catch {interp eval $i {package require NOEXIST}} - - # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. - safe::interpConfigure $i -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0 auto2] \ - [file join $ZipMountPoint auto0 auto1]] - - # Inspect. - set confB [safe::interpConfigure $i] - set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] - set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] - - # Try to load the packages and run a command from each one. - set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] - set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] - set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] - set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] - - list $path1 $path2 $path3 $path4 $code3 $msg3 $code4 $msg4 $confA $confB \ - $code5 $msg5 $code6 $msg6 -} -cleanup { - safe::interpDelete $i - if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP - } -} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:2:)} {\$p(:1:)} 0 1.2.3 0 2.3.4\ - {-accessPath {[list $tcl_library $ZipMountPoint/auto0/auto1 $ZipMountPoint/auto0/auto2]*}\ - -statics 1 -nested 0 -deleteHook {}}\ - {-accessPath {[list $tcl_library $ZipMountPoint/auto0/auto2 $ZipMountPoint/auto0/auto1]*}\ - -statics 1 -nested 0 -deleteHook {}}\ - 0 OK1 0 OK2" - -test safe-9.12z {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed; zipfs} -setup { + $ZipMountPoint/auto0/auto1 \ + $ZipMountPoint/auto0/auto2 \ + $ZipMountPoint/auto0/modules \ + $ZipMountPoint/auto0/modules/mod1 \ + $ZipMountPoint/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" +test safe-9.22 {interpConfigure change the access path; check module loading; stale data case 0} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 1 } + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] } -body { - set i [safe::interpCreate -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0 auto1] \ - [file join $ZipMountPoint auto0 auto2]]] + set i [safe::interpCreate -accessPath [list $tcl_library]] # Inspect. set confA [safe::interpConfigure $i] - set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]] - set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]] - - # Load pkgIndex.tcl data. - catch {interp eval $i {package require NOEXIST}} + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] - # Limit access path. Remove tokens {$p(:1:)} and {$p(:2:)}. - safe::interpConfigure $i -accessPath [list $tcl_library] + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] # Inspect. set confB [safe::interpConfigure $i] - set code4 [catch {::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto1]} path4] - set code5 [catch {::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 auto2]} path5] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] - # Try to load the packages. - set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] - set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6] + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] - list $path1 $path2 $code4 $path4 $code5 $path5 $code3 $msg3 $code6 $msg6 $confA $confB + list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + $out0 $out1 $out2 } -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{\$p(:1:)} {\$p(:2:)} 1 {* not found in access path}\ - 1 {* not found in access path} 1 {*} 1 {*}\ - {-accessPath {[list $tcl_library $ZipMountPoint/auto0/auto1 $ZipMountPoint/auto0/auto2]*}\ - -statics 1 -nested 0 -deleteHook {}}\ - {-accessPath {[list $tcl_library]*} -statics 1 -nested 0 -deleteHook {}}" - -test safe-9.20z {check module loading; zipfs} -setup { +} -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + {-accessPath {[list $tcl_library \ + $TestsDir/auto0/auto1 \ + $TestsDir/auto0/auto2 \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + res0 res1 res2" +test safe-9.22z {interpConfigure change the access path; check module loading; stale data case 0; zipfs} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -1967,6 +1892,19 @@ test safe-9.20z {check module loading; zipfs} -setup { set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] + + # Inspect. + set confB [safe::interpConfigure $i] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + # Try to load the packages and run a command from each one. set code0 [catch {interp eval $i {package require test0}} msg0] set code1 [catch {interp eval $i {package require mod1::test1}} msg1] @@ -1975,8 +1913,9 @@ test safe-9.20z {check module loading; zipfs} -setup { set out1 [interp eval $i {mod1::test1::try1}] set out2 [interp eval $i {mod2::test2::try2}] - list $path0 $path1 $path2 -- $modsA -- \ - $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $out0 $out1 $out2 + list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ + $out0 $out1 $out2 } -cleanup { tcl::tm::path remove [file join $ZipMountPoint auto0 modules] foreach path [lreverse $oldTm] { @@ -1987,14 +1926,22 @@ test safe-9.20z {check module loading; zipfs} -setup { safe::setAutoPathSync $SyncVal_TMP } } -match glob -result "{\$p(:1:)} {\$p(:2:)} {\$p(:3:)} -- {{\$p(:1:)}} --\ + {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ 0 0.5 0 1.0 0 2.0 --\ - {-accessPath {[list $tcl_library $ZipMountPoint/auto0/modules \ - $ZipMountPoint/auto0/modules/mod1 \ - $ZipMountPoint/auto0/modules/mod2]*}\ + {-accessPath {[list $tcl_library \ + $ZipMountPoint/auto0/modules \ + $ZipMountPoint/auto0/modules/mod1 \ + $ZipMountPoint/auto0/modules/mod2]}\ + -statics 1 -nested 0 -deleteHook {}} --\ + {-accessPath {[list $tcl_library \ + $ZipMountPoint/auto0/auto1 \ + $ZipMountPoint/auto0/auto2 \ + $ZipMountPoint/auto0/modules \ + $ZipMountPoint/auto0/modules/mod1 \ + $ZipMountPoint/auto0/modules/mod2]}\ -statics 1 -nested 0 -deleteHook {}} --\ res0 res1 res2" - -test safe-9.21z {interpConfigure change the access path; check module loading; stale data case 1; zipfs} -setup { +test safe-9.23 {interpConfigure change the access path; check module loading; stale data case 3} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -2004,31 +1951,36 @@ test safe-9.21z {interpConfigure change the access path; check module loading; s foreach path $oldTm { tcl::tm::path remove $path } - tcl::tm::path add [file join $ZipMountPoint auto0 modules] + tcl::tm::path add [file join $TestsDir auto0 modules] } -body { set i [safe::interpCreate -accessPath [list $tcl_library]] # Inspect. set confA [safe::interpConfigure $i] set modsA [interp eval $i {tcl::tm::path list}] - set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] - set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] - set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} # Add to access path. # This injects more tokens, pushing modules to higher token numbers. safe::interpConfigure $i -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0 auto1] \ - [file join $ZipMountPoint auto0 auto2]] + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] # Inspect. set confB [safe::interpConfigure $i] set modsB [interp eval $i {tcl::tm::path list}] - set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] - set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] - set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] - # Load pkg data. + # Refresh stale pkg data. catch {interp eval $i {package require NOEXIST}} catch {interp eval $i {package require mod1::NOEXIST}} catch {interp eval $i {package require mod2::NOEXIST}} @@ -2044,8 +1996,9 @@ test safe-9.21z {interpConfigure change the access path; check module loading; s list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ $out0 $out1 $out2 + } -cleanup { - tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + tcl::tm::path remove [file join $TestsDir auto0 modules] foreach path [lreverse $oldTm] { tcl::tm::path add $path } @@ -2057,20 +2010,19 @@ test safe-9.21z {interpConfigure change the access path; check module loading; s {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ 0 0.5 0 1.0 0 2.0 --\ {-accessPath {[list $tcl_library \ - $ZipMountPoint/auto0/modules \ - $ZipMountPoint/auto0/modules/mod1 \ - $ZipMountPoint/auto0/modules/mod2]}\ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ -statics 1 -nested 0 -deleteHook {}} --\ {-accessPath {[list $tcl_library \ - $ZipMountPoint/auto0/auto1 \ - $ZipMountPoint/auto0/auto2 \ - $ZipMountPoint/auto0/modules \ - $ZipMountPoint/auto0/modules/mod1 \ - $ZipMountPoint/auto0/modules/mod2]}\ + $TestsDir/auto0/auto1 \ + $TestsDir/auto0/auto2 \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ -statics 1 -nested 0 -deleteHook {}} --\ res0 res1 res2" - -test safe-9.22z {interpConfigure change the access path; check module loading; stale data case 0; zipfs} -setup { +test safe-9.23z {interpConfigure change the access path; check module loading; stale data case 3; zipfs} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -2091,11 +2043,16 @@ test safe-9.22z {interpConfigure change the access path; check module loading; s set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + # Add to access path. # This injects more tokens, pushing modules to higher token numbers. safe::interpConfigure $i -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0 auto1] \ - [file join $ZipMountPoint auto0 auto2]] + [file join $ZipMountPoint auto0 auto1] \ + [file join $ZipMountPoint auto0 auto2]] # Inspect. set confB [safe::interpConfigure $i] @@ -2104,6 +2061,11 @@ test safe-9.22z {interpConfigure change the access path; check module loading; s set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + # Refresh stale pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + # Try to load the packages and run a command from each one. set code0 [catch {interp eval $i {package require test0}} msg0] set code1 [catch {interp eval $i {package require mod1::test1}} msg1] @@ -2115,6 +2077,7 @@ test safe-9.22z {interpConfigure change the access path; check module loading; s list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ $out0 $out1 $out2 + } -cleanup { tcl::tm::path remove [file join $ZipMountPoint auto0 modules] foreach path [lreverse $oldTm] { @@ -2140,8 +2103,7 @@ test safe-9.22z {interpConfigure change the access path; check module loading; s $ZipMountPoint/auto0/modules/mod2]}\ -statics 1 -nested 0 -deleteHook {}} --\ res0 res1 res2" - -test safe-9.23z {interpConfigure change the access path; check module loading; stale data case 3; zipfs} -setup { +test safe-9.24 {interpConfigure change the access path; check module loading; stale data case 2 (worst case)} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -2151,16 +2113,16 @@ test safe-9.23z {interpConfigure change the access path; check module loading; s foreach path $oldTm { tcl::tm::path remove $path } - tcl::tm::path add [file join $ZipMountPoint auto0 modules] + tcl::tm::path add [file join $TestsDir auto0 modules] } -body { set i [safe::interpCreate -accessPath [list $tcl_library]] # Inspect. set confA [safe::interpConfigure $i] set modsA [interp eval $i {tcl::tm::path list}] - set path0 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] - set path1 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] - set path2 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] # Force the interpreter to acquire pkg data which will soon become stale. catch {interp eval $i {package require NOEXIST}} @@ -2170,20 +2132,15 @@ test safe-9.23z {interpConfigure change the access path; check module loading; s # Add to access path. # This injects more tokens, pushing modules to higher token numbers. safe::interpConfigure $i -accessPath [list $tcl_library \ - [file join $ZipMountPoint auto0 auto1] \ - [file join $ZipMountPoint auto0 auto2]] + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] # Inspect. set confB [safe::interpConfigure $i] set modsB [interp eval $i {tcl::tm::path list}] - set path3 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules]] - set path4 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod1]] - set path5 [::safe::interpFindInAccessPath $i [file join $ZipMountPoint auto0 modules mod2]] - - # Refresh stale pkg data. - catch {interp eval $i {package require NOEXIST}} - catch {interp eval $i {package require mod1::NOEXIST}} - catch {interp eval $i {package require mod2::NOEXIST}} + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] # Try to load the packages and run a command from each one. set code0 [catch {interp eval $i {package require test0}} msg0] @@ -2196,9 +2153,8 @@ test safe-9.23z {interpConfigure change the access path; check module loading; s list $path0 $path1 $path2 -- $modsA -- $path3 $path4 $path5 -- $modsB -- \ $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $confA -- $confB -- \ $out0 $out1 $out2 - } -cleanup { - tcl::tm::path remove [file join $ZipMountPoint auto0 modules] + tcl::tm::path remove [file join $TestsDir auto0 modules] foreach path [lreverse $oldTm] { tcl::tm::path add $path } @@ -2210,19 +2166,18 @@ test safe-9.23z {interpConfigure change the access path; check module loading; s {\$p(:3:)} {\$p(:4:)} {\$p(:5:)} -- {{\$p(:3:)}} --\ 0 0.5 0 1.0 0 2.0 --\ {-accessPath {[list $tcl_library \ - $ZipMountPoint/auto0/modules \ - $ZipMountPoint/auto0/modules/mod1 \ - $ZipMountPoint/auto0/modules/mod2]}\ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ -statics 1 -nested 0 -deleteHook {}} --\ {-accessPath {[list $tcl_library \ - $ZipMountPoint/auto0/auto1 \ - $ZipMountPoint/auto0/auto2 \ - $ZipMountPoint/auto0/modules \ - $ZipMountPoint/auto0/modules/mod1 \ - $ZipMountPoint/auto0/modules/mod2]}\ + $TestsDir/auto0/auto1 \ + $TestsDir/auto0/auto2 \ + $TestsDir/auto0/modules \ + $TestsDir/auto0/modules/mod1 \ + $TestsDir/auto0/modules/mod2]}\ -statics 1 -nested 0 -deleteHook {}} --\ res0 res1 res2" - test safe-9.24z {interpConfigure change the access path; check module loading; stale data case 2 (worst case); zipfs} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { @@ -2764,7 +2719,41 @@ test safe-17.2 {Check that first element of slave auto_path (and access path) is ### 18. Tests for AutoSyncDefined without conventional AutoPathSync, i.e. with AutoPathSync off. -test safe-18.1opt {cf. safe-7.1opt - tests that everything works at high level without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup { +test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without conventional AutoPathSync} -constraints AutoSyncDefined -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + + # Without AutoPathSync, we need a more complete auto_path, + # because the slave will use the same value. + set lib1 [info library] + set lib2 [file join $TestsDir auto0] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib1 $lib2] + + set i [safe::interpCreate] + set ::auto_path $::auto_TMP +} -body { + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs so + # package require in a slave works like in the master) + set v [interp eval $i {package require SafeTestPackage1}] + # no error shall occur: + interp eval $i HeresPackage1 + set v +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result 1.2.3 +test safe-18.1z {cf. safe-7.1 - tests that everything works at high level without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -2778,7 +2767,7 @@ test safe-18.1opt {cf. safe-7.1opt - tests that everything works at high level w # Without AutoPathSync, we need a more complete auto_path, # because the slave will use the same value. set lib1 [info library] - set lib2 [file dirname $lib1] + set lib2 [file join $ZipMountPoint auto0] set ::auto_TMP $::auto_path set ::auto_path [list $lib1 $lib2] @@ -2788,18 +2777,17 @@ test safe-18.1opt {cf. safe-7.1opt - tests that everything works at high level w # no error shall occur: # (because the default access_path shall include 1st level sub dirs so # package require in a slave works like in the master) - set v [interp eval $i {package require opt}] + set v [interp eval $i {package require SafeTestPackage1}] # no error shall occur: - interp eval $i {::tcl::Lempty {a list}} + interp eval $i HeresPackage1 set v } -cleanup { safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result 0.4.* - -test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without conventional AutoPathSync} -constraints AutoSyncDefined -setup { +} -match glob -result 1.2.3 +test safe-18.1opt {cf. safe-7.1opt - tests that everything works at high level without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -2813,7 +2801,7 @@ test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without # Without AutoPathSync, we need a more complete auto_path, # because the slave will use the same value. set lib1 [info library] - set lib2 [file join $TestsDir auto0] + set lib2 [file dirname $lib1] set ::auto_TMP $::auto_path set ::auto_path [list $lib1 $lib2] @@ -2823,18 +2811,17 @@ test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without # no error shall occur: # (because the default access_path shall include 1st level sub dirs so # package require in a slave works like in the master) - set v [interp eval $i {package require SafeTestPackage1}] + set v [interp eval $i {package require opt}] # no error shall occur: - interp eval $i HeresPackage1 + interp eval $i {::tcl::Lempty {a list}} set v } -cleanup { safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result 1.2.3 - -test safe-18.2opt {cf. safe-7.2opt - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup { +} -match glob -result 0.4.* +test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -2852,21 +2839,25 @@ test safe-18.2opt {cf. safe-7.2opt - tests specific path and interpFind/AddToAcc set token1 [safe::interpAddToAccessPath $i [info library]] # should add as p* (not p1 if master has a module path) set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] - # an error shall occur (opt is not anymore in the secure 0-level + # should add as p* (not p2 if master has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]] + # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level # provided deep path) - list $auto1 $token1 $token2 \ - [catch {interp eval $i {package require opt}} msg] $msg \ + list $auto1 $token1 $token2 $token3 \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ [safe::interpConfigure $i]\ [safe::interpDelete $i] } -cleanup { if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {$pkgOptErrMsg}\ - {-accessPath {[list $tcl_library */dummy/unixlike/test/path]}\ +} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)}\ + 1 {can't find package SafeTestPackage1}\ + {-accessPath {[list $tcl_library \ + */dummy/unixlike/test/path \ + $TestsDir/auto0]}\ -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" - -test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync} -constraints AutoSyncDefined -setup { +test safe-18.2z {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -2885,7 +2876,7 @@ test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPat # should add as p* (not p1 if master has a module path) set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] # should add as p* (not p2 if master has a module path) - set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]] + set token3 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0]] # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level # provided deep path) list $auto1 $token1 $token2 $token3 \ @@ -2900,9 +2891,39 @@ test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPat 1 {can't find package SafeTestPackage1}\ {-accessPath {[list $tcl_library \ */dummy/unixlike/test/path \ - $TestsDir/auto0]}\ + $ZipMountPoint/auto0]}\ -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" +test safe-18.2opt {cf. safe-7.2opt - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + set auto1 [interp eval $i {set ::auto_path}] + interp eval $i {set ::auto_path [list {$p(:0:)}]} + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if master has a module path) + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + # an error shall occur (opt is not anymore in the secure 0-level + # provided deep path) + list $auto1 $token1 $token2 \ + [catch {interp eval $i {package require opt}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] +} -cleanup { + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {$pkgOptErrMsg}\ + {-accessPath {[list $tcl_library */dummy/unixlike/test/path]}\ + -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" test safe-18.3 {Check that default auto_path is the same as in the master interpreter without conventional AutoPathSync} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -2931,8 +2952,7 @@ test safe-18.3 {Check that default auto_path is the same as in the master interp safe::setAutoPathSync $SyncVal_TMP } } -result $::auto_path - -test safe-18.4opt {cf. safe-7.4opt - tests specific path and positive search and auto_path without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup { +test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -2954,25 +2974,30 @@ test safe-18.4opt {cf. safe-7.4opt - tests specific path and positive search and set token1 [safe::interpAddToAccessPath $i [info library]] # should add as p* (not p1 if master has a module path) - set token2 [safe::interpAddToAccessPath $i [file join [info library] $pkgOptDir]] + set token2 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]] + + # should add as p* (not p2 if master has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0 auto1]] # should not have been changed by Safe Base: set auto2 [interp eval $i {set ::auto_path}] - # This time, unlike test safe-18.2opt and the try above, opt should be found: - list $auto1 $auto2 $token1 $token2 \ - [catch {interp eval $i {package require opt}} msg] $msg \ + set auto3 [interp eval $i [list set ::auto_path [list {$p(:0:)} $token2]]] + + # This time, unlike test safe-18.2 and the try above, SafeTestPackage1 should be found: + list $auto1 $auto2 $token1 $token2 $token3 \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ [safe::interpConfigure $i]\ [safe::interpDelete $i] } -cleanup { if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 0.4.*\ - {-accessPath {[list $tcl_library *$tcl_library/$pkgOptDir]}\ - -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" - -test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync} -constraints AutoSyncDefined -setup { +} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 0 1.2.3\ + {-accessPath {[list $tcl_library *$TestsDir/auto0 $TestsDir/auto0/auto1]}\ + -statics 0 -nested 1 -deleteHook {}\ + -autoPath {[list $tcl_library $TestsDir/auto0]}} {}" +test safe-18.4z {cf. safe-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -2994,10 +3019,10 @@ test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_ set token1 [safe::interpAddToAccessPath $i [info library]] # should add as p* (not p1 if master has a module path) - set token2 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]] + set token2 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0]] # should add as p* (not p2 if master has a module path) - set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0 auto1]] + set token3 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0 auto1]] # should not have been changed by Safe Base: set auto2 [interp eval $i {set ::auto_path}] @@ -3014,77 +3039,10 @@ test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_ safe::setAutoPathSync $SyncVal_TMP } } -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 0 1.2.3\ - {-accessPath {[list $tcl_library *$TestsDir/auto0 $TestsDir/auto0/auto1]}\ + {-accessPath {[list $tcl_library *$ZipMountPoint/auto0 $ZipMountPoint/auto0/auto1]}\ -statics 0 -nested 1 -deleteHook {}\ - -autoPath {[list $tcl_library $TestsDir/auto0]}} {}" - -test safe-18.5 {cf. safe-7.5 - tests positive and negative module loading without conventional AutoPathSync} -setup { - # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - - if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 - } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} - } - - set i [safe::interpCreate] - - interp eval $i { - package forget platform::shell - package forget platform - catch {namespace delete ::platform} - } -} -body { - # Should raise an error (tests module ancestor directory rule) - set code1 [catch {interp eval $i {package require shell}} msg1] - # Should not raise an error - set code2 [catch {interp eval $i {package require platform::shell}} msg2] - return [list $code1 $msg1 $code2] -} -cleanup { - safe::interpDelete $i - if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP - } -} -result {1 {can't find package shell} 0} - -test safe-18.1z {cf. safe-7.1 - tests that everything works at high level without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup { - # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - - if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 - } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} - } - - # Without AutoPathSync, we need a more complete auto_path, - # because the slave will use the same value. - set lib1 [info library] - set lib2 [file join $ZipMountPoint auto0] - set ::auto_TMP $::auto_path - set ::auto_path [list $lib1 $lib2] - - set i [safe::interpCreate] - set ::auto_path $::auto_TMP -} -body { - # no error shall occur: - # (because the default access_path shall include 1st level sub dirs so - # package require in a slave works like in the master) - set v [interp eval $i {package require SafeTestPackage1}] - # no error shall occur: - interp eval $i HeresPackage1 - set v -} -cleanup { - safe::interpDelete $i - if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP - } -} -match glob -result 1.2.3 - -test safe-18.2z {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup { + -autoPath {[list $tcl_library $ZipMountPoint/auto0]}} {}" +test safe-18.4opt {cf. safe-7.4opt - tests specific path and positive search and auto_path without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -3096,32 +3054,34 @@ test safe-18.2z {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPa } } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + + # should not have been set by Safe Base: set auto1 [interp eval $i {set ::auto_path}] + interp eval $i {set ::auto_path [list {$p(:0:)}]} + # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p* (not p1 if master has a module path) - set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] - # should add as p* (not p2 if master has a module path) - set token3 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0]] - # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level - # provided deep path) - list $auto1 $token1 $token2 $token3 \ - [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ + set token2 [safe::interpAddToAccessPath $i [file join [info library] $pkgOptDir]] + + # should not have been changed by Safe Base: + set auto2 [interp eval $i {set ::auto_path}] + + # This time, unlike test safe-18.2opt and the try above, opt should be found: + list $auto1 $auto2 $token1 $token2 \ + [catch {interp eval $i {package require opt}} msg] $msg \ [safe::interpConfigure $i]\ [safe::interpDelete $i] } -cleanup { if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)}\ - 1 {can't find package SafeTestPackage1}\ - {-accessPath {[list $tcl_library \ - */dummy/unixlike/test/path \ - $ZipMountPoint/auto0]}\ +} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 0.4.*\ + {-accessPath {[list $tcl_library *$tcl_library/$pkgOptDir]}\ -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" - -test safe-18.4z {cf. safe-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup { +test safe-18.5 {cf. safe-7.5 - tests positive and negative module loading without conventional AutoPathSync} -setup { # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -3131,41 +3091,27 @@ test safe-18.4z {cf. safe-7.4 - tests specific path and positive search and auto } else { error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } -} -body { - set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] - - # should not have been set by Safe Base: - set auto1 [interp eval $i {set ::auto_path}] - - interp eval $i {set ::auto_path [list {$p(:0:)}]} - - # should not add anything (p0) - set token1 [safe::interpAddToAccessPath $i [info library]] - - # should add as p* (not p1 if master has a module path) - set token2 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0]] - - # should add as p* (not p2 if master has a module path) - set token3 [safe::interpAddToAccessPath $i [file join $ZipMountPoint auto0 auto1]] - - # should not have been changed by Safe Base: - set auto2 [interp eval $i {set ::auto_path}] - set auto3 [interp eval $i [list set ::auto_path [list {$p(:0:)} $token2]]] + set i [safe::interpCreate] - # This time, unlike test safe-18.2 and the try above, SafeTestPackage1 should be found: - list $auto1 $auto2 $token1 $token2 $token3 \ - [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ - [safe::interpConfigure $i]\ - [safe::interpDelete $i] + interp eval $i { + package forget platform::shell + package forget platform + catch {namespace delete ::platform} + } +} -body { + # Should raise an error (tests module ancestor directory rule) + set code1 [catch {interp eval $i {package require shell}} msg1] + # Should not raise an error + set code2 [catch {interp eval $i {package require platform::shell}} msg2] + return [list $code1 $msg1 $code2] } -cleanup { + safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 0 1.2.3\ - {-accessPath {[list $tcl_library *$ZipMountPoint/auto0 $ZipMountPoint/auto0/auto1]}\ - -statics 0 -nested 1 -deleteHook {}\ - -autoPath {[list $tcl_library $ZipMountPoint/auto0]}} {}" +} -result {1 {can't find package shell} 0} + ### 19. Test tokenization of directories available to a slave. -- cgit v0.12 From b7691676aafa7a3b4ae2464af6e1c4051084c12d Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 22 Jul 2020 19:38:22 +0000 Subject: Move tests that depend on platform::shell and http1.0 from safe.test to safe-stock86.test, and replace with tests that use example packages. Add -setup and -cleanup code where missing from tests that use AutoPathSync. --- tests/safe-stock86.test | 157 +++++++++++++++++++++++++++++++- tests/safe.test | 231 +++++++++++++++++++++++++++++++----------------- 2 files changed, 303 insertions(+), 85 deletions(-) diff --git a/tests/safe-stock86.test b/tests/safe-stock86.test index 2fbe108..a3f6bb5 100644 --- a/tests/safe-stock86.test +++ b/tests/safe-stock86.test @@ -50,6 +50,7 @@ catch {safe::interpConfigure} # package - Tcltest - but it might be absent if we're in standard tclsh) testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}] +testConstraint AutoSyncDefined 1 # high level general test test safe-stock86-7.1 {tests that everything works at high level, uses http 2} -body { @@ -91,6 +92,31 @@ test safe-stock86-7.4 {tests specific path and positive search, uses http1.0} -b [catch {interp eval $i {package require http 1}} msg] $msg -- \ $mappA -- [safe::interpDelete $i] } -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.0 -- {TCLLIB *TCLLIB/http1.0} -- {}} +test safe-stock86-7.5 {tests positive and negative module loading with conventional AutoPathSync} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + set i [safe::interpCreate] + interp eval $i { + package forget platform::shell + package forget platform + catch {namespace delete ::platform} +# for platform::shell use mod1::test1 + } +} -body { + # Should raise an error (module ancestor directory issue) + set code1 [catch {interp eval $i {package require shell}} msg1] + # Should not raise an error + set code2 [catch {interp eval $i {package require platform::shell}} msg2] + return [list $code1 $msg1 $code2] +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {1 {can't find package shell} 0} # The following test checks whether the definition of tcl_endOfWord can be # obtained from auto_loading. It was previously test "safe-5.1". @@ -102,12 +128,139 @@ test safe-stock86-9.8 {test auto-loading in safe interpreters, was test 5.1} -se } -cleanup { safe::interpDelete a } -result -1 + +### 18. Tests for AutoSyncDefined without conventional AutoPathSync, i.e. with AutoPathSync off. +test safe-stock86-18.1 {cf. safe-stock86-7.1 - tests that everything works at high level without conventional AutoPathSync} -constraints AutoSyncDefined -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + + # Without AutoPathSync, we need a more complete auto_path, + # because the slave will use the same value. + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib1 $lib2] + + set i [safe::interpCreate] + set ::auto_path $::auto_TMP +} -body { + # no error shall occur: + # (because the default access_path shall include 1st level sub dirs so + # package require in a slave works like in the master) + set v [interp eval $i {package require http 1}] + # no error shall occur: + interp eval $i {http_config} + set v +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result 1.0 +test safe-stock86-18.2 {cf. safe-stock86-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync} -constraints AutoSyncDefined -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + set auto1 [interp eval $i {set ::auto_path}] + interp eval $i {set ::auto_path [list {$p(:0:)}]} + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + # should add as p1 + set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] + # an error shall occur (http is not anymore in the secure 0-level + # provided deep path) + list $auto1 $token1 $token2 \ + [catch {interp eval $i {package require http 1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] +} -cleanup { + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" +test safe-stock86-18.4 {cf. safe-stock86-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync} -constraints AutoSyncDefined -setup { + # All ::safe commands are loaded at start of file. + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + + # should not have been set by Safe Base: + set auto1 [interp eval $i {set ::auto_path}] + + interp eval $i {set ::auto_path [list {$p(:0:)}]} + + # should not add anything (p0) + set token1 [safe::interpAddToAccessPath $i [info library]] + + # should add as p* (not p1 if master has a module path) + set token2 [safe::interpAddToAccessPath $i [file join [info library] http1.0]] + + # should not have been changed by Safe Base: + set auto2 [interp eval $i {set ::auto_path}] + + # This time, unlike test safe-stock86-18.2 and the try above, http 1.0 should be found: + list $auto1 $auto2 $token1 $token2 \ + [catch {interp eval $i {package require http 1}} msg] $msg \ + [safe::interpConfigure $i]\ + [safe::interpDelete $i] +} -cleanup { + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" +test safe-stock86-18.5 {cf. safe-stock86-7.5 - tests positive and negative module loading without conventional AutoPathSync} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set i [safe::interpCreate] + interp eval $i { + package forget platform::shell + package forget platform + catch {namespace delete ::platform} + } +} -body { + # Should raise an error (tests module ancestor directory rule) + set code1 [catch {interp eval $i {package require shell}} msg1] + # Should not raise an error + set code2 [catch {interp eval $i {package require platform::shell}} msg2] + return [list $code1 $msg1 $code2] +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {1 {can't find package shell} 0} +# cleanup set ::auto_path $SaveAutoPath unset SaveAutoPath TestsDir PathMapp rename mapList {} - -# cleanup ::tcltest::cleanupTests return diff --git a/tests/safe.test b/tests/safe.test index ec469ee..5987ce8 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -28,8 +28,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } -testConstraint AutoSyncDefined 1 - foreach i [interp slaves] { interp delete $i } @@ -62,6 +60,7 @@ catch {safe::interpConfigure} # package - Tcltest - but it might be absent if we're in standard tclsh) testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}] +testConstraint AutoSyncDefined 1 test safe-1.1 {safe::interpConfigure syntax} -returnCodes error -body { safe::interpConfigure @@ -287,7 +286,6 @@ test safe-5.6 {example modules packages, test in master interpreter, append to p catch {namespace delete ::mod1} } -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} - # test safe interps 'information leak' proc SafeEval {script} { # Helper procedure that ensures the safe interp is cleaned up even if @@ -319,9 +317,8 @@ rename SafeEval {} # leaking infos, but they still do... # high level general test -# Use example packages not http1.0 +# Use example packages not http1.0 etc test safe-7.1 {tests that everything works at high level with conventional AutoPathSync} -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -346,9 +343,7 @@ test safe-7.1 {tests that everything works at high level with conventional AutoP } } -match glob -result 1.2.3 test safe-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync} -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 1 @@ -409,9 +404,7 @@ test safe-7.3.1 {check that safe subinterpreters work with namespace names} -set [interp exists $j] [info vars ::safe::S*] } -match glob -result {{} {} ok ok {} 0 {}} test safe-7.4 {tests specific path and positive search with conventional AutoPathSync} -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 1 @@ -439,33 +432,30 @@ test safe-7.4 {tests specific path and positive search with conventional AutoPat } -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\ {TCLLIB * TESTSDIR/auto0/auto1} -- {}} test safe-7.5 {tests positive and negative module loading with conventional AutoPathSync} -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 1 } - + tcl::tm::path add [file join $TestsDir auto0 modules] set i [safe::interpCreate] - + tcl::tm::path remove [file join $TestsDir auto0 modules] interp eval $i { - package forget platform::shell - package forget platform - catch {namespace delete ::platform} + package forget mod1::test1 + catch {namespace delete ::mod1} } } -body { # Should raise an error (module ancestor directory issue) - set code1 [catch {interp eval $i {package require shell}} msg1] + set code1 [catch {interp eval $i {package require test1}} msg1] # Should not raise an error - set code2 [catch {interp eval $i {package require platform::shell}} msg2] + set code2 [catch {interp eval $i {package require mod1::test1}} msg2] return [list $code1 $msg1 $code2] } -cleanup { safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -result {1 {can't find package shell} 0} +} -result {1 {can't find package test1} 0} # test source control on file name test safe-8.1 {safe source control on file} -setup { @@ -734,7 +724,12 @@ test safe-9.8 {test autoloading commands indexed in tclIndex files} -setup { safe::interpDelete $i } -match glob -result {{$p(:1:)} {$p(:2:)} -- 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*}} -test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset)} -setup { +test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset), with conventional AutoPathSync} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ @@ -770,10 +765,18 @@ test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffec list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB } -cleanup { safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} -test safe-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset)} -setup { +test safe-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset), with conventional AutoPathSync} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ @@ -807,11 +810,19 @@ test safe-9.10 {interpConfigure change the access path; tclIndex commands unaffe list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB } -cleanup { safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} -test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement} -setup { +test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, with conventional AutoPathSync} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } } -body { # For complete correspondence to safe-9.10opt, include auto0 in access path. set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -851,11 +862,19 @@ test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages un $mappA -- $mappB -- $code5 $msg5 $code6 $msg6 } -cleanup { safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } } -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ 0 OK1 0 OK2} -test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0} -setup { +test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0, with conventional AutoPathSync} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ @@ -890,12 +909,20 @@ test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages un $code5 $msg5 $code6 $msg6 } -cleanup { safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ 0 1.2.3 0 2.3.4 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ 0 OK1 0 OK2} -test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed} -setup { +test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, with conventional AutoPathSync} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ @@ -926,10 +953,18 @@ test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fa $mappA -- $mappB } -cleanup { safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } } -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\ 1 {* not found in access path} -- 1 1 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} -- {TCLLIB*}} -test safe-9.20 {check module loading} -setup { +test safe-9.20 {check module loading, with conventional AutoPathSync} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } set oldTm [tcl::tm::path list] foreach path $oldTm { tcl::tm::path remove $path @@ -962,6 +997,9 @@ test safe-9.20 {check module loading} -setup { tcl::tm::path add $path } safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ 0 0.5 0 1.0 0 2.0 --\ {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ @@ -975,7 +1013,12 @@ test safe-9.20 {check module loading} -setup { # directories in the access path. Both those things must be sorted before # comparing with expected results. The test is therefore not totally strict, # but will notice missing or surplus directories. -test safe-9.21 {interpConfigure change the access path; check module loading; stale data case 1} -setup { +test safe-9.21 {interpConfigure change the access path; check module loading, with conventional AutoPathSync; stale data case 1} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } set oldTm [tcl::tm::path list] foreach path $oldTm { tcl::tm::path remove $path @@ -1028,6 +1071,9 @@ test safe-9.21 {interpConfigure change the access path; check module loading; st tcl::tm::path add $path } safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ 0 0.5 0 1.0 0 2.0 --\ @@ -1037,7 +1083,12 @@ test safe-9.21 {interpConfigure change the access path; check module loading; st TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ res0 res1 res2} # See comments on lsort after test safe-9.20. -test safe-9.22 {interpConfigure change the access path; check module loading; stale data case 0} -setup { +test safe-9.22 {interpConfigure change the access path; check module loading, with conventional AutoPathSync; stale data case 0} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } set oldTm [tcl::tm::path list] foreach path $oldTm { tcl::tm::path remove $path @@ -1075,7 +1126,7 @@ test safe-9.22 {interpConfigure change the access path; check module loading; st set out1 [interp eval $i {mod1::test1::try1}] set out2 [interp eval $i {mod2::test2::try2}] - list [lsort [list $path0 $path1 $path2]] -- $modsA --\ + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ [lsort [list $path3 $path4 $path5]] -- $modsB -- \ $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ $out0 $out1 $out2 @@ -1085,6 +1136,9 @@ test safe-9.22 {interpConfigure change the access path; check module loading; st tcl::tm::path add $path } safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ 0 0.5 0 1.0 0 2.0 --\ @@ -1094,7 +1148,12 @@ test safe-9.22 {interpConfigure change the access path; check module loading; st TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ res0 res1 res2} # See comments on lsort after test safe-9.20. -test safe-9.23 {interpConfigure change the access path; check module loading; stale data case 3} -setup { +test safe-9.23 {interpConfigure change the access path; check module loading, with conventional AutoPathSync; stale data case 3} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } set oldTm [tcl::tm::path list] foreach path $oldTm { tcl::tm::path remove $path @@ -1142,7 +1201,7 @@ test safe-9.23 {interpConfigure change the access path; check module loading; st set out1 [interp eval $i {mod1::test1::try1}] set out2 [interp eval $i {mod2::test2::try2}] - list [lsort [list $path0 $path1 $path2]] -- $modsA --\ + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ [lsort [list $path3 $path4 $path5]] -- $modsB -- \ $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ $out0 $out1 $out2 @@ -1152,6 +1211,9 @@ test safe-9.23 {interpConfigure change the access path; check module loading; st tcl::tm::path add $path } safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ 0 0.5 0 1.0 0 2.0 --\ @@ -1161,7 +1223,12 @@ test safe-9.23 {interpConfigure change the access path; check module loading; st TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ res0 res1 res2} # See comments on lsort after test safe-9.20. -test safe-9.24 {interpConfigure change the access path; check module loading; stale data case 2 (worst case)} -setup { +test safe-9.24 {interpConfigure change the access path; check module loading, with conventional AutoPathSync; stale data case 2 (worst case)} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } set oldTm [tcl::tm::path list] foreach path $oldTm { tcl::tm::path remove $path @@ -1214,6 +1281,9 @@ test safe-9.24 {interpConfigure change the access path; check module loading; st tcl::tm::path add $path } safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ 0 0.5 0 1.0 0 2.0 --\ @@ -1606,7 +1676,7 @@ test safe-15.1 {safe file ensemble does not surprise code} -setup { unset -nocomplain msg interp delete $i } -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}} -test safe-15.1.1 {safe file ensemble does not surprise code} -setup { +test safe-15.2 {safe file ensemble does not surprise code} -setup { set i [interp create -safe] } -body { set result [expr {"file" in [interp hidden $i]}] @@ -1721,9 +1791,9 @@ test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup safe::interpDelete $i unset user } -result {~USER} - -### 17. The first element in a slave's ::auto_path and access path must be [info library]. +### 17. The first element in a slave's ::auto_path and access path must be [info library]. +### Merge back to no-TIP safe.test test safe-17.1 {Check that first element of slave auto_path (and access path) is Tcl Library} -setup { set lib1 [info library] set lib2 [file dirname $lib1] @@ -1763,45 +1833,39 @@ test safe-17.2 {Check that first element of slave auto_path (and access path) is } -result [list [info library] [info library]] ### 18. Tests for AutoSyncDefined without conventional AutoPathSync, i.e. with AutoPathSync off. - test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without conventional AutoPathSync} -constraints AutoSyncDefined -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 0 } else { error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } - - # Without AutoPathSync, we need a more complete auto_path, because the slave will use the same value. + # Without AutoPathSync, we need a more complete auto_path, + # because the slave will use the same value. set lib1 [info library] - set lib2 [file dirname $lib1] + set lib2 [file join $TestsDir auto0] set ::auto_TMP $::auto_path set ::auto_path [list $lib1 $lib2] set i [safe::interpCreate] + set ::auto_path $::auto_TMP } -body { # no error shall occur: - # (because the default access_path shall include 1st level sub dirs - # so package require in a slave works like in the master) - set v [interp eval $i {package require http 1}] + # (because the default access_path shall include 1st level sub dirs so + # package require in a slave works like in the master) + set v [interp eval $i {package require SafeTestPackage1}] # no error shall occur: - interp eval $i {http_config} + interp eval $i HeresPackage1 set v } -cleanup { - set ::auto_path $::auto_TMP safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -result 1.0 - +} -match glob -result 1.2.3 test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync} -constraints AutoSyncDefined -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 0 @@ -1814,37 +1878,38 @@ test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPat interp eval $i {set ::auto_path [list {$p(:0:)}]} # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] - # should add as p1 + # should add as p* (not p1 if master has a module path) set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] - # an error shall occur (http is not anymore in the secure 0-level + # should add as p* (not p2 if master has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]] + # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level # provided deep path) - list $auto1 $token1 $token2 \ - [catch {interp eval $i {package require http 1}} msg] $msg \ + list $auto1 $token1 $token2 $token3 \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ [safe::interpConfigure $i]\ [safe::interpDelete $i] } -cleanup { if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" - +} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)}\ + 1 {can't find package SafeTestPackage1}\ + {-accessPath {[list $tcl_library \ + */dummy/unixlike/test/path \ + $TestsDir/auto0]}\ + -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" test safe-18.3 {Check that default auto_path is the same as in the master interpreter without conventional AutoPathSync} -constraints AutoSyncDefined -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 0 } else { error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } - set i [safe::interpCreate] - } -body { # This file's header sets auto_path to a single directory [info library], # which is the one required by Safe Base to be present & first in the list. - set ap {} foreach token [$i eval set ::auto_path] { lappend ap [dict get [set ::safe::S${i}(access_path,map)] $token] @@ -1855,12 +1920,9 @@ test safe-18.3 {Check that default auto_path is the same as in the master interp if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -result [set ::auto_path] - +} -result $::auto_path test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync} -constraints AutoSyncDefined -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 0 @@ -1879,55 +1941,59 @@ test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_ set token1 [safe::interpAddToAccessPath $i [info library]] # should add as p* (not p1 if master has a module path) - set token2 [safe::interpAddToAccessPath $i [file join [info library] http1.0]] + set token2 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]] + + # should add as p* (not p2 if master has a module path) + set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0 auto1]] # should not have been changed by Safe Base: set auto2 [interp eval $i {set ::auto_path}] - # This time, unlike test safe-18.2 and the try above, http 1.0 should be found: - list $auto1 $auto2 $token1 $token2 \ - [catch {interp eval $i {package require http 1}} msg] $msg \ + set auto3 [interp eval $i [list set ::auto_path [list {$p(:0:)} $token2]]] + + # This time, unlike test safe-18.2 and the try above, SafeTestPackage1 should be found: + list $auto1 $auto2 $token1 $token2 $token3 \ + [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ [safe::interpConfigure $i]\ [safe::interpDelete $i] } -cleanup { if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" - +} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 0 1.2.3\ + {-accessPath {[list $tcl_library *$TestsDir/auto0 $TestsDir/auto0/auto1]}\ + -statics 0 -nested 1 -deleteHook {}\ + -autoPath {[list $tcl_library $TestsDir/auto0]}} {}" test safe-18.5 {cf. safe-7.5 - tests positive and negative module loading without conventional AutoPathSync} -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 0 } else { error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } - + tcl::tm::path add [file join $TestsDir auto0 modules] set i [safe::interpCreate] - + tcl::tm::path remove [file join $TestsDir auto0 modules] interp eval $i { - package forget platform::shell - package forget platform - catch {namespace delete ::platform} + package forget mod1::test1 + catch {namespace delete ::mod1} } } -body { # Should raise an error (tests module ancestor directory rule) - set code1 [catch {interp eval $i {package require shell}} msg1] + set code1 [catch {interp eval $i {package require test1}} msg1] # Should not raise an error - set code2 [catch {interp eval $i {package require platform::shell}} msg2] + set code2 [catch {interp eval $i {package require mod1::test1}} msg2] return [list $code1 $msg1 $code2] } -cleanup { safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -result {1 {can't find package shell} 0} +} -result {1 {can't find package test1} 0} ### 19. Test tokenization of directories available to a slave. - +### Merge back to no-TIP safe.test test safe-19.1 {Check that each directory of the default auto_path is a valid token} -setup { set i [safe::interpCreate] } -body { @@ -1962,12 +2028,11 @@ test safe-19.2 {Check that each directory of the module path is a valid token} - safe::interpDelete $i } -result {} +# cleanup set ::auto_path $SaveAutoPath unset SaveAutoPath TestsDir PathMapp rename mapList {} rename mapAndSortList {} - -# cleanup ::tcltest::cleanupTests return -- cgit v0.12 From 356b2f5829e52ff52c28cba8b5b6b5558a562c89 Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 22 Jul 2020 19:42:38 +0000 Subject: Move tests that depend on platform::shell from safe.test to safe-stock86.test, and replace with tests that use example packages. --- tests/safe-stock87.test | 65 +++++++++++++++++++++++++++++++++++----------- tests/safe-zipfs.test | 13 ++-------- tests/safe.test | 68 ++++++++++++++----------------------------------- 3 files changed, 71 insertions(+), 75 deletions(-) diff --git a/tests/safe-stock87.test b/tests/safe-stock87.test index a8f5bd2..1a29018 100644 --- a/tests/safe-stock87.test +++ b/tests/safe-stock87.test @@ -107,19 +107,15 @@ catch {safe::interpConfigure} # package - Tcltest - but it might be absent if we're in standard tclsh) testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}] - testConstraint AutoSyncDefined 1 # high level general test test safe-stock87-7.1 {tests that everything works at high level with conventional AutoPathSync, use pkg opt} -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 1 } - set i [safe::interpCreate] } -body { # no error shall occur: @@ -136,9 +132,7 @@ test safe-stock87-7.1 {tests that everything works at high level with convention } } -match glob -result 0.4.* test safe-stock87-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync, use pkg opt} -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 1 @@ -165,9 +159,7 @@ test safe-stock87-7.2 {tests specific path and interpFind/AddToAccessPath with c } -match glob -result "{\$p(:0:)} {\$p(:*:)} -- 1 {$pkgOptErrMsg} --\ {TCLLIB */dummy/unixlike/test/path} -- {}" test safe-stock87-7.4 {tests specific path and positive search with conventional AutoPathSync, use pkg opt} -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 1 @@ -194,6 +186,30 @@ test safe-stock87-7.4 {tests specific path and positive search with conventional } } -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 0.4.* --\ {TCLLIB * TCLLIB/OPTDIR} -- {}} +test safe-stock87-7.5 {tests positive and negative module loading with conventional AutoPathSync} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + set i [safe::interpCreate] + interp eval $i { + package forget platform::shell + package forget platform + catch {namespace delete ::platform} + } +} -body { + # Should raise an error (module ancestor directory issue) + set code1 [catch {interp eval $i {package require shell}} msg1] + # Should not raise an error + set code2 [catch {interp eval $i {package require platform::shell}} msg2] + return [list $code1 $msg1 $code2] +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {1 {can't find package shell} 0} # The following test checks whether the definition of tcl_endOfWord can be # obtained from auto_loading. It was previously test "safe-5.1". @@ -296,16 +312,13 @@ test safe-stock87-9.13 {interpConfigure change the access path; pkgIndex.tcl pac {TCLLIB TCLLIB/OPTDIR TCLLIB/JARDIR*} -- {TCLLIB*}} test safe-stock87-18.1 {cf. safe-stock87-7.1opt - tests that everything works at high level without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 0 } else { error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } - # Without AutoPathSync, we need a more complete auto_path, # because the slave will use the same value. set lib1 [info library] @@ -330,9 +343,7 @@ test safe-stock87-18.1 {cf. safe-stock87-7.1opt - tests that everything works at } } -match glob -result 0.4.* test safe-stock87-18.2 {cf. safe-stock87-7.2opt - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 0 @@ -361,9 +372,7 @@ test safe-stock87-18.2 {cf. safe-stock87-7.2opt - tests specific path and interp {-accessPath {[list $tcl_library */dummy/unixlike/test/path]}\ -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" test safe-stock87-18.4 {cf. safe-stock87-7.4opt - tests specific path and positive search and auto_path without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 0 @@ -399,6 +408,32 @@ test safe-stock87-18.4 {cf. safe-stock87-7.4opt - tests specific path and positi } -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 0.4.*\ {-accessPath {[list $tcl_library *$tcl_library/$pkgOptDir]}\ -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" +test safe-stock87-18.5 {cf. safe-stock87-7.5 - tests positive and negative module loading without conventional AutoPathSync} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set i [safe::interpCreate] + interp eval $i { + package forget platform::shell + package forget platform + catch {namespace delete ::platform} + } +} -body { + # Should raise an error (tests module ancestor directory rule) + set code1 [catch {interp eval $i {package require shell}} msg1] + # Should not raise an error + set code2 [catch {interp eval $i {package require platform::shell}} msg2] + return [list $code1 $msg1 $code2] +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {1 {can't find package shell} 0} set ::auto_path $SaveAutoPath unset pkgOptErrMsg pkgOptDir pkgJarDir SaveAutoPath TestsDir PathMapp diff --git a/tests/safe-zipfs.test b/tests/safe-zipfs.test index 4793bb2..4ec01d1 100644 --- a/tests/safe-zipfs.test +++ b/tests/safe-zipfs.test @@ -172,9 +172,8 @@ test safe-zipfs-5.6 {example modules packages, test in master interpreter, appen } -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} # high level general test -# Use zipped example packages not tcl8.x/opt +# Use zipped example packages not http1.0 etc test safe-zipfs-7.1 {tests that everything works at high level with conventional AutoPathSync; zipfs} -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -199,7 +198,6 @@ test safe-zipfs-7.1 {tests that everything works at high level with conventional } } -match glob -result 1.2.3 test safe-zipfs-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync; zipfs} -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -230,7 +228,6 @@ test safe-zipfs-7.2 {tests specific path and interpFind/AddToAccessPath with con 1 {can't find package SafeTestPackage1} --\ {TCLLIB */dummy/unixlike/test/path ZIPDIR/auto0} -- {}} test safe-zipfs-7.4 {tests specific path and positive search with conventional AutoPathSync; zipfs} -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -829,16 +826,13 @@ test safe-zipfs-9.24 {interpConfigure change the access path; check module loadi # See comments on lsort after test safe-zipfs-9.20. test safe-zipfs-18.1 {cf. safe-zipfs-7.1 - tests that everything works at high level without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 0 } else { error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } - # Without AutoPathSync, we need a more complete auto_path, # because the slave will use the same value. set lib1 [info library] @@ -863,9 +857,7 @@ test safe-zipfs-18.1 {cf. safe-zipfs-7.1 - tests that everything works at high l } } -match glob -result 1.2.3 test safe-zipfs-18.2 {cf. safe-zipfs-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 0 @@ -899,7 +891,6 @@ test safe-zipfs-18.2 {cf. safe-zipfs-7.2 - tests specific path and interpFind/Ad $ZipMountPoint/auto0]}\ -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" test safe-zipfs-18.4 {cf. safe-zipfs-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -943,12 +934,12 @@ test safe-zipfs-18.4 {cf. safe-zipfs-7.4 - tests specific path and positive sear -statics 0 -nested 1 -deleteHook {}\ -autoPath {[list $tcl_library $ZipMountPoint/auto0]}} {}" +# cleanup set ::auto_path $SaveAutoPath zipfs unmount ${ZipMountPoint} unset SaveAutoPath TestsDir ZipMountPoint PathMapp rename mapList {} rename mapAndSortList {} -# cleanup ::tcltest::cleanupTests return diff --git a/tests/safe.test b/tests/safe.test index ae4af7c..1b118a9 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -286,7 +286,6 @@ test safe-5.6 {example modules packages, test in master interpreter, append to p catch {namespace delete ::mod1} } -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} - # test safe interps 'information leak' proc SafeEval {script} { # Helper procedure that ensures the safe interp is cleaned up even if @@ -318,16 +317,13 @@ rename SafeEval {} # leaking infos, but they still do... # high level general test -# Use example packages not tcl8.x/opt +# Use example packages not http1.0 etc test safe-7.1 {tests that everything works at high level with conventional AutoPathSync} -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 1 } - set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0] set i [safe::interpCreate] @@ -347,9 +343,7 @@ test safe-7.1 {tests that everything works at high level with conventional AutoP } } -match glob -result 1.2.3 test safe-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync} -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 1 @@ -410,9 +404,7 @@ test safe-7.3.1 {check that safe subinterpreters work with namespace names} -set [interp exists $j] [info vars ::safe::S*] } -match glob -result {{} {} ok ok {} 0 {}} test safe-7.4 {tests specific path and positive search with conventional AutoPathSync} -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 1 @@ -440,33 +432,30 @@ test safe-7.4 {tests specific path and positive search with conventional AutoPat } -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\ {TCLLIB * TESTSDIR/auto0/auto1} -- {}} test safe-7.5 {tests positive and negative module loading with conventional AutoPathSync} -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 1 } - + tcl::tm::path add [file join $TestsDir auto0 modules] set i [safe::interpCreate] - + tcl::tm::path remove [file join $TestsDir auto0 modules] interp eval $i { - package forget platform::shell - package forget platform - catch {namespace delete ::platform} + package forget mod1::test1 + catch {namespace delete ::mod1} } } -body { # Should raise an error (module ancestor directory issue) - set code1 [catch {interp eval $i {package require shell}} msg1] + set code1 [catch {interp eval $i {package require test1}} msg1] # Should not raise an error - set code2 [catch {interp eval $i {package require platform::shell}} msg2] + set code2 [catch {interp eval $i {package require mod1::test1}} msg2] return [list $code1 $msg1 $code2] } -cleanup { safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -result {1 {can't find package shell} 0} +} -result {1 {can't find package test1} 0} # test source control on file name test safe-8.1 {safe source control on file} -setup { @@ -857,7 +846,6 @@ test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages un [file join $TestsDir auto0] \ [file join $TestsDir auto0 auto2] \ [file join $TestsDir auto0 auto1]] - # Inspect. set confB [safe::interpConfigure $i] set mappB [mapList $PathMapp [dict get $confB -accessPath]] @@ -1801,7 +1789,7 @@ test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup } -result {~USER} ### 17. The first element in a slave's ::auto_path and access path must be [info library]. - +### Merge back to no-TIP safe.test test safe-17.1 {Check that first element of slave auto_path (and access path) is Tcl Library} -setup { set lib1 [info library] set lib2 [file dirname $lib1] @@ -1841,18 +1829,14 @@ test safe-17.2 {Check that first element of slave auto_path (and access path) is } -result [list [info library] [info library]] ### 18. Tests for AutoSyncDefined without conventional AutoPathSync, i.e. with AutoPathSync off. - test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without conventional AutoPathSync} -constraints AutoSyncDefined -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 0 } else { error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } - # Without AutoPathSync, we need a more complete auto_path, # because the slave will use the same value. set lib1 [info library] @@ -1877,9 +1861,7 @@ test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without } } -match glob -result 1.2.3 test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync} -constraints AutoSyncDefined -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 0 @@ -1913,22 +1895,17 @@ test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPat $TestsDir/auto0]}\ -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" test safe-18.3 {Check that default auto_path is the same as in the master interpreter without conventional AutoPathSync} -constraints AutoSyncDefined -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 0 } else { error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } - set i [safe::interpCreate] - } -body { # This file's header sets auto_path to a single directory [info library], # which is the one required by Safe Base to be present & first in the list. - set ap {} foreach token [$i eval set ::auto_path] { lappend ap [dict get [set ::safe::S${i}(access_path,map)] $token] @@ -1941,9 +1918,7 @@ test safe-18.3 {Check that default auto_path is the same as in the master interp } } -result $::auto_path test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync} -constraints AutoSyncDefined -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 0 @@ -1986,40 +1961,35 @@ test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_ -statics 0 -nested 1 -deleteHook {}\ -autoPath {[list $tcl_library $TestsDir/auto0]}} {}" test safe-18.5 {cf. safe-7.5 - tests positive and negative module loading without conventional AutoPathSync} -setup { - # All ::safe commands are loaded at start of file. set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 0 } else { error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } - + tcl::tm::path add [file join $TestsDir auto0 modules] set i [safe::interpCreate] - + tcl::tm::path remove [file join $TestsDir auto0 modules] interp eval $i { - package forget platform::shell - package forget platform - catch {namespace delete ::platform} + package forget mod1::test1 + catch {namespace delete ::mod1} } } -body { # Should raise an error (tests module ancestor directory rule) - set code1 [catch {interp eval $i {package require shell}} msg1] + set code1 [catch {interp eval $i {package require test1}} msg1] # Should not raise an error - set code2 [catch {interp eval $i {package require platform::shell}} msg2] + set code2 [catch {interp eval $i {package require mod1::test1}} msg2] return [list $code1 $msg1 $code2] } -cleanup { safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -result {1 {can't find package shell} 0} - - +} -result {1 {can't find package test1} 0} ### 19. Test tokenization of directories available to a slave. - +### Merge back to no-TIP safe.test test safe-19.1 {Check that each directory of the default auto_path is a valid token} -setup { set i [safe::interpCreate] } -body { @@ -2053,12 +2023,12 @@ test safe-19.2 {Check that each directory of the module path is a valid token} - } -cleanup { safe::interpDelete $i } -result {} - + +# cleanup set ::auto_path $SaveAutoPath unset SaveAutoPath TestsDir PathMapp rename mapList {} rename mapAndSortList {} -# cleanup ::tcltest::cleanupTests return -- cgit v0.12 From a18c844695bc12871386e04a67dfd913be5d0c76 Mon Sep 17 00:00:00 2001 From: kjnash Date: Thu, 23 Jul 2020 10:12:25 +0000 Subject: Add tests for cases that might differ when ::auto_path is not synchronized. Renumber some tests not yet added to core, but do not yet reorder them. Change some test descriptions. --- tests/safe.test | 1007 +++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 938 insertions(+), 69 deletions(-) diff --git a/tests/safe.test b/tests/safe.test index 5987ce8..0c5bd37 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -62,12 +62,26 @@ catch {safe::interpConfigure} testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}] testConstraint AutoSyncDefined 1 +### 1. Basic help/error messages. + test safe-1.1 {safe::interpConfigure syntax} -returnCodes error -body { safe::interpConfigure } -result {no value given for parameter "slave" (use -help for full usage) : slave name () name of the slave} -test safe-1.2 {safe::interpCreate syntax} -returnCodes error -body { +test safe-1.2 {safe::interpCreate syntax, Sync Mode on} -returnCodes error -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } else { + set SyncVal_TMP 1 + } +} -body { safe::interpCreate -help +} -cleanup { + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } } -result {Usage information: Var/FlagName Type Value Help ------------ ---- ----- ---- @@ -79,11 +93,39 @@ test safe-1.2 {safe::interpCreate syntax} -returnCodes error -body { -nestedLoadOk boolflag (false) allow nested loading -nested boolean (false) nested loading -deleteHook script () delete hook} +test safe-1.2.1 {safe::interpCreate syntax, Sync Mode off} -returnCodes error -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + safe::interpCreate -help +} -cleanup { + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {Usage information: + Var/FlagName Type Value Help + ------------ ---- ----- ---- + (-help gives this help) + ?slave? name () name of the slave (optional) + -accessPath list () access path for the slave + -noStatics boolflag (false) prevent loading of statically linked pkgs + -statics boolean (true) loading of statically linked pkgs + -nestedLoadOk boolflag (false) allow nested loading + -nested boolean (false) nested loading + -deleteHook script () delete hook + -autoPath list () ::auto_path for the slave} test safe-1.3 {safe::interpInit syntax} -returnCodes error -body { safe::interpInit -noStatics } -result {bad value "-noStatics" for parameter slave name () name of the slave} +### 2. Aliases in a new "interp create" interpreter. + test safe-2.1 {creating interpreters, should have no aliases} emptyTest { # Disabled this test. It tests nothing sensible. [Bug 999612] # interp aliases @@ -107,6 +149,9 @@ test safe-2.3 {creating safe interpreters, should have no unexpected aliases} -s interp delete a } -result {::tcl::mathfunc::max ::tcl::mathfunc::min clock} +### 3. Simple use of interpCreate, interpInit. +### Aliases in a new "interpCreate/interpInit" interpreter. + test safe-3.1 {calling safe::interpInit is safe} -setup { catch {safe::interpDelete a} interp create a -safe @@ -141,6 +186,8 @@ test safe-3.4 {calling safe::interpCreate on trusted interp} -setup { safe::interpDelete a } -result {} +### 4. Testing safe::interpDelete, double interpCreate. + test safe-4.1 {safe::interpDelete} -setup { catch {safe::interpDelete a} } -body { @@ -173,9 +220,9 @@ test safe-4.6 {safe::interpDelete, indirectly} -setup { a eval exit } -result "" -# The old test "safe-5.1" has been moved to "safe-stock86-9.8". -# A replacement test using example files is "safe-9.8". -# Tests 5.* test the example files before using them to test safe interpreters. +### 5. Test the example files before using them to test safe interpreters. +### The old test "safe-5.1" has been moved to "safe-stock86-9.8". +### A replacement test using example files is "safe-9.8". test safe-5.1 {example tclIndex commands, test in master interpreter} -setup { set tmpAutoPath $::auto_path @@ -286,7 +333,8 @@ test safe-5.6 {example modules packages, test in master interpreter, append to p catch {namespace delete ::mod1} } -match glob -result {0 0.5 0 1.0 0 2.0 -- res0 res1 res2} -# test safe interps 'information leak' +### 6. Test safe interps 'information leak'. + proc SafeEval {script} { # Helper procedure that ensures the safe interp is cleaned up even if # there is a failure in the script. @@ -316,9 +364,11 @@ rename SafeEval {} # More test should be added to check that hostname, nameofexecutable, aren't # leaking infos, but they still do... -# high level general test -# Use example packages not http1.0 etc -test safe-7.1 {tests that everything works at high level with conventional AutoPathSync} -setup { +### 7. Test the use of ::auto_path for loading commands (via tclIndex files) +### and non-module packages (via pkgIndex.tcl files). +### Corresponding tests with Sync Mode off are 17.* + +test safe-7.1 {positive non-module package require, Sync Mode on} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -342,7 +392,7 @@ test safe-7.1 {tests that everything works at high level with conventional AutoP safe::setAutoPathSync $SyncVal_TMP } } -match glob -result 1.2.3 -test safe-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync} -setup { +test safe-7.2 {negative non-module package require with specific path and interpAddToAccessPath, Sync Mode on} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -360,8 +410,7 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath with conventio set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]] set confA [safe::interpConfigure $i] set mappA [mapList $PathMapp [dict get $confA -accessPath]] - # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level - # provided deep path) + # an error shall occur (SafeTestPackage1 is not in auto0 but a subdirectory) list $token1 $token2 $token3 -- \ [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg -- \ $mappA -- [safe::interpDelete $i] @@ -403,7 +452,7 @@ test safe-7.3.1 {check that safe subinterpreters work with namespace names} -set [safe::interpDelete $i] \ [interp exists $j] [info vars ::safe::S*] } -match glob -result {{} {} ok ok {} 0 {}} -test safe-7.4 {tests specific path and positive search with conventional AutoPathSync} -setup { +test safe-7.4 {positive non-module package require with specific path and interpAddToAccessPath, Sync Mode on} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -431,7 +480,7 @@ test safe-7.4 {tests specific path and positive search with conventional AutoPat } } -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\ {TCLLIB * TESTSDIR/auto0/auto1} -- {}} -test safe-7.5 {tests positive and negative module loading with conventional AutoPathSync} -setup { +test safe-7.5 {positive and negative module package require, including ancestor directory issue, Sync Mode on} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -457,7 +506,8 @@ test safe-7.5 {tests positive and negative module loading with conventional Auto } } -result {1 {can't find package test1} 0} -# test source control on file name +### 8. Test source control on file name. + test safe-8.1 {safe source control on file} -setup { set i "a" catch {safe::interpDelete $i} @@ -602,6 +652,9 @@ test safe-8.10 {safe source and return} -setup { unset i } -result ok +### 9. Assorted options, including changes to option values. +### If Sync Mode is on, a corresponding test with Sync Mode off is 19.* + test safe-9.1 {safe interps' deleteHook} -setup { set i "a" catch {safe::interpDelete $i} @@ -704,7 +757,12 @@ test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\ {-accessPath * -statics 0 -nested 0 -deleteHook toto}} -test safe-9.8 {test autoloading commands indexed in tclIndex files} -setup { +test safe-9.8 {autoloading commands indexed in tclIndex files, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ [file join $TestsDir auto0 auto1] \ @@ -722,9 +780,12 @@ test safe-9.8 {test autoloading commands indexed in tclIndex files} -setup { list $path1 $path2 -- $code1 $msg1 $code2 $msg2 -- $mappA } -cleanup { safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } } -match glob -result {{$p(:1:)} {$p(:2:)} -- 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*}} -test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset), with conventional AutoPathSync} -setup { +test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset), Sync Mode on} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -771,7 +832,7 @@ test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffec } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} -test safe-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset), with conventional AutoPathSync} -setup { +test safe-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset), Sync Mode on} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -817,7 +878,7 @@ test safe-9.10 {interpConfigure change the access path; tclIndex commands unaffe 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} -test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, with conventional AutoPathSync} -setup { +test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, Sync Mode on} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -869,7 +930,7 @@ test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages un {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ 0 OK1 0 OK2} -test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0, with conventional AutoPathSync} -setup { +test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, safe-9.11 without path auto0, Sync Mode on} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -917,7 +978,7 @@ test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages un {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ 0 OK1 0 OK2} -test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, with conventional AutoPathSync} -setup { +test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, Sync Mode on} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -959,7 +1020,7 @@ test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fa } -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\ 1 {* not found in access path} -- 1 1 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} -- {TCLLIB*}} -test safe-9.20 {check module loading, with conventional AutoPathSync} -setup { +test safe-9.20 {check module loading, Sync Mode on} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -1013,7 +1074,7 @@ test safe-9.20 {check module loading, with conventional AutoPathSync} -setup { # directories in the access path. Both those things must be sorted before # comparing with expected results. The test is therefore not totally strict, # but will notice missing or surplus directories. -test safe-9.21 {interpConfigure change the access path; check module loading, with conventional AutoPathSync; stale data case 1} -setup { +test safe-9.21 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 1} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -1083,7 +1144,7 @@ test safe-9.21 {interpConfigure change the access path; check module loading, wi TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ res0 res1 res2} # See comments on lsort after test safe-9.20. -test safe-9.22 {interpConfigure change the access path; check module loading, with conventional AutoPathSync; stale data case 0} -setup { +test safe-9.22 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 0} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -1148,7 +1209,7 @@ test safe-9.22 {interpConfigure change the access path; check module loading, wi TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ res0 res1 res2} # See comments on lsort after test safe-9.20. -test safe-9.23 {interpConfigure change the access path; check module loading, with conventional AutoPathSync; stale data case 3} -setup { +test safe-9.23 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 3} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -1223,7 +1284,7 @@ test safe-9.23 {interpConfigure change the access path; check module loading, wi TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ res0 res1 res2} # See comments on lsort after test safe-9.20. -test safe-9.24 {interpConfigure change the access path; check module loading, with conventional AutoPathSync; stale data case 2 (worst case)} -setup { +test safe-9.24 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 2 (worst case)} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -1294,6 +1355,8 @@ test safe-9.24 {interpConfigure change the access path; check module loading, wi res0 res1 res2} # See comments on lsort after test safe-9.20. +### 10. Test options -statics -nostatics -nested -nestedloadok + catch {teststaticpkg Safepkg1 0 0} test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { set i [safe::interpCreate] @@ -1347,6 +1410,8 @@ test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints T invoked from within "interp eval $i {interp create x; load {} Safepkg1 x}"} +### 11. Safe encoding. + test safe-11.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1445,6 +1510,9 @@ test safe-11.8.1 {testing safe encoding} -setup { invoked from within "interp eval $i encoding convertto"} +### 12. Safe glob. +### More tests of glob in sections 13, 16. + test safe-12.1 {glob is restricted [Bug 2906841]} -setup { set i [safe::interpCreate] } -body { @@ -1495,6 +1563,9 @@ test safe-12.7 {glob is restricted} -setup { safe::interpDelete $i } -result {permission denied} +### 13. More tests for Safe base glob, with patches @ Bug 2964715 +### More tests of glob in sections 12, 16. + proc buildEnvironment {filename} { upvar 1 testdir testdir testdir2 testdir2 testfile testfile set testdir [makeDirectory deletethisdir] @@ -1510,7 +1581,7 @@ proc buildEnvironment2 {filename} { set testdir3 [makeDirectory deleteme $testdir] set testfile2 [makeFile {} $filename $testdir3] } -#### New tests for Safe base glob, with patches @ Bug 2964715 + test safe-13.1 {glob is restricted [Bug 2964715]} -setup { set i [safe::interpCreate] } -body { @@ -1647,7 +1718,8 @@ test safe-13.10 {as 13.8 but test silent failure when result is outside access_p rename buildEnvironment {} rename buildEnvironment2 {} -#### Test for the module path +### 14. Sanity checks on paths - module path, access path, auto_path. + test safe-14.1 {Check that module path is the same as in the master interpreter [Bug 2964715]} -setup { set i [safe::interpCreate] } -body { @@ -1660,6 +1732,8 @@ test safe-14.1 {Check that module path is the same as in the master interpreter safe::interpDelete $i } -result [::tcl::tm::path list] +### 15. Safe file ensemble. + test safe-15.1 {safe file ensemble does not surprise code} -setup { set i [interp create -safe] } -body { @@ -1697,7 +1771,10 @@ test safe-15.2 {safe file ensemble does not surprise code} -setup { invoked from within "interp eval $i {file isdirectory .}"}} -### ~ should have no special meaning in paths in safe interpreters +### 16. ~ should have no special meaning in paths in safe interpreters. +### Defang it in glob. +### More tests of glob in sections 12, 13. + test safe-16.1 {Bug 3529949: defang ~ in paths} -setup { set savedHOME $env(HOME) set env(HOME) /foo/bar @@ -1792,9 +1869,43 @@ test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup unset user } -result {~USER} -### 17. The first element in a slave's ::auto_path and access path must be [info library]. -### Merge back to no-TIP safe.test -test safe-17.1 {Check that first element of slave auto_path (and access path) is Tcl Library} -setup { +### 14.x move above. + +test safe-14.2 {Check that first element of slave auto_path (and access path) is Tcl Library, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib1 $lib2] + + set i [safe::interpCreate] +} -body { + set autoList {} + set token [lindex [$i eval set ::auto_path] 0] + set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] + set accessList [lindex [safe::interpConfigure $i -accessPath] 1] + return [list [lindex $accessList 0] $auto0] +} -cleanup { + set ::auto_path $::auto_TMP + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result [list [info library] [info library]] +test safe-14.2.1 {Check that first element of slave auto_path (and access path) is Tcl Library, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set lib1 [info library] set lib2 [file dirname $lib1] set ::auto_TMP $::auto_path @@ -1810,9 +1921,47 @@ test safe-17.1 {Check that first element of slave auto_path (and access path) is } -cleanup { set ::auto_path $::auto_TMP safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result [list [info library] [info library]] +test safe-14.3 {Check that first element of slave auto_path (and access path) is Tcl Library, even if not true for master, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib2 $lib1] + # Unexpected order, should be reversed in the slave + + set i [safe::interpCreate] +} -body { + set autoList {} + set token [lindex [$i eval set ::auto_path] 0] + set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] + set accessList [lindex [safe::interpConfigure $i -accessPath] 1] + + return [list [lindex $accessList 0] $auto0] +} -cleanup { + set ::auto_path $::auto_TMP + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } } -result [list [info library] [info library]] +test safe-14.3.1 {Check that first element of slave auto_path (and access path) is Tcl Library, even if not true for master, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } -test safe-17.2 {Check that first element of slave auto_path (and access path) is Tcl Library, even if not true for master} -setup { set lib1 [info library] set lib2 [file dirname $lib1] set ::auto_TMP $::auto_path @@ -1830,10 +1979,16 @@ test safe-17.2 {Check that first element of slave auto_path (and access path) is } -cleanup { set ::auto_path $::auto_TMP safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } } -result [list [info library] [info library]] -### 18. Tests for AutoSyncDefined without conventional AutoPathSync, i.e. with AutoPathSync off. -test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without conventional AutoPathSync} -constraints AutoSyncDefined -setup { +### 17. Test the use of ::auto_path for loading commands (via tclIndex files) +### and non-module packages (via pkgIndex.tcl files). +### Corresponding tests with Sync Mode on are 7.* + +test safe-17.1 {cf. safe-7.1 - positive non-module package require, Sync Mode off} -constraints AutoSyncDefined -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -1864,7 +2019,7 @@ test safe-18.1 {cf. safe-7.1 - tests that everything works at high level without safe::setAutoPathSync $SyncVal_TMP } } -match glob -result 1.2.3 -test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync} -constraints AutoSyncDefined -setup { +test safe-17.2 {cf. safe-7.2 - negative non-module package require with specific path and interpAddToAccessPath, Sync Mode off} -constraints AutoSyncDefined -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -1882,8 +2037,7 @@ test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPat set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] # should add as p* (not p2 if master has a module path) set token3 [safe::interpAddToAccessPath $i [file join $TestsDir auto0]] - # an error shall occur (SafeTestPackage1 is not anymore in the secure 0-level - # provided deep path) + # an error shall occur (SafeTestPackage1 is not in auto0 but a subdirectory) list $auto1 $token1 $token2 $token3 \ [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ [safe::interpConfigure $i]\ @@ -1898,7 +2052,8 @@ test safe-18.2 {cf. safe-7.2 - tests specific path and interpFind/AddToAccessPat */dummy/unixlike/test/path \ $TestsDir/auto0]}\ -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" -test safe-18.3 {Check that default auto_path is the same as in the master interpreter without conventional AutoPathSync} -constraints AutoSyncDefined -setup { +# (not a counterpart of safe-7.3) +test safe-17.3 {Check that default auto_path is the same as in the master interpreter, Sync Mode off} -constraints AutoSyncDefined -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -1921,7 +2076,7 @@ test safe-18.3 {Check that default auto_path is the same as in the master interp safe::setAutoPathSync $SyncVal_TMP } } -result $::auto_path -test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync} -constraints AutoSyncDefined -setup { +test safe-17.4 {cf. safe-7.4 - positive non-module package require with specific path and interpAddToAccessPath, Sync Mode off} -constraints AutoSyncDefined -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -1951,7 +2106,7 @@ test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_ set auto3 [interp eval $i [list set ::auto_path [list {$p(:0:)} $token2]]] - # This time, unlike test safe-18.2 and the try above, SafeTestPackage1 should be found: + # This time, unlike test safe-17.2 and the try above, SafeTestPackage1 should be found: list $auto1 $auto2 $token1 $token2 $token3 \ [catch {interp eval $i {package require SafeTestPackage1}} msg] $msg \ [safe::interpConfigure $i]\ @@ -1964,7 +2119,7 @@ test safe-18.4 {cf. safe-7.4 - tests specific path and positive search and auto_ {-accessPath {[list $tcl_library *$TestsDir/auto0 $TestsDir/auto0/auto1]}\ -statics 0 -nested 1 -deleteHook {}\ -autoPath {[list $tcl_library $TestsDir/auto0]}} {}" -test safe-18.5 {cf. safe-7.5 - tests positive and negative module loading without conventional AutoPathSync} -setup { +test safe-17.5 {cf. safe-7.5 - positive and negative module package require, including ancestor directory issue, Sync Mode off} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -1992,40 +2147,754 @@ test safe-18.5 {cf. safe-7.5 - tests positive and negative module loading withou } } -result {1 {can't find package test1} 0} -### 19. Test tokenization of directories available to a slave. -### Merge back to no-TIP safe.test -test safe-19.1 {Check that each directory of the default auto_path is a valid token} -setup { - set i [safe::interpCreate] -} -body { - set badTokens {} - foreach dir [$i eval {set ::auto_path}] { - if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { - # Match - OK - token has expected form - } else { - # No match - possibly an ordinary path has not been tokenized - lappend badTokens $dir - } +### 19. Assorted options, including changes to option values. +### Mostly these are changes to access path, auto_path, module path. +### If Sync Mode is on, a corresponding test with Sync Mode off is 9.* + +test safe-19.8 {autoloading commands indexed in tclIndex files, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } - set badTokens +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] \ + -autoPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load and run the commands. + set code1 [catch {interp eval $i {report1}} msg1] + set code2 [catch {interp eval $i {report2}} msg2] + + list $path1 $path2 -- $code1 $msg1 $code2 $msg2 -- $mappA } -cleanup { safe::interpDelete $i -} -result {} - -test safe-19.2 {Check that each directory of the module path is a valid token} -setup { - set i [safe::interpCreate] -} -body { - set badTokens {} - foreach dir [$i eval {::tcl::tm::path list}] { - if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { - # Match - OK - token has expected form - } else { - # No match - possibly an ordinary path has not been tokenized - lappend badTokens $dir - } + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP } - set badTokens +} -match glob -result {{$p(:1:)} {$p(:2:)} -- 0 ok1 0 ok2 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*}} +test safe-19.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset), Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] \ + -autoPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Load and run the commands. + # This guarantees the test will pass even if the tokens are swapped. + set code1 [catch {interp eval $i {report1}} msg1] + set code2 [catch {interp eval $i {report2}} msg2] + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] \ + -autoPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB } -cleanup { safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} +test safe-19.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset), Sync Mode off} -constraints {AutoSyncDefined} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] \ + -autoPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load auto_load data. + interp eval $i {catch nonExistentCommand} + + # Do not load the commands. With the tokens swapped, the test + # will pass only if the Safe Base has called auto_reset. + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:2:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] \ + -autoPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load and run the commands. + set code3 [catch {interp eval $i {report1}} msg3] + set code4 [catch {interp eval $i {report2}} msg4] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ + 0 ok1 0 ok2 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} +test safe-19.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + # For complete correspondence to safe-stock87-9.11, include auto0 in access path. + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] \ + -autoPath [list $tcl_library \ + [file join $TestsDir auto0]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}. + # This would have no effect because the records in Pkg of these directories + # were from access as children of {$p(:1:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] \ + -autoPath [list $tcl_library \ + [file join $TestsDir auto0]]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\ + {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ + 0 OK1 0 OK2} +test safe-19.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, safe-19.11 without path auto0, Sync Mode off} -constraints {AutoSyncDefined} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + # To manage without path auto0, use an auto_path that is unusual for + # package discovery. + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] \ + -autoPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:2:)} and {$p(:3:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] \ + -autoPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- \ + $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ + 0 1.2.3 0 2.3.4 --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ + 0 OK1 0 OK2} +test safe-19.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, Sync Mode off} -constraints {AutoSyncDefined} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + # Path auto0 added (cf. safe-9.3) because it is needed for auto_path. + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] \ + -autoPath [list $tcl_library \ + [file join $TestsDir auto0]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Limit access path. Remove tokens {$p(:2:)} and {$p(:3:)}. + safe::interpConfigure $i -accessPath [list $tcl_library] + + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set code4 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]} path4] + set code5 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]} path5] + + # Try to load the packages. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] + set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6] + + list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \ + $mappA -- $mappB +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result {{$p(:2:)} {$p(:3:)} -- 1 {* not found in access path} --\ + 1 {* not found in access path} -- 1 1 --\ + {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} -- {TCLLIB*}} +test safe-19.20 {check module loading, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} -- res0 res1 res2} +# See comments on lsort after test safe-9.20. +test safe-19.21 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 1} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Load pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. +test safe-19.22 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 0} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. +test safe-19.23 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 3} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Refresh stale pkg data. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. +test safe-19.24 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 2 (worst case)} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set oldTm [tcl::tm::path list] + foreach path $oldTm { + tcl::tm::path remove $path + } + tcl::tm::path add [file join $TestsDir auto0 modules] +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library]] + + # Inspect. + set confA [safe::interpConfigure $i] + set sortA [mapAndSortList $PathMapp [dict get $confA -accessPath]] + set modsA [interp eval $i {tcl::tm::path list}] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Force the interpreter to acquire pkg data which will soon become stale. + catch {interp eval $i {package require NOEXIST}} + catch {interp eval $i {package require mod1::NOEXIST}} + catch {interp eval $i {package require mod2::NOEXIST}} + + # Add to access path. + # This injects more tokens, pushing modules to higher token numbers. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set sortB [mapAndSortList $PathMapp [dict get $confB -accessPath]] + set modsB [interp eval $i {tcl::tm::path list}] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod1]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 modules mod2]] + + # Try to load the packages and run a command from each one. + set code0 [catch {interp eval $i {package require test0}} msg0] + set code1 [catch {interp eval $i {package require mod1::test1}} msg1] + set code2 [catch {interp eval $i {package require mod2::test2}} msg2] + set out0 [interp eval $i {test0::try0}] + set out1 [interp eval $i {mod1::test1::try1}] + set out2 [interp eval $i {mod2::test2::try2}] + + list [lsort [list $path0 $path1 $path2]] -- $modsA -- \ + [lsort [list $path3 $path4 $path5]] -- $modsB -- \ + $code0 $msg0 $code1 $msg1 $code2 $msg2 -- $sortA -- $sortB -- \ + $out0 $out1 $out2 +} -cleanup { + tcl::tm::path remove [file join $TestsDir auto0 modules] + foreach path [lreverse $oldTm] { + tcl::tm::path add $path + } + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ + {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ + 0 0.5 0 1.0 0 2.0 --\ + {TCLLIB TESTSDIR/auto0/modules TESTSDIR/auto0/modules/mod1\ + TESTSDIR/auto0/modules/mod2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2 TESTSDIR/auto0/modules\ + TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ + res0 res1 res2} +# See comments on lsort after test safe-9.20. + +### 18. Test tokenization of directories available to a slave. + +test safe-18.1 {Check that each directory of the default auto_path is a valid token, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + set i [safe::interpCreate] +} -body { + set badTokens {} + foreach dir [$i eval {set ::auto_path}] { + if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { + # Match - OK - token has expected form + } else { + # No match - possibly an ordinary path has not been tokenized + lappend badTokens $dir + } + } + set badTokens +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {} +test safe-18.1.1 {Check that each directory of the default auto_path is a valid token, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set i [safe::interpCreate] +} -body { + set badTokens {} + foreach dir [$i eval {set ::auto_path}] { + if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { + # Match - OK - token has expected form + } else { + # No match - possibly an ordinary path has not been tokenized + lappend badTokens $dir + } + } + set badTokens +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {} +test safe-18.2 {Check that each directory of the module path is a valid token, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + set i [safe::interpCreate] +} -body { + set badTokens {} + foreach dir [$i eval {::tcl::tm::path list}] { + if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { + # Match - OK - token has expected form + } else { + # No match - possibly an ordinary path has not been tokenized + lappend badTokens $dir + } + } + set badTokens +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {} +test safe-18.2.1 {Check that each directory of the module path is a valid token, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set i [safe::interpCreate] +} -body { + set badTokens {} + foreach dir [$i eval {::tcl::tm::path list}] { + if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { + # Match - OK - token has expected form + } else { + # No match - possibly an ordinary path has not been tokenized + lappend badTokens $dir + } + } + set badTokens +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } } -result {} # cleanup -- cgit v0.12 From 50e33715bae0885fa0a16f51f1880352e8490a09 Mon Sep 17 00:00:00 2001 From: kjnash Date: Thu, 23 Jul 2020 19:04:07 +0000 Subject: For each slave, record a value of -autoPath instead of discarding it and relying on the value of ::auto_path in the slave. Clarify the distinction between the two, both in library/safe.tcl and in doc/safe.n. Amend four tests to expect the correct value. Add code to tests to examine both values where appropriate. Add three more tests for cases in which the distinction is important. Renumber and re-title tests in safe-stock86.test to correspond to those in safe.test, and add code to safe-stock86.test to set the Sync Mode. --- doc/safe.n | 10 +- library/safe.tcl | 24 +++-- tests/safe-stock86.test | 84 +++++++++++---- tests/safe.test | 265 ++++++++++++++++++++++++++++++++++++++++++++---- 4 files changed, 331 insertions(+), 52 deletions(-) diff --git a/doc/safe.n b/doc/safe.n index 5777f74..8aa8686 100644 --- a/doc/safe.n +++ b/doc/safe.n @@ -401,14 +401,18 @@ to call \fB::safe::interpCreate\fR or \fB::safe::interpInit\fR without the option set to the empty list), which will give the safe interpreter the same access as the master interpreter to packages, modules, and autoloader files. With -"Sync Mode" off, the ::auto_path will be set to a tokenized form of the master's -::auto_path. +"Sync Mode" off, the Safe Base will set the value of \fB\-autoPath\fR to the +master's ::auto_path, and will set the slave's ::auto_path to a tokenized form +of the master's ::auto_path. .PP With "Sync Mode" off, if a value is specified for \fB\-autoPath\fR, even the empty list, in a call to \fB::safe::interpCreate\fR, \fB::safe::interpInit\fR, or \fB::safe::interpConfigure\fR, it will be tokenized and used as the safe interpreter's ::auto_path. Any directories that do not also belong to the -access path cannot be tokenized and will be silently ignored. +access path cannot be tokenized and will be silently ignored. However, the +value of \fB\-autoPath\fR will remain as specified, and will be used to +re-tokenize the slave's ::auto_path if \fB::safe::interpConfigure\fR is called +to change the value of \fB\-accessPath\fR. .PP With "Sync Mode" off, if the access path is reset to the values in the master interpreter by calling \fB::safe::interpConfigure\fR with arguments diff --git a/library/safe.tcl b/library/safe.tcl index 88f59fc..5a5ddb5 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -147,8 +147,7 @@ proc ::safe::interpConfigure {args} { [list -deleteHook $state(cleanupHook)] \ ] if {!$AutoPathSync} { - set SLAP [DetokPath $slave [$slave eval set ::auto_path]] - lappend TMP [list -autoPath $SLAP] + lappend TMP [list -autoPath $state(auto_path)] } return [join $TMP] } @@ -179,8 +178,7 @@ proc ::safe::interpConfigure {args} { if {$AutoPathSync} { return -code error "unknown flag $name (bug)" } else { - set SLAP [DetokPath $slave [$slave eval set ::auto_path]] - return [list -autoPath $SLAP] + return [list -autoPath $state(auto_path)] } } -statics { @@ -227,8 +225,7 @@ proc ::safe::interpConfigure {args} { set doreset 1 } if {(!$AutoPathSync) && (![::tcl::OptProcArgGiven -autoPath])} { - set SLAP [DetokPath $slave [$slave eval set ::auto_path]] - set autoPath $SLAP + set autoPath $state(auto_path) } elseif {$AutoPathSync} { set autoPath {} } else { @@ -487,6 +484,10 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook au set state(nestedok) $nestedok set state(cleanupHook) $deletehook + if {!$AutoPathSync} { + set state(auto_path) $raw_auto_path + } + SyncAccessPath $slave return } @@ -1441,13 +1442,20 @@ namespace eval ::safe { # access_path,slave : Ditto, as the path tokens as seen by the slave. # access_path,map : dict ( token -> path ) # access_path,remap : dict ( path -> token ) + # auto_path : List of paths requested by the caller as slave's ::auto_path. # tm_path_slave : List of TM root directories, as tokens seen by the slave. # staticsok : Value of option -statics # nestedok : Value of option -nested # cleanupHook : Value of option -deleteHook # - # Because the slave can change its value of ::auto_path, the value of - # option -autoPath is not stored in the array but must be obtained from + # In principle, the slave can change its value of ::auto_path - + # - a package might add a path (that is already in the access path) for + # access to tclIndex files; + # - the script might remove some elements of the auto_path. + # However, this is really the business of the master, and the auto_path will + # be reset whenever the token mapping changes (i.e. when option -accessPath is + # used to change the access path). + # -autoPath is now stored in the array and is no longer obtained from # the slave. } diff --git a/tests/safe-stock86.test b/tests/safe-stock86.test index a3f6bb5..e13d37e 100644 --- a/tests/safe-stock86.test +++ b/tests/safe-stock86.test @@ -52,8 +52,17 @@ catch {safe::interpConfigure} testConstraint TcltestPackage [expr {![catch {package require Tcltest}]}] testConstraint AutoSyncDefined 1 -# high level general test -test safe-stock86-7.1 {tests that everything works at high level, uses http 2} -body { +### 7. Test the use of ::auto_path for loading commands (via tclIndex files) +### and non-module packages (via pkgIndex.tcl files). +### Corresponding tests with Sync Mode off are 17.* + +test safe-stock86-7.1 {positive non-module package require, uses http 2, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } +} -body { set i [safe::interpCreate] # no error shall occur: # (because the default access_path shall include 1st level sub dirs so @@ -63,8 +72,19 @@ test safe-stock86-7.1 {tests that everything works at high level, uses http 2} - interp eval $i {http::config} safe::interpDelete $i set v +} -cleanup { + catch {safe::interpDelete $i} + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } } -match glob -result 2.* -test safe-stock86-7.2 {tests specific path and interpFind/AddToAccessPath, uses http1.0} -body { +test safe-stock86-7.2 {negative non-module package require with specific path and interpAddToAccessPath, uses http1.0, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } +} -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] @@ -77,9 +97,20 @@ test safe-stock86-7.2 {tests specific path and interpFind/AddToAccessPath, uses list $token1 $token2 -- \ [catch {interp eval $i {package require http 1}} msg] $msg -- \ $mappA -- [safe::interpDelete $i] +} -cleanup { + catch {safe::interpDelete $i} + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } } -match glob -result {{$p(:0:)} {$p(:*:)} -- 1 {can't find package http 1} --\ {TCLLIB */dummy/unixlike/test/path} -- {}} -test safe-stock86-7.4 {tests specific path and positive search, uses http1.0} -body { +test safe-stock86-7.4 {positive non-module package require with specific path and interpAddToAccessPath, uses http1.0, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } +} -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] @@ -91,8 +122,13 @@ test safe-stock86-7.4 {tests specific path and positive search, uses http1.0} -b list $token1 $token2 -- \ [catch {interp eval $i {package require http 1}} msg] $msg -- \ $mappA -- [safe::interpDelete $i] +} -cleanup { + catch {safe::interpDelete $i} + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } } -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.0 -- {TCLLIB *TCLLIB/http1.0} -- {}} -test safe-stock86-7.5 {tests positive and negative module loading with conventional AutoPathSync} -setup { +test safe-stock86-7.5 {positive and negative module package require, including ancestor directory issue, uses platform::shell, Sync Mode on} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -120,27 +156,35 @@ test safe-stock86-7.5 {tests positive and negative module loading with conventio # The following test checks whether the definition of tcl_endOfWord can be # obtained from auto_loading. It was previously test "safe-5.1". -test safe-stock86-9.8 {test auto-loading in safe interpreters, was test 5.1} -setup { +test safe-stock86-9.8 {autoloading commands indexed in tclIndex files, was test 5.1, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } catch {safe::interpDelete a} safe::interpCreate a } -body { interp eval a {tcl_endOfWord "" 0} } -cleanup { safe::interpDelete a + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } } -result -1 -### 18. Tests for AutoSyncDefined without conventional AutoPathSync, i.e. with AutoPathSync off. -test safe-stock86-18.1 {cf. safe-stock86-7.1 - tests that everything works at high level without conventional AutoPathSync} -constraints AutoSyncDefined -setup { - # All ::safe commands are loaded at start of file. - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] +### 17. Test the use of ::auto_path for loading commands (via tclIndex files) +### and non-module packages (via pkgIndex.tcl files). +### Corresponding tests with Sync Mode on are 7.* +test safe-stock86-17.1 {cf. safe-7.1 - positive non-module package require, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 0 } else { error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } - # Without AutoPathSync, we need a more complete auto_path, # because the slave will use the same value. set lib1 [info library] @@ -164,10 +208,8 @@ test safe-stock86-18.1 {cf. safe-stock86-7.1 - tests that everything works at hi safe::setAutoPathSync $SyncVal_TMP } } -result 1.0 -test safe-stock86-18.2 {cf. safe-stock86-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync} -constraints AutoSyncDefined -setup { - # All ::safe commands are loaded at start of file. +test safe-stock86-17.2 {cf. safe-7.2 - negative non-module package require with specific path and interpAddToAccessPath, Sync Mode off} -constraints AutoSyncDefined -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 0 @@ -189,14 +231,13 @@ test safe-stock86-18.2 {cf. safe-stock86-7.2 - tests specific path and interpFin [safe::interpConfigure $i]\ [safe::interpDelete $i] } -cleanup { + catch {safe::interpDelete $i} if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" -test safe-stock86-18.4 {cf. safe-stock86-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync} -constraints AutoSyncDefined -setup { - # All ::safe commands are loaded at start of file. +} -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {} -autoPath {}} {}" +test safe-stock86-17.4 {cf. safe-7.4 - positive non-module package require with specific path and interpAddToAccessPath, Sync Mode off} -constraints AutoSyncDefined -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] safe::setAutoPathSync 0 @@ -220,17 +261,18 @@ test safe-stock86-18.4 {cf. safe-stock86-7.4 - tests specific path and positive # should not have been changed by Safe Base: set auto2 [interp eval $i {set ::auto_path}] - # This time, unlike test safe-stock86-18.2 and the try above, http 1.0 should be found: + # This time, unlike test safe-stock86-17.2 and the try above, http 1.0 should be found: list $auto1 $auto2 $token1 $token2 \ [catch {interp eval $i {package require http 1}} msg] $msg \ [safe::interpConfigure $i]\ [safe::interpDelete $i] } -cleanup { + catch {safe::interpDelete $i} if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" -test safe-stock86-18.5 {cf. safe-stock86-7.5 - tests positive and negative module loading without conventional AutoPathSync} -setup { +} -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {} -autoPath {}} {}" +test safe-stock86-17.5 {cf. safe-7.5 - positive and negative module package require, including ancestor directory issue, Sync Mode off} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] diff --git a/tests/safe.test b/tests/safe.test index f24c4d3..19daabc 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1917,14 +1917,15 @@ test safe-14.2.1 {Check that first element of slave auto_path (and access path) set token [lindex [$i eval set ::auto_path] 0] set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] set accessList [lindex [safe::interpConfigure $i -accessPath] 1] - return [list [lindex $accessList 0] $auto0] + set autoList [lindex [safe::interpConfigure $i -autoPath] 1] + return [list [lindex $accessList 0] [lindex $autoList 0] $auto0] } -cleanup { set ::auto_path $::auto_TMP safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -result [list [info library] [info library]] +} -result [list [info library] [info library] [info library]] test safe-14.3 {Check that first element of slave auto_path (and access path) is Tcl Library, even if not true for master, Sync Mode on} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { @@ -1974,15 +1975,16 @@ test safe-14.3.1 {Check that first element of slave auto_path (and access path) set token [lindex [$i eval set ::auto_path] 0] set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] set accessList [lindex [safe::interpConfigure $i -accessPath] 1] + set autoList [lindex [safe::interpConfigure $i -autoPath] 1] - return [list [lindex $accessList 0] $auto0] + return [list [lindex $accessList 0] [lindex $autoList 0] $auto0] } -cleanup { set ::auto_path $::auto_TMP safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -result [list [info library] [info library]] +} -result [list [info library] [info library] [info library]] ### 17. Test the use of ::auto_path for loading commands (via tclIndex files) ### and non-module packages (via pkgIndex.tcl files). @@ -2029,7 +2031,9 @@ test safe-17.2 {cf. safe-7.2 - negative non-module package require with specific } } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] + # should not have been set by Safe Base: set auto1 [interp eval $i {set ::auto_path}] + # This does not change the value of option -autoPath: interp eval $i {set ::auto_path [list {$p(:0:)}]} # should not add anything (p0) set token1 [safe::interpAddToAccessPath $i [info library]] @@ -2051,7 +2055,7 @@ test safe-17.2 {cf. safe-7.2 - negative non-module package require with specific {-accessPath {[list $tcl_library \ */dummy/unixlike/test/path \ $TestsDir/auto0]}\ - -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" + -statics 0 -nested 1 -deleteHook {} -autoPath {}} {}" # (not a counterpart of safe-7.3) test safe-17.3 {Check that default auto_path is the same as in the master interpreter, Sync Mode off} -constraints AutoSyncDefined -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -2069,13 +2073,13 @@ test safe-17.3 {Check that default auto_path is the same as in the master interp foreach token [$i eval set ::auto_path] { lappend ap [dict get [set ::safe::S${i}(access_path,map)] $token] } - return $ap + return [list $ap [lindex [::safe::interpConfigure $i -autoPath] 1]] } -cleanup { safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -result $::auto_path +} -result [list $::auto_path $::auto_path] test safe-17.4 {cf. safe-7.4 - positive non-module package require with specific path and interpAddToAccessPath, Sync Mode off} -constraints AutoSyncDefined -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { @@ -2090,6 +2094,7 @@ test safe-17.4 {cf. safe-7.4 - positive non-module package require with specific # should not have been set by Safe Base: set auto1 [interp eval $i {set ::auto_path}] + # This does not change the value of option -autoPath. interp eval $i {set ::auto_path [list {$p(:0:)}]} # should not add anything (p0) @@ -2118,7 +2123,7 @@ test safe-17.4 {cf. safe-7.4 - positive non-module package require with specific } -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 0 1.2.3\ {-accessPath {[list $tcl_library *$TestsDir/auto0 $TestsDir/auto0/auto1]}\ -statics 0 -nested 1 -deleteHook {}\ - -autoPath {[list $tcl_library $TestsDir/auto0]}} {}" + -autoPath {}} {}" test safe-17.5 {cf. safe-7.5 - positive and negative module package require, including ancestor directory issue, Sync Mode off} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { @@ -2171,19 +2176,23 @@ test safe-19.8 {autoloading commands indexed in tclIndex files, Sync Mode off} - set mappA [mapList $PathMapp [dict get $confA -accessPath]] set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + set mappC [mapList $PathMapp [dict get $confA -autoPath]] + set toksC [interp eval $i set ::auto_path] # Load and run the commands. set code1 [catch {interp eval $i {report1}} msg1] set code2 [catch {interp eval $i {report2}} msg2] - list $path1 $path2 -- $code1 $msg1 $code2 $msg2 -- $mappA + list $path1 $path2 -- $code1 $msg1 $code2 $msg2 -- $mappA -- $mappC -- $toksC } -cleanup { safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- 0 ok1 0 ok2 --\ - {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*}} + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {{$p(:0:)} {$p(:1:)} {$p(:2:)}}} test safe-19.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset), Sync Mode off} -constraints AutoSyncDefined -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { @@ -2204,6 +2213,8 @@ test safe-19.9 {interpConfigure change the access path; tclIndex commands unaffe set mappA [mapList $PathMapp [dict get $confA -accessPath]] set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + set mappC [mapList $PathMapp [dict get $confA -autoPath]] + set toksC [interp eval $i set ::auto_path] # Load auto_load data. interp eval $i {catch nonExistentCommand} @@ -2225,12 +2236,15 @@ test safe-19.9 {interpConfigure change the access path; tclIndex commands unaffe set mappB [mapList $PathMapp [dict get $confB -accessPath]] set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + set mappD [mapList $PathMapp [dict get $confB -autoPath]] + set toksD [interp eval $i set ::auto_path] # Run the commands. set code3 [catch {interp eval $i {report1}} msg3] set code4 [catch {interp eval $i {report2}} msg4] - list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- $mappC -- $mappD -- $toksC -- $toksD } -cleanup { safe::interpDelete $i if {$SyncExists} { @@ -2238,7 +2252,10 @@ test safe-19.9 {interpConfigure change the access path; tclIndex commands unaffe } } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ - {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {{$p(:0:)} {$p(:1:)} {$p(:2:)}} -- {{$p(:0:)} {$p(:2:)} {$p(:1:)}}} test safe-19.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset), Sync Mode off} -constraints {AutoSyncDefined} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { @@ -2259,6 +2276,8 @@ test safe-19.10 {interpConfigure change the access path; tclIndex commands unaff set mappA [mapList $PathMapp [dict get $confA -accessPath]] set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + set mappC [mapList $PathMapp [dict get $confA -autoPath]] + set toksC [interp eval $i set ::auto_path] # Load auto_load data. interp eval $i {catch nonExistentCommand} @@ -2278,12 +2297,15 @@ test safe-19.10 {interpConfigure change the access path; tclIndex commands unaff set mappB [mapList $PathMapp [dict get $confB -accessPath]] set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + set mappD [mapList $PathMapp [dict get $confB -autoPath]] + set toksD [interp eval $i set ::auto_path] # Load and run the commands. set code3 [catch {interp eval $i {report1}} msg3] set code4 [catch {interp eval $i {report2}} msg4] - list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- $mappA -- $mappB + list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- $mappC -- $mappD -- $toksC -- $toksD } -cleanup { safe::interpDelete $i if {$SyncExists} { @@ -2292,8 +2314,11 @@ test safe-19.10 {interpConfigure change the access path; tclIndex commands unaff } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ - {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} -test safe-19.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, Sync Mode off} -constraints AutoSyncDefined -setup { + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2} --\ + {{$p(:0:)} {$p(:1:)} {$p(:2:)}} -- {{$p(:0:)} {$p(:2:)} {$p(:1:)}}} +test safe-19.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement (1), Sync Mode off} -constraints AutoSyncDefined -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -2302,7 +2327,6 @@ test safe-19.11 {interpConfigure change the access path; pkgIndex.tcl packages u error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } } -body { - # For complete correspondence to safe-stock87-9.11, include auto0 in access path. set i [safe::interpCreate -accessPath [list $tcl_library \ [file join $TestsDir auto0] \ [file join $TestsDir auto0 auto1] \ @@ -2315,6 +2339,8 @@ test safe-19.11 {interpConfigure change the access path; pkgIndex.tcl packages u set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]] set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + set mappC [mapList $PathMapp [dict get $confA -autoPath]] + set toksC [interp eval $i set ::auto_path] # Load pkgIndex.tcl data. catch {interp eval $i {package require NOEXIST}} @@ -2333,6 +2359,8 @@ test safe-19.11 {interpConfigure change the access path; pkgIndex.tcl packages u set mappB [mapList $PathMapp [dict get $confB -accessPath]] set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + set mappD [mapList $PathMapp [dict get $confB -autoPath]] + set toksD [interp eval $i set ::auto_path] # Try to load the packages and run a command from each one. set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] @@ -2341,7 +2369,8 @@ test safe-19.11 {interpConfigure change the access path; pkgIndex.tcl packages u set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ - $mappA -- $mappB -- $code5 $msg5 $code6 $msg6 + $mappA -- $mappB -- $mappC -- $mappD -- $toksC -- $toksD -- \ + $code5 $msg5 $code6 $msg6 } -cleanup { safe::interpDelete $i if {$SyncExists} { @@ -2350,6 +2379,8 @@ test safe-19.11 {interpConfigure change the access path; pkgIndex.tcl packages u } -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ + {TCLLIB TESTSDIR/auto0} -- {TCLLIB TESTSDIR/auto0} --\ + {{$p(:0:)} {$p(:1:)}} -- {{$p(:0:)} {$p(:1:)}} --\ 0 OK1 0 OK2} test safe-19.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, safe-19.11 without path auto0, Sync Mode off} -constraints {AutoSyncDefined} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -2373,6 +2404,8 @@ test safe-19.12 {interpConfigure change the access path; pkgIndex.tcl packages u set mappA [mapList $PathMapp [dict get $confA -accessPath]] set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + set mappC [mapList $PathMapp [dict get $confA -autoPath]] + set toksC [interp eval $i set ::auto_path] # Load pkgIndex.tcl data. catch {interp eval $i {package require NOEXIST}} @@ -2389,6 +2422,8 @@ test safe-19.12 {interpConfigure change the access path; pkgIndex.tcl packages u set mappB [mapList $PathMapp [dict get $confB -accessPath]] set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + set mappD [mapList $PathMapp [dict get $confB -autoPath]] + set toksD [interp eval $i set ::auto_path] # Try to load the packages and run a command from each one. set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] @@ -2397,7 +2432,7 @@ test safe-19.12 {interpConfigure change the access path; pkgIndex.tcl packages u set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] list $path1 $path2 -- $path3 $path4 -- $code3 $msg3 $code4 $msg4 -- \ - $mappA -- $mappB -- \ + $mappA -- $mappB -- $mappC -- $mappD -- $toksC -- $toksD -- \ $code5 $msg5 $code6 $msg6 } -cleanup { safe::interpDelete $i @@ -2408,6 +2443,9 @@ test safe-19.12 {interpConfigure change the access path; pkgIndex.tcl packages u 0 1.2.3 0 2.3.4 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2} --\ + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1} --\ + {{$p(:0:)} {$p(:1:)} {$p(:2:)}} -- {{$p(:0:)} {$p(:1:)} {$p(:2:)}} --\ 0 OK1 0 OK2} test safe-19.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, Sync Mode off} -constraints {AutoSyncDefined} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] @@ -2430,6 +2468,8 @@ test safe-19.13 {interpConfigure change the access path; pkgIndex.tcl packages f set mappA [mapList $PathMapp [dict get $confA -accessPath]] set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + set mappC [mapList $PathMapp [dict get $confA -autoPath]] + set toksC [interp eval $i set ::auto_path] # Load pkgIndex.tcl data. catch {interp eval $i {package require NOEXIST}} @@ -2442,13 +2482,15 @@ test safe-19.13 {interpConfigure change the access path; pkgIndex.tcl packages f set mappB [mapList $PathMapp [dict get $confB -accessPath]] set code4 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]} path4] set code5 [catch {::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]} path5] + set mappD [mapList $PathMapp [dict get $confB -autoPath]] + set toksD [interp eval $i set ::auto_path] # Try to load the packages. set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] set code6 [catch {interp eval $i {package require SafeTestPackage2}} msg6] list $path1 $path2 -- $code4 $path4 -- $code5 $path5 -- $code3 $code6 -- \ - $mappA -- $mappB + $mappA -- $mappB -- $mappC -- $mappD -- $toksC -- $toksD } -cleanup { safe::interpDelete $i if {$SyncExists} { @@ -2456,7 +2498,190 @@ test safe-19.13 {interpConfigure change the access path; pkgIndex.tcl packages f } } -match glob -result {{$p(:2:)} {$p(:3:)} -- 1 {* not found in access path} --\ 1 {* not found in access path} -- 1 1 --\ - {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} -- {TCLLIB*}} + {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB*} -- {TCLLIB TESTSDIR/auto0} -- {TCLLIB TESTSDIR/auto0} --\ + {{$p(:0:)} {$p(:1:)}} -- {{$p(:0:)}}} +# (no counterpart safe-9.14) +test safe-19.14 {when interpConfigure changes the access path, ::auto_path uses -autoPath value and new tokens, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + # Test that although -autoPath is unchanged, the slave's ::auto_path changes to + # reflect the changes in token mappings. + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] \ + -autoPath [list $tcl_library \ + [file join $TestsDir auto0]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + set mappC [mapList $PathMapp [dict get $confA -autoPath]] + set toksC [interp eval $i set ::auto_path] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Swap tokens {$p(:1:)} and {$p(:3:)}. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto2] \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + set mappD [mapList $PathMapp [dict get $confA -autoPath]] + set toksD [interp eval $i set ::auto_path] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path0 $path1 $path2 -- $path5 $path3 $path4 -- $toksC -- $toksD -- \ + $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- $mappC -- $mappD -- $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result {{$p(:1:)} {$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} {$p(:1:)} -- {{$p(:0:)} {$p(:1:)}} -- {{$p(:0:)} {$p(:3:)}} -- 0 1.2.3 0 2.3.4 --\ + {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1 TESTSDIR/auto0*} --\ + {TCLLIB TESTSDIR/auto0} --\ + {TCLLIB TESTSDIR/auto0} --\ + 0 OK1 0 OK2} +# (no counterpart safe-9.15) +test safe-19.15 {when interpConfigure changes the access path, ::auto_path uses -autoPath value and new tokens, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + # Test that although -autoPath is unchanged, the slave's ::auto_path changes to + # reflect the changes in token mappings; and that it is based on the -autoPath + # value, not the previously restricted slave ::auto_path. + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0]] \ + -autoPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path0 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]] + set mappC [mapList $PathMapp [dict get $confA -autoPath]] + set toksC [interp eval $i set ::auto_path] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Add more directories. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path4 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + set mappD [mapList $PathMapp [dict get $confA -autoPath]] + set toksD [interp eval $i set ::auto_path] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3 opts3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4 opts4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path0 -- $path5 $path3 $path4 -- $toksC -- $toksD -- \ + $code3 $msg3 $code4 $msg4 -- \ + $mappA -- $mappB -- $mappC -- $mappD -- $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result {{$p(:1:)} -- {$p(:1:)} {$p(:2:)} {$p(:3:)} -- {{$p(:0:)}} -- {{$p(:0:)} {$p(:2:)} {$p(:3:)}} -- 0 1.2.3 0 2.3.4 --\ + {TCLLIB TESTSDIR/auto0*} --\ + {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2} --\ + {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2} --\ + 0 OK1 0 OK2} +# (no counterpart safe-9.16) +test safe-19.16 {default value for -accessPath and -autoPath on creation; -autoPath preserved when -accessPath changes, ::auto_path using changed tokens, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set tmpAutoPath $::auto_path + set ::auto_path [list $tcl_library [file join $TestsDir auto0]] + set i [safe::interpCreate] + set ::auto_path $tmpAutoPath +} -body { + # Test that the -autoPath acquires and keeps the master's value unless otherwise specified. + + # Inspect. + set confA [safe::interpConfigure $i] + set mappC [mapList $PathMapp [dict get $confA -autoPath]] + set toksC [interp eval $i set ::auto_path] + + # Load pkgIndex.tcl data. + catch {interp eval $i {package require NOEXIST}} + + # Rearrange access path. Remove a directory. + safe::interpConfigure $i -accessPath [list $tcl_library \ + [file join $TestsDir auto0] \ + [file join $TestsDir auto0 auto1]] + # Inspect. + set confB [safe::interpConfigure $i] + set mappB [mapList $PathMapp [dict get $confB -accessPath]] + set path5 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0]] + set path3 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set mappD [mapList $PathMapp [dict get $confA -autoPath]] + set toksD [interp eval $i set ::auto_path] + + # Try to load the packages and run a command from each one. + set code3 [catch {interp eval $i {package require SafeTestPackage1}} msg3] + set code4 [catch {interp eval $i {package require SafeTestPackage2}} msg4] + set code5 [catch {interp eval $i {HeresPackage1}} msg5 opts5] + set code6 [catch {interp eval $i {HeresPackage2}} msg6 opts6] + + list $path5 $path3 -- [lindex $toksC 0] [llength $toksC] -- \ + $toksD -- $code3 $msg3 $code4 $msg4 -- \ + $mappB -- $mappC -- $mappD -- $code5 $msg5 $code6 $msg6 +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:0:)} 2 --\ + {{$p(:0:)} {$p(:1:)}} -- 0 1.2.3 1 {can't find package SafeTestPackage2} --\ + {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1*} --\ + {TCLLIB TESTSDIR/auto0} -- {TCLLIB TESTSDIR/auto0} --\ + 0 OK1 1 {invalid command name "HeresPackage2"}} test safe-19.20 {check module loading, Sync Mode off} -constraints AutoSyncDefined -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { -- cgit v0.12 From b64759fbc4e900de70694bebbc5a48c8ed52be9b Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 25 Jul 2020 01:46:56 +0000 Subject: Rearrange tests in safe.test so they are in numerical order, add 24 more tests of -accessPath/-autoPath cases. --- tests/safe.test | 808 +++++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 620 insertions(+), 188 deletions(-) diff --git a/tests/safe.test b/tests/safe.test index 19daabc..e0a2d84 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -37,6 +37,11 @@ set ::auto_path [info library] set TestsDir [file normalize [file dirname [info script]]] set PathMapp [list $tcl_library TCLLIB $TestsDir TESTSDIR] +proc getAutoPath {slave} { + set ap1 [lrange [lindex [safe::interpConfigure $slave -autoPath] 1] 0 end] + set ap2 [::safe::DetokPath $slave [interp eval $slave set ::auto_path]] + list $ap1 -- $ap2 +} proc mapList {map listIn} { set listOut {} foreach element $listIn { @@ -1731,6 +1736,120 @@ test safe-14.1 {Check that module path is the same as in the master interpreter } -cleanup { safe::interpDelete $i } -result [::tcl::tm::path list] +test safe-14.2 {Check that first element of slave auto_path (and access path) is Tcl Library, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib1 $lib2] + + set i [safe::interpCreate] +} -body { + set autoList {} + set token [lindex [$i eval set ::auto_path] 0] + set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] + set accessList [lindex [safe::interpConfigure $i -accessPath] 1] + return [list [lindex $accessList 0] $auto0] +} -cleanup { + set ::auto_path $::auto_TMP + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result [list [info library] [info library]] +test safe-14.2.1 {Check that first element of slave auto_path (and access path) is Tcl Library, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib1 $lib2] + + set i [safe::interpCreate] +} -body { + set autoList {} + set token [lindex [$i eval set ::auto_path] 0] + set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] + set accessList [lindex [safe::interpConfigure $i -accessPath] 1] + set autoList [lindex [safe::interpConfigure $i -autoPath] 1] + return [list [lindex $accessList 0] [lindex $autoList 0] $auto0] +} -cleanup { + set ::auto_path $::auto_TMP + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result [list [info library] [info library] [info library]] +test safe-14.3 {Check that first element of slave auto_path (and access path) is Tcl Library, even if not true for master, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib2 $lib1] + # Unexpected order, should be reversed in the slave + + set i [safe::interpCreate] +} -body { + set autoList {} + set token [lindex [$i eval set ::auto_path] 0] + set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] + set accessList [lindex [safe::interpConfigure $i -accessPath] 1] + + return [list [lindex $accessList 0] $auto0] +} -cleanup { + set ::auto_path $::auto_TMP + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result [list [info library] [info library]] +test safe-14.3.1 {Check that first element of slave auto_path (and access path) is Tcl Library, even if not true for master, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib2 $lib1] + # Unexpected order, should be reversed in the slave + + set i [safe::interpCreate] +} -body { + set autoList {} + set token [lindex [$i eval set ::auto_path] 0] + set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] + set accessList [lindex [safe::interpConfigure $i -accessPath] 1] + set autoList [lindex [safe::interpConfigure $i -autoPath] 1] + + return [list [lindex $accessList 0] [lindex $autoList 0] $auto0] +} -cleanup { + set ::auto_path $::auto_TMP + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result [list [info library] [info library] [info library]] ### 15. Safe file ensemble. @@ -1869,123 +1988,6 @@ test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup unset user } -result {~USER} -### 14.x move above. - -test safe-14.2 {Check that first element of slave auto_path (and access path) is Tcl Library, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 - } - - set lib1 [info library] - set lib2 [file dirname $lib1] - set ::auto_TMP $::auto_path - set ::auto_path [list $lib1 $lib2] - - set i [safe::interpCreate] -} -body { - set autoList {} - set token [lindex [$i eval set ::auto_path] 0] - set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] - set accessList [lindex [safe::interpConfigure $i -accessPath] 1] - return [list [lindex $accessList 0] $auto0] -} -cleanup { - set ::auto_path $::auto_TMP - safe::interpDelete $i - if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP - } -} -result [list [info library] [info library]] -test safe-14.2.1 {Check that first element of slave auto_path (and access path) is Tcl Library, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 - } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} - } - - set lib1 [info library] - set lib2 [file dirname $lib1] - set ::auto_TMP $::auto_path - set ::auto_path [list $lib1 $lib2] - - set i [safe::interpCreate] -} -body { - set autoList {} - set token [lindex [$i eval set ::auto_path] 0] - set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] - set accessList [lindex [safe::interpConfigure $i -accessPath] 1] - set autoList [lindex [safe::interpConfigure $i -autoPath] 1] - return [list [lindex $accessList 0] [lindex $autoList 0] $auto0] -} -cleanup { - set ::auto_path $::auto_TMP - safe::interpDelete $i - if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP - } -} -result [list [info library] [info library] [info library]] -test safe-14.3 {Check that first element of slave auto_path (and access path) is Tcl Library, even if not true for master, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 - } - - set lib1 [info library] - set lib2 [file dirname $lib1] - set ::auto_TMP $::auto_path - set ::auto_path [list $lib2 $lib1] - # Unexpected order, should be reversed in the slave - - set i [safe::interpCreate] -} -body { - set autoList {} - set token [lindex [$i eval set ::auto_path] 0] - set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] - set accessList [lindex [safe::interpConfigure $i -accessPath] 1] - - return [list [lindex $accessList 0] $auto0] -} -cleanup { - set ::auto_path $::auto_TMP - safe::interpDelete $i - if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP - } -} -result [list [info library] [info library]] -test safe-14.3.1 {Check that first element of slave auto_path (and access path) is Tcl Library, even if not true for master, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 - } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} - } - - set lib1 [info library] - set lib2 [file dirname $lib1] - set ::auto_TMP $::auto_path - set ::auto_path [list $lib2 $lib1] - # Unexpected order, should be reversed in the slave - - set i [safe::interpCreate] -} -body { - set autoList {} - set token [lindex [$i eval set ::auto_path] 0] - set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] - set accessList [lindex [safe::interpConfigure $i -accessPath] 1] - set autoList [lindex [safe::interpConfigure $i -autoPath] 1] - - return [list [lindex $accessList 0] [lindex $autoList 0] $auto0] -} -cleanup { - set ::auto_path $::auto_TMP - safe::interpDelete $i - if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP - } -} -result [list [info library] [info library] [info library]] - ### 17. Test the use of ::auto_path for loading commands (via tclIndex files) ### and non-module packages (via pkgIndex.tcl files). ### Corresponding tests with Sync Mode on are 7.* @@ -2152,33 +2154,136 @@ test safe-17.5 {cf. safe-7.5 - positive and negative module package require, inc } } -result {1 {can't find package test1} 0} -### 19. Assorted options, including changes to option values. -### Mostly these are changes to access path, auto_path, module path. -### If Sync Mode is on, a corresponding test with Sync Mode off is 9.* +### 18. Test tokenization of directories available to a slave. -test safe-19.8 {autoloading commands indexed in tclIndex files, Sync Mode off} -constraints AutoSyncDefined -setup { +test safe-18.1 {Check that each directory of the default auto_path is a valid token, Sync Mode on} -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 - } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + safe::setAutoPathSync 1 } + set i [safe::interpCreate] } -body { - set i [safe::interpCreate -accessPath [list $tcl_library \ - [file join $TestsDir auto0 auto1] \ - [file join $TestsDir auto0 auto2]] \ - -autoPath [list $tcl_library \ - [file join $TestsDir auto0 auto1] \ - [file join $TestsDir auto0 auto2]]] - # Inspect. - set confA [safe::interpConfigure $i] - set mappA [mapList $PathMapp [dict get $confA -accessPath]] - set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] - set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] - set mappC [mapList $PathMapp [dict get $confA -autoPath]] - set toksC [interp eval $i set ::auto_path] - + set badTokens {} + foreach dir [$i eval {set ::auto_path}] { + if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { + # Match - OK - token has expected form + } else { + # No match - possibly an ordinary path has not been tokenized + lappend badTokens $dir + } + } + set badTokens +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {} +test safe-18.1.1 {Check that each directory of the default auto_path is a valid token, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set i [safe::interpCreate] +} -body { + set badTokens {} + foreach dir [$i eval {set ::auto_path}] { + if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { + # Match - OK - token has expected form + } else { + # No match - possibly an ordinary path has not been tokenized + lappend badTokens $dir + } + } + set badTokens +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {} +test safe-18.2 {Check that each directory of the module path is a valid token, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + set i [safe::interpCreate] +} -body { + set badTokens {} + foreach dir [$i eval {::tcl::tm::path list}] { + if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { + # Match - OK - token has expected form + } else { + # No match - possibly an ordinary path has not been tokenized + lappend badTokens $dir + } + } + set badTokens +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {} +test safe-18.2.1 {Check that each directory of the module path is a valid token, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set i [safe::interpCreate] +} -body { + set badTokens {} + foreach dir [$i eval {::tcl::tm::path list}] { + if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { + # Match - OK - token has expected form + } else { + # No match - possibly an ordinary path has not been tokenized + lappend badTokens $dir + } + } + set badTokens +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {} + +### 19. Assorted options, including changes to option values. +### Mostly these are changes to access path, auto_path, module path. +### If Sync Mode is on, a corresponding test with Sync Mode off is 9.* + +test safe-19.8 {autoloading commands indexed in tclIndex files, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + set i [safe::interpCreate -accessPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]] \ + -autoPath [list $tcl_library \ + [file join $TestsDir auto0 auto1] \ + [file join $TestsDir auto0 auto2]]] + # Inspect. + set confA [safe::interpConfigure $i] + set mappA [mapList $PathMapp [dict get $confA -accessPath]] + set path1 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto1]] + set path2 [::safe::interpFindInAccessPath $i [file join $TestsDir auto0 auto2]] + set mappC [mapList $PathMapp [dict get $confA -autoPath]] + set toksC [interp eval $i set ::auto_path] + # Load and run the commands. set code1 [catch {interp eval $i {report1}} msg1] set code2 [catch {interp eval $i {report2}} msg2] @@ -3019,33 +3124,63 @@ test safe-19.24 {interpConfigure change the access path; check module loading, S res0 res1 res2} # See comments on lsort after test safe-9.20. -### 18. Test tokenization of directories available to a slave. -test safe-18.1 {Check that each directory of the default auto_path is a valid token, Sync Mode on} -setup { +### 20. safe::interpCreate with different cases of -accessPath, -autoPath. + +set ::auto_path [list $tcl_library [file dirname $tcl_library] [file join $TestsDir auto0]] + +test safe-20.1 "create -accessPath NULL -autoPath NULL -> master's ::auto_path" -constraints AutoSyncDefined -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } +} -body { set i [safe::interpCreate] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result [list $::auto_path -- $::auto_path] +test safe-20.2 "create -accessPath {} -autoPath NULL -> master's ::auto_path" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } } -body { - set badTokens {} - foreach dir [$i eval {set ::auto_path}] { - if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { - # Match - OK - token has expected form - } else { - # No match - possibly an ordinary path has not been tokenized - lappend badTokens $dir - } + set i [safe::interpCreate -accessPath {}] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP } - set badTokens +} -result [list $::auto_path -- $::auto_path] +test safe-20.3 "create -accessPath path1 -autoPath NULL -> {}" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1]] + getAutoPath $i } -cleanup { safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -result {} -test safe-18.1.1 {Check that each directory of the default auto_path is a valid token, Sync Mode off} -constraints AutoSyncDefined -setup { +} -result {{} -- {}} +test safe-20.4 "create -accessPath NULL -autoPath {} -> {}" -constraints AutoSyncDefined -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -3053,49 +3188,67 @@ test safe-18.1.1 {Check that each directory of the default auto_path is a valid } else { error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } - set i [safe::interpCreate] } -body { - set badTokens {} - foreach dir [$i eval {set ::auto_path}] { - if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { - # Match - OK - token has expected form - } else { - # No match - possibly an ordinary path has not been tokenized - lappend badTokens $dir - } + set i [safe::interpCreate -autoPath {}] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP } - set badTokens +} -result {{} -- {}} +test safe-20.5 "create -accessPath {} -autoPath {} -> {}" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + set i [safe::interpCreate -accessPath {} -autoPath {}] + getAutoPath $i } -cleanup { safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -result {} -test safe-18.2 {Check that each directory of the module path is a valid token, Sync Mode on} -setup { +} -result {{} -- {}} +test safe-20.6 "create -accessPath path1 -autoPath {} -> {}" -constraints AutoSyncDefined -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } - set i [safe::interpCreate] } -body { - set badTokens {} - foreach dir [$i eval {::tcl::tm::path list}] { - if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { - # Match - OK - token has expected form - } else { - # No match - possibly an ordinary path has not been tokenized - lappend badTokens $dir - } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath {}] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP } - set badTokens +} -result {{} -- {}} +test safe-20.7 "create -accessPath NULL -autoPath path2 -> path2" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + set i [safe::interpCreate -autoPath [lrange $::auto_path 0 0]] + getAutoPath $i } -cleanup { safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -result {} -test safe-18.2.1 {Check that each directory of the module path is a valid token, Sync Mode off} -constraints AutoSyncDefined -setup { +} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]] +test safe-20.8 "create -accessPath {} -autoPath path2 -> path2" -constraints AutoSyncDefined -setup { set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] if {$SyncExists} { set SyncVal_TMP [safe::setAutoPathSync] @@ -3103,28 +3256,307 @@ test safe-18.2.1 {Check that each directory of the module path is a valid token, } else { error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} } - set i [safe::interpCreate] } -body { - set badTokens {} - foreach dir [$i eval {::tcl::tm::path list}] { - if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { - # Match - OK - token has expected form - } else { - # No match - possibly an ordinary path has not been tokenized - lappend badTokens $dir - } + set i [safe::interpCreate -accessPath {} -autoPath [lrange $::auto_path 0 0]] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP } - set badTokens +} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]] +test safe-20.9 "create -accessPath path1 -autoPath path2 -> path2" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] + getAutoPath $i } -cleanup { safe::interpDelete $i if {$SyncExists} { safe::setAutoPathSync $SyncVal_TMP } -} -result {} +} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]] +test safe-20.10 "create -accessPath NULL -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + set i [safe::interpCreate -autoPath /not/in/access/path] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {/not/in/access/path -- {}} +test safe-20.11 "create -accessPath {} -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + set i [safe::interpCreate -accessPath {} -autoPath /not/in/access/path] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {/not/in/access/path -- {}} +test safe-20.12 "create -accessPath path1 -autoPath pathX -> {pathX}" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } +} -body { + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath /not/in/access/path] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {/not/in/access/path -- {}} + +### 21. safe::interpConfigure with different cases of -accessPath, -autoPath. + +test safe-21.1 "interpConfigure -accessPath NULL -autoPath NULL -> no change" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -deleteHook {} + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]] +test safe-21.2 "interpConfigure -accessPath {} -autoPath NULL -> master's ::auto_path" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -accessPath {} + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result [list $::auto_path -- $::auto_path] +test safe-21.3 "interpConfigure -accessPath path1 -autoPath NULL -> no change" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -accessPath [lrange $::auto_path 0 1] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]] +test safe-21.4 "interpConfigure -accessPath NULL -autoPath {} -> {}" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -autoPath {} + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {{} -- {}} +test safe-21.5 "interpConfigure -accessPath {} -autoPath {} -> {}" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -accessPath {} -autoPath {} + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {{} -- {}} +test safe-21.6 "interpConfigure -accessPath {path1} -autoPath {} -> {}" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -accessPath [lrange $::auto_path 1 1] -autoPath {} + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {{} -- {}} +test safe-21.7 "interpConfigure -accessPath NULL -autoPath path2 -> path2" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -autoPath [lrange $::auto_path 1 1] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result [list [lrange $::auto_path 1 1] -- [lrange $::auto_path 1 1]] +test safe-21.8 "interpConfigure -accessPath {} -autoPath path2 -> path2" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -accessPath {} -autoPath [lrange $::auto_path 1 1] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result [list [lrange $::auto_path 1 1] -- [lrange $::auto_path 1 1]] +test safe-21.9 "interpConfigure -accessPath path1 -autoPath path2 -> path2" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -accessPath [lrange $::auto_path 0 2] -autoPath [lrange $::auto_path 1 1] + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result [list [lrange $::auto_path 1 1] -- [lrange $::auto_path 1 1]] +test safe-21.10 "interpConfigure -accessPath NULL -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -autoPath /not/in/access/path + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {/not/in/access/path -- {}} +test safe-21.11 "interpConfigure -accessPath {} -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -accessPath {} -autoPath /not/in/access/path + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {/not/in/access/path -- {}} +test safe-21.12 "interpConfigure -accessPath path1 -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] +} -body { + safe::interpConfigure $i -accessPath [lrange $::auto_path 0 2] -autoPath /not/in/access/path + getAutoPath $i +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {/not/in/access/path -- {}} # cleanup set ::auto_path $SaveAutoPath unset SaveAutoPath TestsDir PathMapp +rename getAutoPath {} rename mapList {} rename mapAndSortList {} ::tcltest::cleanupTests -- cgit v0.12 From 1b7f4189f054796e18cbc8211d7eed39495ffa9c Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 25 Jul 2020 02:08:08 +0000 Subject: Rename command safe::setAutoPathSync to safe::setSyncMode. Add a section TYPICAL USE to doc/safe.n. --- doc/safe.n | 36 ++- library/safe.tcl | 12 +- library/tclIndex | 2 +- tests/safe-stock86.test | 80 +++--- tests/safe.test | 640 ++++++++++++++++++++++++------------------------ 5 files changed, 400 insertions(+), 370 deletions(-) diff --git a/doc/safe.n b/doc/safe.n index 8aa8686..ab424d3 100644 --- a/doc/safe.n +++ b/doc/safe.n @@ -23,7 +23,7 @@ safe \- Creating and manipulating safe interpreters .sp \fB::safe::interpFindInAccessPath\fR \fIslave\fR \fIdirectory\fR .sp -\fB::safe::setAutoPathSync\fR ?\fInewValue\fR? +\fB::safe::setSyncMode\fR ?\fInewValue\fR? .sp \fB::safe::setLogCmd\fR ?\fIcmd arg...\fR? .SS OPTIONS @@ -151,7 +151,7 @@ $slave eval [list set tk_library \e .CE .RE .TP -\fB::safe::setAutoPathSync\fR ?\fInewValue\fR? +\fB::safe::setSyncMode\fR ?\fInewValue\fR? This command is used to get or set the "Sync Mode" of the Safe Base. When an argument is supplied, the command returns an error if the argument is not a boolean value, or if any Safe Base interpreters exist. Typically @@ -377,6 +377,36 @@ When the \fIaccessPath\fR is changed after the first creation or initialization (i.e. through \fBinterpConfigure -accessPath \fR\fIlist\fR), an \fBauto_reset\fR is automatically evaluated in the safe interpreter to synchronize its \fBauto_index\fR with the new token list. +.SH TYPICAL USE +In many cases, the properties of a Safe Base interpreter can be specified +when the interpreter is created, and then left unchanged for the lifetime +of the interpreter. +.PP +If you wish to use Safe Base interpreters with "Sync Mode" off, evaluate +the command +.RS +.PP +.CS + safe::setSyncMode 0 +.CE +.RE +.PP +Use \fB::safe::interpCreate\fR or \fB::safe::interpInit\fR to create an +interpreter with the properties that you require. The simplest way is not +to specify \fB\-accessPath\fR or \fB\-autoPath\fR, which means the safe +interpreter will use the same paths as the master interpreter. However, +if \fB\-accessPath\fR is specified, then \fB\-autoPath\fR must also be +specified, or else it will be set to {}. +.PP +The value of \fB\-autoPath\fR will be that required to access tclIndex +and pkgIndex.txt files according to the same rules as an unsafe +interpreter (see pkg_mkIndex(n) and library(n)). +.PP +With "Sync Mode" on, the option \fB\-autoPath\fR is undefined, and +the Safe Base sets the slave's ::auto_path to a tokenized form of the +access path. In addition to the directories present if "Safe Mode" is off, +the ::auto_path includes the numerous subdirectories and module paths +that belong to the access path. .SH SYNC MODE Before Tcl version 8.6.x, the Safe Base kept each safe interpreter's ::auto_path synchronized with a tokenized form of its access path. @@ -392,7 +422,7 @@ of the ::auto_path and access path ("Sync Mode" on) is still the default. However, the Safe Base offers the option of limiting the safe interpreter's ::auto_path to the much shorter list of directories that is necessary for it to perform its function ("Sync Mode" off). Use the command -\fB::safe::setAutoPathSync\fR to choose the mode before creating any Safe +\fB::safe::setSyncMode\fR to choose the mode before creating any Safe Base interpreters. .PP In either mode, the most convenient way to initialize a safe interpreter is diff --git a/library/safe.tcl b/library/safe.tcl index 5a5ddb5..9a701a4 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -345,7 +345,7 @@ proc ::safe::InterpCreate { # # It is the caller's responsibility, if it supplies a non-empty value for # access_path, to make the first directory in the path suitable for use as -# tcl_library, and (if ![setAutoPathSync]), to set the slave's ::auto_path. +# tcl_library, and (if ![setSyncMode]), to set the slave's ::auto_path. proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook autoPath withAutoPath} { global auto_path @@ -418,9 +418,9 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook au # Set the slave auto_path to a tokenized raw_auto_path. # Silently ignore any directories that are not in the access path. - # If [setAutoPathSync], SyncAccessPath will overwrite this value with the + # If [setSyncMode], SyncAccessPath will overwrite this value with the # full access path. - # If ![setAutoPathSync], Safe Base code will not change this value. + # If ![setSyncMode], Safe Base code will not change this value. set tokens_auto_path {} foreach dir $raw_auto_path { if {[dict exists $remap_access_path $dir]} { @@ -1360,7 +1360,7 @@ proc ::safe::Setup {} { } # Accessor method for ::safe::AutoPathSync -# Usage: ::safe::setAutoPathSync ?newValue? +# Usage: ::safe::setSyncMode ?newValue? # Respond to changes by calling Setup again, preserving any # caller-defined logging. This allows complete equivalence with # prior Safe Base behavior if AutoPathSync is true. @@ -1373,7 +1373,7 @@ proc ::safe::Setup {} { # (The initialization of AutoPathSync at the end of this file is acceptable # because Setup has not yet been called.) -proc ::safe::setAutoPathSync {args} { +proc ::safe::setSyncMode {args} { variable AutoPathSync if {[llength $args] == 0} { @@ -1396,7 +1396,7 @@ proc ::safe::setAutoPathSync {args} { setLogCmd $TmpLog } } else { - set msg {wrong # args: should be "safe::setAutoPathSync ?newValue?"} + set msg {wrong # args: should be "safe::setSyncMode ?newValue?"} return -code error $msg } diff --git a/library/tclIndex b/library/tclIndex index 0d2db02..efc29a8 100644 --- a/library/tclIndex +++ b/library/tclIndex @@ -61,7 +61,7 @@ set auto_index(::safe::DirInAccessPath) [list source [file join $dir safe.tcl]] set auto_index(::safe::Subset) [list source [file join $dir safe.tcl]] set auto_index(::safe::AliasSubset) [list source [file join $dir safe.tcl]] set auto_index(::safe::AliasEncoding) [list source [file join $dir safe.tcl]] -set auto_index(::safe::setAutoPathSync) [list source [file join $dir safe.tcl]] +set auto_index(::safe::setSyncMode) [list source [file join $dir safe.tcl]] set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]] set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]] set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]] diff --git a/tests/safe-stock86.test b/tests/safe-stock86.test index e13d37e..1ec7ee5 100644 --- a/tests/safe-stock86.test +++ b/tests/safe-stock86.test @@ -57,10 +57,10 @@ testConstraint AutoSyncDefined 1 ### Corresponding tests with Sync Mode off are 17.* test safe-stock86-7.1 {positive non-module package require, uses http 2, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { set i [safe::interpCreate] @@ -75,14 +75,14 @@ test safe-stock86-7.1 {positive non-module package require, uses http 2, Sync Mo } -cleanup { catch {safe::interpDelete $i} if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result 2.* test safe-stock86-7.2 {negative non-module package require with specific path and interpAddToAccessPath, uses http1.0, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] @@ -100,15 +100,15 @@ test safe-stock86-7.2 {negative non-module package require with specific path an } -cleanup { catch {safe::interpDelete $i} if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:0:)} {$p(:*:)} -- 1 {can't find package http 1} --\ {TCLLIB */dummy/unixlike/test/path} -- {}} test safe-stock86-7.4 {positive non-module package require with specific path and interpAddToAccessPath, uses http1.0, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] @@ -125,14 +125,14 @@ test safe-stock86-7.4 {positive non-module package require with specific path an } -cleanup { catch {safe::interpDelete $i} if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.0 -- {TCLLIB *TCLLIB/http1.0} -- {}} test safe-stock86-7.5 {positive and negative module package require, including ancestor directory issue, uses platform::shell, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set i [safe::interpCreate] interp eval $i { @@ -150,17 +150,17 @@ test safe-stock86-7.5 {positive and negative module package require, including a } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {1 {can't find package shell} 0} # The following test checks whether the definition of tcl_endOfWord can be # obtained from auto_loading. It was previously test "safe-5.1". test safe-stock86-9.8 {autoloading commands indexed in tclIndex files, was test 5.1, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } catch {safe::interpDelete a} safe::interpCreate a @@ -169,7 +169,7 @@ test safe-stock86-9.8 {autoloading commands indexed in tclIndex files, was test } -cleanup { safe::interpDelete a if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result -1 @@ -178,12 +178,12 @@ test safe-stock86-9.8 {autoloading commands indexed in tclIndex files, was test ### Corresponding tests with Sync Mode on are 7.* test safe-stock86-17.1 {cf. safe-7.1 - positive non-module package require, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } # Without AutoPathSync, we need a more complete auto_path, # because the slave will use the same value. @@ -205,16 +205,16 @@ test safe-stock86-17.1 {cf. safe-7.1 - positive non-module package require, Sync } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result 1.0 test safe-stock86-17.2 {cf. safe-7.2 - negative non-module package require with specific path and interpAddToAccessPath, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] @@ -233,16 +233,16 @@ test safe-stock86-17.2 {cf. safe-7.2 - negative non-module package require with } -cleanup { catch {safe::interpDelete $i} if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {} -autoPath {}} {}" test safe-stock86-17.4 {cf. safe-7.4 - positive non-module package require with specific path and interpAddToAccessPath, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] @@ -269,16 +269,16 @@ test safe-stock86-17.4 {cf. safe-7.4 - positive non-module package require with } -cleanup { catch {safe::interpDelete $i} if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 1.0 {-accessPath {[list $tcl_library *$tcl_library/http1.0]} -statics 0 -nested 1 -deleteHook {} -autoPath {}} {}" test safe-stock86-17.5 {cf. safe-7.5 - positive and negative module package require, including ancestor directory issue, Sync Mode off} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set i [safe::interpCreate] interp eval $i { @@ -295,7 +295,7 @@ test safe-stock86-17.5 {cf. safe-7.5 - positive and negative module package requ } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {1 {can't find package shell} 0} diff --git a/tests/safe.test b/tests/safe.test index e0a2d84..ec348b4 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -74,10 +74,10 @@ test safe-1.1 {safe::interpConfigure syntax} -returnCodes error -body { } -result {no value given for parameter "slave" (use -help for full usage) : slave name () name of the slave} test safe-1.2 {safe::interpCreate syntax, Sync Mode on} -returnCodes error -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } else { set SyncVal_TMP 1 } @@ -85,7 +85,7 @@ test safe-1.2 {safe::interpCreate syntax, Sync Mode on} -returnCodes error -setu safe::interpCreate -help } -cleanup { if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {Usage information: Var/FlagName Type Value Help @@ -99,18 +99,18 @@ test safe-1.2 {safe::interpCreate syntax, Sync Mode on} -returnCodes error -setu -nested boolean (false) nested loading -deleteHook script () delete hook} test safe-1.2.1 {safe::interpCreate syntax, Sync Mode off} -returnCodes error -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { safe::interpCreate -help } -cleanup { if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {Usage information: Var/FlagName Type Value Help @@ -374,10 +374,10 @@ rename SafeEval {} ### Corresponding tests with Sync Mode off are 17.* test safe-7.1 {positive non-module package require, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0] @@ -394,14 +394,14 @@ test safe-7.1 {positive non-module package require, Sync Mode on} -setup { } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result 1.2.3 test safe-7.2 {negative non-module package require with specific path and interpAddToAccessPath, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } else { set SyncVal_TMP 1 } @@ -421,7 +421,7 @@ test safe-7.2 {negative non-module package require with specific path and interp $mappA -- [safe::interpDelete $i] } -cleanup { if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:0:)} {$p(:*:)} {$p(:*:)} --\ 1 {can't find package SafeTestPackage1} --\ @@ -458,10 +458,10 @@ test safe-7.3.1 {check that safe subinterpreters work with namespace names} -set [interp exists $j] [info vars ::safe::S*] } -match glob -result {{} {} ok ok {} 0 {}} test safe-7.4 {positive non-module package require with specific path and interpAddToAccessPath, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } else { set SyncVal_TMP 1 } @@ -481,15 +481,15 @@ test safe-7.4 {positive non-module package require with specific path and interp # other than the first and last in the access path. } -cleanup { if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\ {TCLLIB * TESTSDIR/auto0/auto1} -- {}} test safe-7.5 {positive and negative module package require, including ancestor directory issue, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } tcl::tm::path add [file join $TestsDir auto0 modules] set i [safe::interpCreate] @@ -507,7 +507,7 @@ test safe-7.5 {positive and negative module package require, including ancestor } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {1 {can't find package test1} 0} @@ -763,10 +763,10 @@ test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\ {-accessPath * -statics 0 -nested 0 -deleteHook toto}} test safe-9.8 {autoloading commands indexed in tclIndex files, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -786,15 +786,15 @@ test safe-9.8 {autoloading commands indexed in tclIndex files, Sync Mode on} -se } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*}} test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset), Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -832,16 +832,16 @@ test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffec } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} test safe-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset), Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -877,17 +877,17 @@ test safe-9.10 {interpConfigure change the access path; tclIndex commands unaffe } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { # For complete correspondence to safe-9.10opt, include auto0 in access path. @@ -929,17 +929,17 @@ test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages un } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ 0 OK1 0 OK2} test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, safe-9.11 without path auto0, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -976,7 +976,7 @@ test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages un } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ 0 1.2.3 0 2.3.4 --\ @@ -984,10 +984,10 @@ test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages un {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ 0 OK1 0 OK2} test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -1020,16 +1020,16 @@ test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fa } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\ 1 {* not found in access path} -- 1 1 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} -- {TCLLIB*}} test safe-9.20 {check module loading, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -1064,7 +1064,7 @@ test safe-9.20 {check module loading, Sync Mode on} -setup { } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ 0 0.5 0 1.0 0 2.0 --\ @@ -1080,10 +1080,10 @@ test safe-9.20 {check module loading, Sync Mode on} -setup { # comparing with expected results. The test is therefore not totally strict, # but will notice missing or surplus directories. test safe-9.21 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 1} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -1138,7 +1138,7 @@ test safe-9.21 {interpConfigure change the access path; check module loading, Sy } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ @@ -1150,10 +1150,10 @@ test safe-9.21 {interpConfigure change the access path; check module loading, Sy res0 res1 res2} # See comments on lsort after test safe-9.20. test safe-9.22 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 0} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -1203,7 +1203,7 @@ test safe-9.22 {interpConfigure change the access path; check module loading, Sy } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ @@ -1215,10 +1215,10 @@ test safe-9.22 {interpConfigure change the access path; check module loading, Sy res0 res1 res2} # See comments on lsort after test safe-9.20. test safe-9.23 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 3} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -1278,7 +1278,7 @@ test safe-9.23 {interpConfigure change the access path; check module loading, Sy } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ @@ -1290,10 +1290,10 @@ test safe-9.23 {interpConfigure change the access path; check module loading, Sy res0 res1 res2} # See comments on lsort after test safe-9.20. test safe-9.24 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 2 (worst case)} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -1348,7 +1348,7 @@ test safe-9.24 {interpConfigure change the access path; check module loading, Sy } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ @@ -1737,10 +1737,10 @@ test safe-14.1 {Check that module path is the same as in the master interpreter safe::interpDelete $i } -result [::tcl::tm::path list] test safe-14.2 {Check that first element of slave auto_path (and access path) is Tcl Library, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set lib1 [info library] @@ -1759,16 +1759,16 @@ test safe-14.2 {Check that first element of slave auto_path (and access path) is set ::auto_path $::auto_TMP safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result [list [info library] [info library]] test safe-14.2.1 {Check that first element of slave auto_path (and access path) is Tcl Library, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set lib1 [info library] @@ -1788,14 +1788,14 @@ test safe-14.2.1 {Check that first element of slave auto_path (and access path) set ::auto_path $::auto_TMP safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result [list [info library] [info library] [info library]] test safe-14.3 {Check that first element of slave auto_path (and access path) is Tcl Library, even if not true for master, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set lib1 [info library] @@ -1816,16 +1816,16 @@ test safe-14.3 {Check that first element of slave auto_path (and access path) is set ::auto_path $::auto_TMP safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result [list [info library] [info library]] test safe-14.3.1 {Check that first element of slave auto_path (and access path) is Tcl Library, even if not true for master, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set lib1 [info library] @@ -1847,7 +1847,7 @@ test safe-14.3.1 {Check that first element of slave auto_path (and access path) set ::auto_path $::auto_TMP safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result [list [info library] [info library] [info library]] @@ -1993,12 +1993,12 @@ test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup ### Corresponding tests with Sync Mode on are 7.* test safe-17.1 {cf. safe-7.1 - positive non-module package require, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } # Without AutoPathSync, we need a more complete auto_path, # because the slave will use the same value. @@ -2020,16 +2020,16 @@ test safe-17.1 {cf. safe-7.1 - positive non-module package require, Sync Mode of } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result 1.2.3 test safe-17.2 {cf. safe-7.2 - negative non-module package require with specific path and interpAddToAccessPath, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] @@ -2050,7 +2050,7 @@ test safe-17.2 {cf. safe-7.2 - negative non-module package require with specific [safe::interpDelete $i] } -cleanup { if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result "{} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)}\ 1 {can't find package SafeTestPackage1}\ @@ -2060,12 +2060,12 @@ test safe-17.2 {cf. safe-7.2 - negative non-module package require with specific -statics 0 -nested 1 -deleteHook {} -autoPath {}} {}" # (not a counterpart of safe-7.3) test safe-17.3 {Check that default auto_path is the same as in the master interpreter, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set i [safe::interpCreate] } -body { @@ -2079,16 +2079,16 @@ test safe-17.3 {Check that default auto_path is the same as in the master interp } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result [list $::auto_path $::auto_path] test safe-17.4 {cf. safe-7.4 - positive non-module package require with specific path and interpAddToAccessPath, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] @@ -2120,19 +2120,19 @@ test safe-17.4 {cf. safe-7.4 - positive non-module package require with specific [safe::interpDelete $i] } -cleanup { if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 0 1.2.3\ {-accessPath {[list $tcl_library *$TestsDir/auto0 $TestsDir/auto0/auto1]}\ -statics 0 -nested 1 -deleteHook {}\ -autoPath {}} {}" test safe-17.5 {cf. safe-7.5 - positive and negative module package require, including ancestor directory issue, Sync Mode off} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } tcl::tm::path add [file join $TestsDir auto0 modules] set i [safe::interpCreate] @@ -2150,17 +2150,17 @@ test safe-17.5 {cf. safe-7.5 - positive and negative module package require, inc } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {1 {can't find package test1} 0} ### 18. Test tokenization of directories available to a slave. test safe-18.1 {Check that each directory of the default auto_path is a valid token, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set i [safe::interpCreate] } -body { @@ -2177,16 +2177,16 @@ test safe-18.1 {Check that each directory of the default auto_path is a valid to } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {} test safe-18.1.1 {Check that each directory of the default auto_path is a valid token, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set i [safe::interpCreate] } -body { @@ -2203,14 +2203,14 @@ test safe-18.1.1 {Check that each directory of the default auto_path is a valid } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {} test safe-18.2 {Check that each directory of the module path is a valid token, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set i [safe::interpCreate] } -body { @@ -2227,16 +2227,16 @@ test safe-18.2 {Check that each directory of the module path is a valid token, S } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {} test safe-18.2.1 {Check that each directory of the module path is a valid token, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set i [safe::interpCreate] } -body { @@ -2253,7 +2253,7 @@ test safe-18.2.1 {Check that each directory of the module path is a valid token, } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {} @@ -2262,12 +2262,12 @@ test safe-18.2.1 {Check that each directory of the module path is a valid token, ### If Sync Mode is on, a corresponding test with Sync Mode off is 9.* test safe-19.8 {autoloading commands indexed in tclIndex files, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -2292,19 +2292,19 @@ test safe-19.8 {autoloading commands indexed in tclIndex files, Sync Mode off} - } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {{$p(:0:)} {$p(:1:)} {$p(:2:)}}} test safe-19.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset), Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -2353,7 +2353,7 @@ test safe-19.9 {interpConfigure change the access path; tclIndex commands unaffe } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ @@ -2362,12 +2362,12 @@ test safe-19.9 {interpConfigure change the access path; tclIndex commands unaffe {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {{$p(:0:)} {$p(:1:)} {$p(:2:)}} -- {{$p(:0:)} {$p(:2:)} {$p(:1:)}}} test safe-19.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset), Sync Mode off} -constraints {AutoSyncDefined} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -2414,7 +2414,7 @@ test safe-19.10 {interpConfigure change the access path; tclIndex commands unaff } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ 0 ok1 0 ok2 --\ @@ -2424,12 +2424,12 @@ test safe-19.10 {interpConfigure change the access path; tclIndex commands unaff {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2} --\ {{$p(:0:)} {$p(:1:)} {$p(:2:)}} -- {{$p(:0:)} {$p(:2:)} {$p(:1:)}}} test safe-19.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement (1), Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -2479,7 +2479,7 @@ test safe-19.11 {interpConfigure change the access path; pkgIndex.tcl packages u } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ @@ -2488,12 +2488,12 @@ test safe-19.11 {interpConfigure change the access path; pkgIndex.tcl packages u {{$p(:0:)} {$p(:1:)}} -- {{$p(:0:)} {$p(:1:)}} --\ 0 OK1 0 OK2} test safe-19.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, safe-19.11 without path auto0, Sync Mode off} -constraints {AutoSyncDefined} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { # To manage without path auto0, use an auto_path that is unusual for @@ -2542,7 +2542,7 @@ test safe-19.12 {interpConfigure change the access path; pkgIndex.tcl packages u } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ 0 1.2.3 0 2.3.4 --\ @@ -2553,12 +2553,12 @@ test safe-19.12 {interpConfigure change the access path; pkgIndex.tcl packages u {{$p(:0:)} {$p(:1:)} {$p(:2:)}} -- {{$p(:0:)} {$p(:1:)} {$p(:2:)}} --\ 0 OK1 0 OK2} test safe-19.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, Sync Mode off} -constraints {AutoSyncDefined} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { # Path auto0 added (cf. safe-9.3) because it is needed for auto_path. @@ -2599,7 +2599,7 @@ test safe-19.13 {interpConfigure change the access path; pkgIndex.tcl packages f } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:2:)} {$p(:3:)} -- 1 {* not found in access path} --\ 1 {* not found in access path} -- 1 1 --\ @@ -2608,12 +2608,12 @@ test safe-19.13 {interpConfigure change the access path; pkgIndex.tcl packages f {{$p(:0:)} {$p(:1:)}} -- {{$p(:0:)}}} # (no counterpart safe-9.14) test safe-19.14 {when interpConfigure changes the access path, ::auto_path uses -autoPath value and new tokens, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { # Test that although -autoPath is unchanged, the slave's ::auto_path changes to @@ -2662,7 +2662,7 @@ test safe-19.14 {when interpConfigure changes the access path, ::auto_path uses } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} {$p(:1:)} -- {{$p(:0:)} {$p(:1:)}} -- {{$p(:0:)} {$p(:3:)}} -- 0 1.2.3 0 2.3.4 --\ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ @@ -2672,12 +2672,12 @@ test safe-19.14 {when interpConfigure changes the access path, ::auto_path uses 0 OK1 0 OK2} # (no counterpart safe-9.15) test safe-19.15 {when interpConfigure changes the access path, ::auto_path uses -autoPath value and new tokens, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { # Test that although -autoPath is unchanged, the slave's ::auto_path changes to @@ -2724,7 +2724,7 @@ test safe-19.15 {when interpConfigure changes the access path, ::auto_path uses } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} -- {$p(:1:)} {$p(:2:)} {$p(:3:)} -- {{$p(:0:)}} -- {{$p(:0:)} {$p(:2:)} {$p(:3:)}} -- 0 1.2.3 0 2.3.4 --\ {TCLLIB TESTSDIR/auto0*} --\ @@ -2734,12 +2734,12 @@ test safe-19.15 {when interpConfigure changes the access path, ::auto_path uses 0 OK1 0 OK2} # (no counterpart safe-9.16) test safe-19.16 {default value for -accessPath and -autoPath on creation; -autoPath preserved when -accessPath changes, ::auto_path using changed tokens, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set tmpAutoPath $::auto_path set ::auto_path [list $tcl_library [file join $TestsDir auto0]] @@ -2780,7 +2780,7 @@ test safe-19.16 {default value for -accessPath and -autoPath on creation; -autoP } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:0:)} 2 --\ {{$p(:0:)} {$p(:1:)}} -- 0 1.2.3 1 {can't find package SafeTestPackage2} --\ @@ -2788,12 +2788,12 @@ test safe-19.16 {default value for -accessPath and -autoPath on creation; -autoP {TCLLIB TESTSDIR/auto0} -- {TCLLIB TESTSDIR/auto0} --\ 0 OK1 1 {invalid command name "HeresPackage2"}} test safe-19.20 {check module loading, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -2828,7 +2828,7 @@ test safe-19.20 {check module loading, Sync Mode off} -constraints AutoSyncDefin } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ 0 0.5 0 1.0 0 2.0 --\ @@ -2836,12 +2836,12 @@ test safe-19.20 {check module loading, Sync Mode off} -constraints AutoSyncDefin TESTSDIR/auto0/modules/mod2} -- res0 res1 res2} # See comments on lsort after test safe-9.20. test safe-19.21 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 1} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -2896,7 +2896,7 @@ test safe-19.21 {interpConfigure change the access path; check module loading, S } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ @@ -2908,12 +2908,12 @@ test safe-19.21 {interpConfigure change the access path; check module loading, S res0 res1 res2} # See comments on lsort after test safe-9.20. test safe-19.22 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 0} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -2963,7 +2963,7 @@ test safe-19.22 {interpConfigure change the access path; check module loading, S } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ @@ -2975,12 +2975,12 @@ test safe-19.22 {interpConfigure change the access path; check module loading, S res0 res1 res2} # See comments on lsort after test safe-9.20. test safe-19.23 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 3} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -3040,7 +3040,7 @@ test safe-19.23 {interpConfigure change the access path; check module loading, S } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ @@ -3052,12 +3052,12 @@ test safe-19.23 {interpConfigure change the access path; check module loading, S res0 res1 res2} # See comments on lsort after test safe-9.20. test safe-19.24 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 2 (worst case)} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -3112,7 +3112,7 @@ test safe-19.24 {interpConfigure change the access path; check module loading, S } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ @@ -3130,12 +3130,12 @@ test safe-19.24 {interpConfigure change the access path; check module loading, S set ::auto_path [list $tcl_library [file dirname $tcl_library] [file join $TestsDir auto0]] test safe-20.1 "create -accessPath NULL -autoPath NULL -> master's ::auto_path" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate] @@ -3143,16 +3143,16 @@ test safe-20.1 "create -accessPath NULL -autoPath NULL -> master's ::auto_path" } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result [list $::auto_path -- $::auto_path] test safe-20.2 "create -accessPath {} -autoPath NULL -> master's ::auto_path" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -accessPath {}] @@ -3160,16 +3160,16 @@ test safe-20.2 "create -accessPath {} -autoPath NULL -> master's ::auto_path" -c } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result [list $::auto_path -- $::auto_path] test safe-20.3 "create -accessPath path1 -autoPath NULL -> {}" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1]] @@ -3177,16 +3177,16 @@ test safe-20.3 "create -accessPath path1 -autoPath NULL -> {}" -constraints Auto } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {{} -- {}} test safe-20.4 "create -accessPath NULL -autoPath {} -> {}" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -autoPath {}] @@ -3194,16 +3194,16 @@ test safe-20.4 "create -accessPath NULL -autoPath {} -> {}" -constraints AutoSyn } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {{} -- {}} test safe-20.5 "create -accessPath {} -autoPath {} -> {}" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -accessPath {} -autoPath {}] @@ -3211,16 +3211,16 @@ test safe-20.5 "create -accessPath {} -autoPath {} -> {}" -constraints AutoSyncD } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {{} -- {}} test safe-20.6 "create -accessPath path1 -autoPath {} -> {}" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath {}] @@ -3228,16 +3228,16 @@ test safe-20.6 "create -accessPath path1 -autoPath {} -> {}" -constraints AutoSy } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {{} -- {}} test safe-20.7 "create -accessPath NULL -autoPath path2 -> path2" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -autoPath [lrange $::auto_path 0 0]] @@ -3245,16 +3245,16 @@ test safe-20.7 "create -accessPath NULL -autoPath path2 -> path2" -constraints A } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]] test safe-20.8 "create -accessPath {} -autoPath path2 -> path2" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -accessPath {} -autoPath [lrange $::auto_path 0 0]] @@ -3262,16 +3262,16 @@ test safe-20.8 "create -accessPath {} -autoPath path2 -> path2" -constraints Aut } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]] test safe-20.9 "create -accessPath path1 -autoPath path2 -> path2" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] @@ -3279,16 +3279,16 @@ test safe-20.9 "create -accessPath path1 -autoPath path2 -> path2" -constraints } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]] test safe-20.10 "create -accessPath NULL -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -autoPath /not/in/access/path] @@ -3296,16 +3296,16 @@ test safe-20.10 "create -accessPath NULL -autoPath pathX -> pathX" -constraints } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {/not/in/access/path -- {}} test safe-20.11 "create -accessPath {} -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -accessPath {} -autoPath /not/in/access/path] @@ -3313,16 +3313,16 @@ test safe-20.11 "create -accessPath {} -autoPath pathX -> pathX" -constraints Au } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {/not/in/access/path -- {}} test safe-20.12 "create -accessPath path1 -autoPath pathX -> {pathX}" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath /not/in/access/path] @@ -3330,19 +3330,19 @@ test safe-20.12 "create -accessPath path1 -autoPath pathX -> {pathX}" -constrain } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {/not/in/access/path -- {}} ### 21. safe::interpConfigure with different cases of -accessPath, -autoPath. test safe-21.1 "interpConfigure -accessPath NULL -autoPath NULL -> no change" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] } -body { @@ -3351,16 +3351,16 @@ test safe-21.1 "interpConfigure -accessPath NULL -autoPath NULL -> no change" -c } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]] test safe-21.2 "interpConfigure -accessPath {} -autoPath NULL -> master's ::auto_path" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] } -body { @@ -3369,16 +3369,16 @@ test safe-21.2 "interpConfigure -accessPath {} -autoPath NULL -> master's ::auto } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result [list $::auto_path -- $::auto_path] test safe-21.3 "interpConfigure -accessPath path1 -autoPath NULL -> no change" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] } -body { @@ -3387,16 +3387,16 @@ test safe-21.3 "interpConfigure -accessPath path1 -autoPath NULL -> no change" - } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result [list [lrange $::auto_path 0 0] -- [lrange $::auto_path 0 0]] test safe-21.4 "interpConfigure -accessPath NULL -autoPath {} -> {}" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] } -body { @@ -3405,16 +3405,16 @@ test safe-21.4 "interpConfigure -accessPath NULL -autoPath {} -> {}" -constraint } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {{} -- {}} test safe-21.5 "interpConfigure -accessPath {} -autoPath {} -> {}" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] } -body { @@ -3423,16 +3423,16 @@ test safe-21.5 "interpConfigure -accessPath {} -autoPath {} -> {}" -constraints } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {{} -- {}} test safe-21.6 "interpConfigure -accessPath {path1} -autoPath {} -> {}" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] } -body { @@ -3441,16 +3441,16 @@ test safe-21.6 "interpConfigure -accessPath {path1} -autoPath {} -> {}" -constra } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {{} -- {}} test safe-21.7 "interpConfigure -accessPath NULL -autoPath path2 -> path2" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] } -body { @@ -3459,16 +3459,16 @@ test safe-21.7 "interpConfigure -accessPath NULL -autoPath path2 -> path2" -cons } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result [list [lrange $::auto_path 1 1] -- [lrange $::auto_path 1 1]] test safe-21.8 "interpConfigure -accessPath {} -autoPath path2 -> path2" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] } -body { @@ -3477,16 +3477,16 @@ test safe-21.8 "interpConfigure -accessPath {} -autoPath path2 -> path2" -constr } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result [list [lrange $::auto_path 1 1] -- [lrange $::auto_path 1 1]] test safe-21.9 "interpConfigure -accessPath path1 -autoPath path2 -> path2" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] } -body { @@ -3495,16 +3495,16 @@ test safe-21.9 "interpConfigure -accessPath path1 -autoPath path2 -> path2" -con } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result [list [lrange $::auto_path 1 1] -- [lrange $::auto_path 1 1]] test safe-21.10 "interpConfigure -accessPath NULL -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] } -body { @@ -3513,16 +3513,16 @@ test safe-21.10 "interpConfigure -accessPath NULL -autoPath pathX -> pathX" -con } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {/not/in/access/path -- {}} test safe-21.11 "interpConfigure -accessPath {} -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] } -body { @@ -3531,16 +3531,16 @@ test safe-21.11 "interpConfigure -accessPath {} -autoPath pathX -> pathX" -const } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {/not/in/access/path -- {}} test safe-21.12 "interpConfigure -accessPath path1 -autoPath pathX -> pathX" -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set i [safe::interpCreate -accessPath [lrange $::auto_path 0 1] -autoPath [lrange $::auto_path 0 0]] } -body { @@ -3549,7 +3549,7 @@ test safe-21.12 "interpConfigure -accessPath path1 -autoPath pathX -> pathX" -co } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {/not/in/access/path -- {}} -- cgit v0.12 From f2815760c5d26291fa3af7efe04b78a40743415e Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 25 Jul 2020 12:15:14 +0000 Subject: Rearrange tests in safe.test so they are in numerical order. --- tests/safe.test | 433 ++++++++++++++++++++++++++++---------------------------- 1 file changed, 215 insertions(+), 218 deletions(-) diff --git a/tests/safe.test b/tests/safe.test index d28c093..8959523 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1726,6 +1726,118 @@ test safe-14.1 {Check that module path is the same as in the master interpreter } -cleanup { safe::interpDelete $i } -result [::tcl::tm::path list] +test safe-14.2 {Check that first element of slave auto_path (and access path) is Tcl Library, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib1 $lib2] + + set i [safe::interpCreate] +} -body { + set autoList {} + set token [lindex [$i eval set ::auto_path] 0] + set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] + set accessList [lindex [safe::interpConfigure $i -accessPath] 1] + return [list [lindex $accessList 0] $auto0] +} -cleanup { + set ::auto_path $::auto_TMP + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result [list [info library] [info library]] +test safe-14.2.1 {Check that first element of slave auto_path (and access path) is Tcl Library, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib1 $lib2] + + set i [safe::interpCreate] +} -body { + set autoList {} + set token [lindex [$i eval set ::auto_path] 0] + set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] + set accessList [lindex [safe::interpConfigure $i -accessPath] 1] + return [list [lindex $accessList 0] $auto0] +} -cleanup { + set ::auto_path $::auto_TMP + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result [list [info library] [info library]] +test safe-14.3 {Check that first element of slave auto_path (and access path) is Tcl Library, even if not true for master, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib2 $lib1] + # Unexpected order, should be reversed in the slave + + set i [safe::interpCreate] +} -body { + set autoList {} + set token [lindex [$i eval set ::auto_path] 0] + set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] + set accessList [lindex [safe::interpConfigure $i -accessPath] 1] + + return [list [lindex $accessList 0] $auto0] +} -cleanup { + set ::auto_path $::auto_TMP + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result [list [info library] [info library]] +test safe-14.3.1 {Check that first element of slave auto_path (and access path) is Tcl Library, even if not true for master, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + + set lib1 [info library] + set lib2 [file dirname $lib1] + set ::auto_TMP $::auto_path + set ::auto_path [list $lib2 $lib1] + # Unexpected order, should be reversed in the slave + + set i [safe::interpCreate] +} -body { + set autoList {} + set token [lindex [$i eval set ::auto_path] 0] + set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] + set accessList [lindex [safe::interpConfigure $i -accessPath] 1] + + return [list [lindex $accessList 0] $auto0] +} -cleanup { + set ::auto_path $::auto_TMP + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result [list [info library] [info library]] ### 15. Safe file ensemble. @@ -1864,121 +1976,6 @@ test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup unset user } -result {~USER} -### 14.x move above. - -test safe-14.2 {Check that first element of slave auto_path (and access path) is Tcl Library, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 - } - - set lib1 [info library] - set lib2 [file dirname $lib1] - set ::auto_TMP $::auto_path - set ::auto_path [list $lib1 $lib2] - - set i [safe::interpCreate] -} -body { - set autoList {} - set token [lindex [$i eval set ::auto_path] 0] - set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] - set accessList [lindex [safe::interpConfigure $i -accessPath] 1] - return [list [lindex $accessList 0] $auto0] -} -cleanup { - set ::auto_path $::auto_TMP - safe::interpDelete $i - if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP - } -} -result [list [info library] [info library]] -test safe-14.2.1 {Check that first element of slave auto_path (and access path) is Tcl Library, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 - } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} - } - - set lib1 [info library] - set lib2 [file dirname $lib1] - set ::auto_TMP $::auto_path - set ::auto_path [list $lib1 $lib2] - - set i [safe::interpCreate] -} -body { - set autoList {} - set token [lindex [$i eval set ::auto_path] 0] - set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] - set accessList [lindex [safe::interpConfigure $i -accessPath] 1] - return [list [lindex $accessList 0] $auto0] -} -cleanup { - set ::auto_path $::auto_TMP - safe::interpDelete $i - if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP - } -} -result [list [info library] [info library]] -test safe-14.3 {Check that first element of slave auto_path (and access path) is Tcl Library, even if not true for master, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 - } - - set lib1 [info library] - set lib2 [file dirname $lib1] - set ::auto_TMP $::auto_path - set ::auto_path [list $lib2 $lib1] - # Unexpected order, should be reversed in the slave - - set i [safe::interpCreate] -} -body { - set autoList {} - set token [lindex [$i eval set ::auto_path] 0] - set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] - set accessList [lindex [safe::interpConfigure $i -accessPath] 1] - - return [list [lindex $accessList 0] $auto0] -} -cleanup { - set ::auto_path $::auto_TMP - safe::interpDelete $i - if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP - } -} -result [list [info library] [info library]] -test safe-14.3.1 {Check that first element of slave auto_path (and access path) is Tcl Library, even if not true for master, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 - } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} - } - - set lib1 [info library] - set lib2 [file dirname $lib1] - set ::auto_TMP $::auto_path - set ::auto_path [list $lib2 $lib1] - # Unexpected order, should be reversed in the slave - - set i [safe::interpCreate] -} -body { - set autoList {} - set token [lindex [$i eval set ::auto_path] 0] - set auto0 [dict get [set ::safe::S${i}(access_path,map)] $token] - set accessList [lindex [safe::interpConfigure $i -accessPath] 1] - - return [list [lindex $accessList 0] $auto0] -} -cleanup { - set ::auto_path $::auto_TMP - safe::interpDelete $i - if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP - } -} -result [list [info library] [info library]] - ### 17. Test the use of ::auto_path for loading commands (via tclIndex files) ### and non-module packages (via pkgIndex.tcl files). ### Corresponding tests with Sync Mode on are 7.* @@ -2142,6 +2139,109 @@ test safe-17.5 {cf. safe-7.5 - positive and negative module package require, inc } } -result {1 {can't find package test1} 0} +### 18. Test tokenization of directories available to a slave. + +test safe-18.1 {Check that each directory of the default auto_path is a valid token, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + set i [safe::interpCreate] +} -body { + set badTokens {} + foreach dir [$i eval {set ::auto_path}] { + if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { + # Match - OK - token has expected form + } else { + # No match - possibly an ordinary path has not been tokenized + lappend badTokens $dir + } + } + set badTokens +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {} +test safe-18.1.1 {Check that each directory of the default auto_path is a valid token, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set i [safe::interpCreate] +} -body { + set badTokens {} + foreach dir [$i eval {set ::auto_path}] { + if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { + # Match - OK - token has expected form + } else { + # No match - possibly an ordinary path has not been tokenized + lappend badTokens $dir + } + } + set badTokens +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {} +test safe-18.2 {Check that each directory of the module path is a valid token, Sync Mode on} -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 1 + } + set i [safe::interpCreate] +} -body { + set badTokens {} + foreach dir [$i eval {::tcl::tm::path list}] { + if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { + # Match - OK - token has expected form + } else { + # No match - possibly an ordinary path has not been tokenized + lappend badTokens $dir + } + } + set badTokens +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {} +test safe-18.2.1 {Check that each directory of the module path is a valid token, Sync Mode off} -constraints AutoSyncDefined -setup { + set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + if {$SyncExists} { + set SyncVal_TMP [safe::setAutoPathSync] + safe::setAutoPathSync 0 + } else { + error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + } + set i [safe::interpCreate] +} -body { + set badTokens {} + foreach dir [$i eval {::tcl::tm::path list}] { + if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { + # Match - OK - token has expected form + } else { + # No match - possibly an ordinary path has not been tokenized + lappend badTokens $dir + } + } + set badTokens +} -cleanup { + safe::interpDelete $i + if {$SyncExists} { + safe::setAutoPathSync $SyncVal_TMP + } +} -result {} + ### 19. Assorted options, including changes to option values. ### Mostly these are changes to access path, auto_path, module path. ### If Sync Mode is on, a corresponding test with Sync Mode off is 9.* @@ -2788,109 +2888,6 @@ test safe-19.24 {interpConfigure change the access path; check module loading, S TESTSDIR/auto0/modules/mod1 TESTSDIR/auto0/modules/mod2} --\ res0 res1 res2} # See comments on lsort after test safe-9.20. - -### 18. Test tokenization of directories available to a slave. - -test safe-18.1 {Check that each directory of the default auto_path is a valid token, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 - } - set i [safe::interpCreate] -} -body { - set badTokens {} - foreach dir [$i eval {set ::auto_path}] { - if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { - # Match - OK - token has expected form - } else { - # No match - possibly an ordinary path has not been tokenized - lappend badTokens $dir - } - } - set badTokens -} -cleanup { - safe::interpDelete $i - if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP - } -} -result {} -test safe-18.1.1 {Check that each directory of the default auto_path is a valid token, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 - } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} - } - set i [safe::interpCreate] -} -body { - set badTokens {} - foreach dir [$i eval {set ::auto_path}] { - if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { - # Match - OK - token has expected form - } else { - # No match - possibly an ordinary path has not been tokenized - lappend badTokens $dir - } - } - set badTokens -} -cleanup { - safe::interpDelete $i - if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP - } -} -result {} -test safe-18.2 {Check that each directory of the module path is a valid token, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 - } - set i [safe::interpCreate] -} -body { - set badTokens {} - foreach dir [$i eval {::tcl::tm::path list}] { - if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { - # Match - OK - token has expected form - } else { - # No match - possibly an ordinary path has not been tokenized - lappend badTokens $dir - } - } - set badTokens -} -cleanup { - safe::interpDelete $i - if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP - } -} -result {} -test safe-18.2.1 {Check that each directory of the module path is a valid token, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] - if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 - } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} - } - set i [safe::interpCreate] -} -body { - set badTokens {} - foreach dir [$i eval {::tcl::tm::path list}] { - if {[regexp {^\$p\(:[0-9]+:\)$} $dir]} { - # Match - OK - token has expected form - } else { - # No match - possibly an ordinary path has not been tokenized - lappend badTokens $dir - } - } - set badTokens -} -cleanup { - safe::interpDelete $i - if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP - } -} -result {} # cleanup set ::auto_path $SaveAutoPath -- cgit v0.12 From 0d094ff62aa60c15d6afecdc694e910646c813cf Mon Sep 17 00:00:00 2001 From: kjnash Date: Sat, 25 Jul 2020 12:24:26 +0000 Subject: Rename command safe::setAutoPathSync to safe::setSyncMode. --- doc/safe.n | 6 +- library/safe.tcl | 12 +- library/tclIndex | 2 +- tests/safe-stock87.test | 88 ++++++------ tests/safe-zipfs.test | 134 +++++++++--------- tests/safe.test | 370 ++++++++++++++++++++++++------------------------ 6 files changed, 306 insertions(+), 306 deletions(-) diff --git a/doc/safe.n b/doc/safe.n index 5777f74..7bae0be 100644 --- a/doc/safe.n +++ b/doc/safe.n @@ -23,7 +23,7 @@ safe \- Creating and manipulating safe interpreters .sp \fB::safe::interpFindInAccessPath\fR \fIslave\fR \fIdirectory\fR .sp -\fB::safe::setAutoPathSync\fR ?\fInewValue\fR? +\fB::safe::setSyncMode\fR ?\fInewValue\fR? .sp \fB::safe::setLogCmd\fR ?\fIcmd arg...\fR? .SS OPTIONS @@ -151,7 +151,7 @@ $slave eval [list set tk_library \e .CE .RE .TP -\fB::safe::setAutoPathSync\fR ?\fInewValue\fR? +\fB::safe::setSyncMode\fR ?\fInewValue\fR? This command is used to get or set the "Sync Mode" of the Safe Base. When an argument is supplied, the command returns an error if the argument is not a boolean value, or if any Safe Base interpreters exist. Typically @@ -392,7 +392,7 @@ of the ::auto_path and access path ("Sync Mode" on) is still the default. However, the Safe Base offers the option of limiting the safe interpreter's ::auto_path to the much shorter list of directories that is necessary for it to perform its function ("Sync Mode" off). Use the command -\fB::safe::setAutoPathSync\fR to choose the mode before creating any Safe +\fB::safe::setSyncMode\fR to choose the mode before creating any Safe Base interpreters. .PP In either mode, the most convenient way to initialize a safe interpreter is diff --git a/library/safe.tcl b/library/safe.tcl index d7b0966..f17d854 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -349,7 +349,7 @@ proc ::safe::InterpCreate { # # It is the caller's responsibility, if it supplies a non-empty value for # access_path, to make the first directory in the path suitable for use as -# tcl_library, and (if ![setAutoPathSync]), to set the slave's ::auto_path. +# tcl_library, and (if ![setSyncMode]), to set the slave's ::auto_path. proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook autoPath withAutoPath} { global auto_path @@ -422,9 +422,9 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook au # Set the slave auto_path to a tokenized raw_auto_path. # Silently ignore any directories that are not in the access path. - # If [setAutoPathSync], SyncAccessPath will overwrite this value with the + # If [setSyncMode], SyncAccessPath will overwrite this value with the # full access path. - # If ![setAutoPathSync], Safe Base code will not change this value. + # If ![setSyncMode], Safe Base code will not change this value. set tokens_auto_path {} foreach dir $raw_auto_path { if {[dict exists $remap_access_path $dir]} { @@ -1355,7 +1355,7 @@ proc ::safe::Setup {} { } # Accessor method for ::safe::AutoPathSync -# Usage: ::safe::setAutoPathSync ?newValue? +# Usage: ::safe::setSyncMode ?newValue? # Respond to changes by calling Setup again, preserving any # caller-defined logging. This allows complete equivalence with # prior Safe Base behavior if AutoPathSync is true. @@ -1368,7 +1368,7 @@ proc ::safe::Setup {} { # (The initialization of AutoPathSync at the end of this file is acceptable # because Setup has not yet been called.) -proc ::safe::setAutoPathSync {args} { +proc ::safe::setSyncMode {args} { variable AutoPathSync if {[llength $args] == 0} { @@ -1391,7 +1391,7 @@ proc ::safe::setAutoPathSync {args} { setLogCmd $TmpLog } } else { - set msg {wrong # args: should be "safe::setAutoPathSync ?newValue?"} + set msg {wrong # args: should be "safe::setSyncMode ?newValue?"} return -code error $msg } diff --git a/library/tclIndex b/library/tclIndex index 731bdbb..a8db3cb 100644 --- a/library/tclIndex +++ b/library/tclIndex @@ -61,7 +61,7 @@ set auto_index(::safe::DirInAccessPath) [list ::tcl::Pkg::source [file join $dir set auto_index(::safe::Subset) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::AliasSubset) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(::safe::AliasEncoding) [list ::tcl::Pkg::source [file join $dir safe.tcl]] -set auto_index(::safe::setAutoPathSync) [list source [file join $dir safe.tcl]] +set auto_index(::safe::setSyncMode) [list ::tcl::Pkg::source [file join $dir safe.tcl]] set auto_index(tcl_wordBreakAfter) [list ::tcl::Pkg::source [file join $dir word.tcl]] set auto_index(tcl_wordBreakBefore) [list ::tcl::Pkg::source [file join $dir word.tcl]] set auto_index(tcl_endOfWord) [list ::tcl::Pkg::source [file join $dir word.tcl]] diff --git a/tests/safe-stock87.test b/tests/safe-stock87.test index 1a29018..c36792c 100644 --- a/tests/safe-stock87.test +++ b/tests/safe-stock87.test @@ -111,10 +111,10 @@ testConstraint AutoSyncDefined 1 # high level general test test safe-stock87-7.1 {tests that everything works at high level with conventional AutoPathSync, use pkg opt} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set i [safe::interpCreate] } -body { @@ -128,14 +128,14 @@ test safe-stock87-7.1 {tests that everything works at high level with convention } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result 0.4.* test safe-stock87-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync, use pkg opt} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } else { set SyncVal_TMP 1 } @@ -154,15 +154,15 @@ test safe-stock87-7.2 {tests specific path and interpFind/AddToAccessPath with c $mappA -- [safe::interpDelete $i] } -cleanup { if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result "{\$p(:0:)} {\$p(:*:)} -- 1 {$pkgOptErrMsg} --\ {TCLLIB */dummy/unixlike/test/path} -- {}" test safe-stock87-7.4 {tests specific path and positive search with conventional AutoPathSync, use pkg opt} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } else { set SyncVal_TMP 1 } @@ -182,15 +182,15 @@ test safe-stock87-7.4 {tests specific path and positive search with conventional # other than the first and last in the access path. } -cleanup { if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 0.4.* --\ {TCLLIB * TCLLIB/OPTDIR} -- {}} test safe-stock87-7.5 {tests positive and negative module loading with conventional AutoPathSync} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set i [safe::interpCreate] interp eval $i { @@ -207,7 +207,7 @@ test safe-stock87-7.5 {tests positive and negative module loading with conventio } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {1 {can't find package shell} 0} @@ -222,10 +222,10 @@ test safe-stock87-9.8 {test auto-loading in safe interpreters, was safe-5.1} -se safe::interpDelete a } -result -1 test safe-stock87-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement with conventional AutoPathSync, uses pkg opt and tcl::idna} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -262,17 +262,17 @@ test safe-stock87-9.11 {interpConfigure change the access path; pkgIndex.tcl pac } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 1.* 0 0.4.* --\ {TCLLIB TCLLIB/OPTDIR TCLLIB/JARDIR*} --\ {TCLLIB TCLLIB/JARDIR TCLLIB/OPTDIR*} --\ 0 0 0 example.com} test safe-stock87-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed with conventional AutoPathSync, uses pkg opt and tcl::idna} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -305,19 +305,19 @@ test safe-stock87-9.13 {interpConfigure change the access path; pkgIndex.tcl pac } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\ 1 {* not found in access path} -- 1 1 --\ {TCLLIB TCLLIB/OPTDIR TCLLIB/JARDIR*} -- {TCLLIB*}} test safe-stock87-18.1 {cf. safe-stock87-7.1opt - tests that everything works at high level without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } # Without AutoPathSync, we need a more complete auto_path, # because the slave will use the same value. @@ -339,16 +339,16 @@ test safe-stock87-18.1 {cf. safe-stock87-7.1opt - tests that everything works at } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result 0.4.* test safe-stock87-18.2 {cf. safe-stock87-7.2opt - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] @@ -366,18 +366,18 @@ test safe-stock87-18.2 {cf. safe-stock87-7.2opt - tests specific path and interp [safe::interpDelete $i] } -cleanup { if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result "{} {\$p(:0:)} {\$p(:*:)} 1 {$pkgOptErrMsg}\ {-accessPath {[list $tcl_library */dummy/unixlike/test/path]}\ -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" test safe-stock87-18.4 {cf. safe-stock87-7.4opt - tests specific path and positive search and auto_path without conventional AutoPathSync, use pkg opt} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] @@ -403,18 +403,18 @@ test safe-stock87-18.4 {cf. safe-stock87-7.4opt - tests specific path and positi [safe::interpDelete $i] } -cleanup { if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} 0 0.4.*\ {-accessPath {[list $tcl_library *$tcl_library/$pkgOptDir]}\ -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" test safe-stock87-18.5 {cf. safe-stock87-7.5 - tests positive and negative module loading without conventional AutoPathSync} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set i [safe::interpCreate] interp eval $i { @@ -431,7 +431,7 @@ test safe-stock87-18.5 {cf. safe-stock87-7.5 - tests positive and negative modul } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {1 {can't find package shell} 0} diff --git a/tests/safe-zipfs.test b/tests/safe-zipfs.test index 4ec01d1..7594e3a 100644 --- a/tests/safe-zipfs.test +++ b/tests/safe-zipfs.test @@ -174,10 +174,10 @@ test safe-zipfs-5.6 {example modules packages, test in master interpreter, appen # high level general test # Use zipped example packages not http1.0 etc test safe-zipfs-7.1 {tests that everything works at high level with conventional AutoPathSync; zipfs} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set tmpAutoPath $::auto_path lappend ::auto_path [file join $ZipMountPoint auto0] @@ -194,14 +194,14 @@ test safe-zipfs-7.1 {tests that everything works at high level with conventional } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result 1.2.3 test safe-zipfs-7.2 {tests specific path and interpFind/AddToAccessPath with conventional AutoPathSync; zipfs} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } else { set SyncVal_TMP 1 } @@ -222,16 +222,16 @@ test safe-zipfs-7.2 {tests specific path and interpFind/AddToAccessPath with con $mappA -- [safe::interpDelete $i] } -cleanup { if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:0:)} {$p(:*:)} {$p(:*:)} --\ 1 {can't find package SafeTestPackage1} --\ {TCLLIB */dummy/unixlike/test/path ZIPDIR/auto0} -- {}} test safe-zipfs-7.4 {tests specific path and positive search with conventional AutoPathSync; zipfs} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } else { set SyncVal_TMP 1 } @@ -251,16 +251,16 @@ test safe-zipfs-7.4 {tests specific path and positive search with conventional A # other than the first and last in the access path. } -cleanup { if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\ {TCLLIB * ZIPDIR/auto0/auto1} -- {}} test safe-zipfs-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset) with conventional AutoPathSync; zipfs} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -298,16 +298,16 @@ test safe-zipfs-9.9 {interpConfigure change the access path; tclIndex commands u } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\ {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\ {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*}} test safe-zipfs-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset) with conventional AutoPathSync; zipfs} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -343,17 +343,17 @@ test safe-zipfs-9.10 {interpConfigure change the access path; tclIndex commands } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ 0 ok1 0 ok2 --\ {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\ {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*}} test safe-zipfs-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement with conventional AutoPathSync; zipfs} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { # For complete correspondence to safe-stock87-9.11, include auto0 in access path. @@ -395,17 +395,17 @@ test safe-zipfs-9.11 {interpConfigure change the access path; pkgIndex.tcl packa } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\ {TCLLIB ZIPDIR/auto0 ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} --\ {TCLLIB ZIPDIR/auto0 ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*} --\ 0 OK1 0 OK2} test safe-zipfs-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, 9.10 without path auto0 with conventional AutoPathSync; zipfs} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -441,7 +441,7 @@ test safe-zipfs-9.12 {interpConfigure change the access path; pkgIndex.tcl packa } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ 0 1.2.3 0 2.3.4 --\ @@ -449,10 +449,10 @@ test safe-zipfs-9.12 {interpConfigure change the access path; pkgIndex.tcl packa {TCLLIB ZIPDIR/auto0/auto2 ZIPDIR/auto0/auto1*} --\ 0 OK1 0 OK2} test safe-zipfs-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, with conventional AutoPathSync; zipfs} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -485,16 +485,16 @@ test safe-zipfs-9.13 {interpConfigure change the access path; pkgIndex.tcl packa } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\ 1 {* not found in access path} -- 1 1 --\ {TCLLIB ZIPDIR/auto0/auto1 ZIPDIR/auto0/auto2*} -- {TCLLIB*}} test safe-zipfs-9.20 {check module loading, with conventional AutoPathSync; zipfs} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -529,7 +529,7 @@ test safe-zipfs-9.20 {check module loading, with conventional AutoPathSync; zipf } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ 0 0.5 0 1.0 0 2.0 --\ @@ -545,10 +545,10 @@ test safe-zipfs-9.20 {check module loading, with conventional AutoPathSync; zipf # comparing with expected results. The test is therefore not totally strict, # but will notice missing or surplus directories. test safe-zipfs-9.21 {interpConfigure change the access path; check module loading, with conventional AutoPathSync; stale data case 1; zipfs} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -603,7 +603,7 @@ test safe-zipfs-9.21 {interpConfigure change the access path; check module loadi } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ @@ -615,10 +615,10 @@ test safe-zipfs-9.21 {interpConfigure change the access path; check module loadi res0 res1 res2} # See comments on lsort after test safe-zipfs-9.20. test safe-zipfs-9.22 {interpConfigure change the access path; check module loading, with conventional AutoPathSync; stale data case 0; zipfs} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -668,7 +668,7 @@ test safe-zipfs-9.22 {interpConfigure change the access path; check module loadi } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ @@ -680,10 +680,10 @@ test safe-zipfs-9.22 {interpConfigure change the access path; check module loadi res0 res1 res2} # See comments on lsort after test safe-zipfs-9.20. test safe-zipfs-9.23 {interpConfigure change the access path; check module loading, with conventional AutoPathSync; stale data case 3; zipfs} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -743,7 +743,7 @@ test safe-zipfs-9.23 {interpConfigure change the access path; check module loadi } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ @@ -755,10 +755,10 @@ test safe-zipfs-9.23 {interpConfigure change the access path; check module loadi res0 res1 res2} # See comments on lsort after test safe-zipfs-9.20. test safe-zipfs-9.24 {interpConfigure change the access path; check module loading, with conventional AutoPathSync; stale data case 2 (worst case); zipfs} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -813,7 +813,7 @@ test safe-zipfs-9.24 {interpConfigure change the access path; check module loadi } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ @@ -826,12 +826,12 @@ test safe-zipfs-9.24 {interpConfigure change the access path; check module loadi # See comments on lsort after test safe-zipfs-9.20. test safe-zipfs-18.1 {cf. safe-zipfs-7.1 - tests that everything works at high level without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } # Without AutoPathSync, we need a more complete auto_path, # because the slave will use the same value. @@ -853,16 +853,16 @@ test safe-zipfs-18.1 {cf. safe-zipfs-7.1 - tests that everything works at high l } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result 1.2.3 test safe-zipfs-18.2 {cf. safe-zipfs-7.2 - tests specific path and interpFind/AddToAccessPath without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] @@ -882,7 +882,7 @@ test safe-zipfs-18.2 {cf. safe-zipfs-7.2 - tests specific path and interpFind/Ad [safe::interpDelete $i] } -cleanup { if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result "{} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)}\ 1 {can't find package SafeTestPackage1}\ @@ -891,12 +891,12 @@ test safe-zipfs-18.2 {cf. safe-zipfs-7.2 - tests specific path and interpFind/Ad $ZipMountPoint/auto0]}\ -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" test safe-zipfs-18.4 {cf. safe-zipfs-7.4 - tests specific path and positive search and auto_path without conventional AutoPathSync; zipfs} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] @@ -927,7 +927,7 @@ test safe-zipfs-18.4 {cf. safe-zipfs-7.4 - tests specific path and positive sear [safe::interpDelete $i] } -cleanup { if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 0 1.2.3\ {-accessPath {[list $tcl_library *$ZipMountPoint/auto0 $ZipMountPoint/auto0/auto1]}\ diff --git a/tests/safe.test b/tests/safe.test index 8959523..16fa94f 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -68,10 +68,10 @@ test safe-1.1 {safe::interpConfigure syntax} -returnCodes error -body { } -result {no value given for parameter "slave" (use -help for full usage) : slave name () name of the slave} test safe-1.2 {safe::interpCreate syntax, Sync Mode on} -returnCodes error -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } else { set SyncVal_TMP 1 } @@ -79,7 +79,7 @@ test safe-1.2 {safe::interpCreate syntax, Sync Mode on} -returnCodes error -setu safe::interpCreate -help } -cleanup { if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {Usage information: Var/FlagName Type Value Help @@ -93,18 +93,18 @@ test safe-1.2 {safe::interpCreate syntax, Sync Mode on} -returnCodes error -setu -nested boolean (false) nested loading -deleteHook script () delete hook} test safe-1.2.1 {safe::interpCreate syntax, Sync Mode off} -returnCodes error -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { safe::interpCreate -help } -cleanup { if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {Usage information: Var/FlagName Type Value Help @@ -368,10 +368,10 @@ rename SafeEval {} ### Corresponding tests with Sync Mode off are 17.* test safe-7.1 {positive non-module package require, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set tmpAutoPath $::auto_path lappend ::auto_path [file join $TestsDir auto0] @@ -388,14 +388,14 @@ test safe-7.1 {positive non-module package require, Sync Mode on} -setup { } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result 1.2.3 test safe-7.2 {negative non-module package require with specific path and interpAddToAccessPath, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } else { set SyncVal_TMP 1 } @@ -415,7 +415,7 @@ test safe-7.2 {negative non-module package require with specific path and interp $mappA -- [safe::interpDelete $i] } -cleanup { if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:0:)} {$p(:*:)} {$p(:*:)} --\ 1 {can't find package SafeTestPackage1} --\ @@ -452,10 +452,10 @@ test safe-7.3.1 {check that safe subinterpreters work with namespace names} -set [interp exists $j] [info vars ::safe::S*] } -match glob -result {{} {} ok ok {} 0 {}} test safe-7.4 {positive non-module package require with specific path and interpAddToAccessPath, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } else { set SyncVal_TMP 1 } @@ -475,15 +475,15 @@ test safe-7.4 {positive non-module package require with specific path and interp # other than the first and last in the access path. } -cleanup { if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:0:)} {$p(:*:)} -- 0 1.2.3 --\ {TCLLIB * TESTSDIR/auto0/auto1} -- {}} test safe-7.5 {positive and negative module package require, including ancestor directory issue, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } tcl::tm::path add [file join $TestsDir auto0 modules] set i [safe::interpCreate] @@ -501,7 +501,7 @@ test safe-7.5 {positive and negative module package require, including ancestor } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {1 {can't find package test1} 0} @@ -757,10 +757,10 @@ test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\ {-accessPath * -statics 0 -nested 0 -deleteHook toto}} test safe-9.8 {autoloading commands indexed in tclIndex files, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -780,15 +780,15 @@ test safe-9.8 {autoloading commands indexed in tclIndex files, Sync Mode on} -se } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*}} test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset), Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -826,16 +826,16 @@ test safe-9.9 {interpConfigure change the access path; tclIndex commands unaffec } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} test safe-9.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset), Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -871,17 +871,17 @@ test safe-9.10 {interpConfigure change the access path; tclIndex commands unaffe } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { # For complete correspondence to safe-9.10opt, include auto0 in access path. @@ -923,17 +923,17 @@ test safe-9.11 {interpConfigure change the access path; pkgIndex.tcl packages un } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ 0 OK1 0 OK2} test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, safe-9.11 without path auto0, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -970,7 +970,7 @@ test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages un } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ 0 1.2.3 0 2.3.4 --\ @@ -978,10 +978,10 @@ test safe-9.12 {interpConfigure change the access path; pkgIndex.tcl packages un {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ 0 OK1 0 OK2} test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -1014,16 +1014,16 @@ test safe-9.13 {interpConfigure change the access path; pkgIndex.tcl packages fa } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- 1 {* not found in access path} --\ 1 {* not found in access path} -- 1 1 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} -- {TCLLIB*}} test safe-9.20 {check module loading, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -1058,7 +1058,7 @@ test safe-9.20 {check module loading, Sync Mode on} -setup { } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ 0 0.5 0 1.0 0 2.0 --\ @@ -1074,10 +1074,10 @@ test safe-9.20 {check module loading, Sync Mode on} -setup { # comparing with expected results. The test is therefore not totally strict, # but will notice missing or surplus directories. test safe-9.21 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 1} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -1132,7 +1132,7 @@ test safe-9.21 {interpConfigure change the access path; check module loading, Sy } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ @@ -1144,10 +1144,10 @@ test safe-9.21 {interpConfigure change the access path; check module loading, Sy res0 res1 res2} # See comments on lsort after test safe-9.20. test safe-9.22 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 0} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -1197,7 +1197,7 @@ test safe-9.22 {interpConfigure change the access path; check module loading, Sy } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ @@ -1209,10 +1209,10 @@ test safe-9.22 {interpConfigure change the access path; check module loading, Sy res0 res1 res2} # See comments on lsort after test safe-9.20. test safe-9.23 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 3} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -1272,7 +1272,7 @@ test safe-9.23 {interpConfigure change the access path; check module loading, Sy } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ @@ -1284,10 +1284,10 @@ test safe-9.23 {interpConfigure change the access path; check module loading, Sy res0 res1 res2} # See comments on lsort after test safe-9.20. test safe-9.24 {interpConfigure change the access path; check module loading, Sync Mode on; stale data case 2 (worst case)} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -1342,7 +1342,7 @@ test safe-9.24 {interpConfigure change the access path; check module loading, Sy } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ @@ -1727,10 +1727,10 @@ test safe-14.1 {Check that module path is the same as in the master interpreter safe::interpDelete $i } -result [::tcl::tm::path list] test safe-14.2 {Check that first element of slave auto_path (and access path) is Tcl Library, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set lib1 [info library] @@ -1749,16 +1749,16 @@ test safe-14.2 {Check that first element of slave auto_path (and access path) is set ::auto_path $::auto_TMP safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result [list [info library] [info library]] test safe-14.2.1 {Check that first element of slave auto_path (and access path) is Tcl Library, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set lib1 [info library] @@ -1777,14 +1777,14 @@ test safe-14.2.1 {Check that first element of slave auto_path (and access path) set ::auto_path $::auto_TMP safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result [list [info library] [info library]] test safe-14.3 {Check that first element of slave auto_path (and access path) is Tcl Library, even if not true for master, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set lib1 [info library] @@ -1805,16 +1805,16 @@ test safe-14.3 {Check that first element of slave auto_path (and access path) is set ::auto_path $::auto_TMP safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result [list [info library] [info library]] test safe-14.3.1 {Check that first element of slave auto_path (and access path) is Tcl Library, even if not true for master, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set lib1 [info library] @@ -1835,7 +1835,7 @@ test safe-14.3.1 {Check that first element of slave auto_path (and access path) set ::auto_path $::auto_TMP safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result [list [info library] [info library]] @@ -1981,12 +1981,12 @@ test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup ### Corresponding tests with Sync Mode on are 7.* test safe-17.1 {cf. safe-7.1 - positive non-module package require, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } # Without AutoPathSync, we need a more complete auto_path, # because the slave will use the same value. @@ -2008,16 +2008,16 @@ test safe-17.1 {cf. safe-7.1 - positive non-module package require, Sync Mode of } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result 1.2.3 test safe-17.2 {cf. safe-7.2 - negative non-module package require with specific path and interpAddToAccessPath, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] @@ -2036,7 +2036,7 @@ test safe-17.2 {cf. safe-7.2 - negative non-module package require with specific [safe::interpDelete $i] } -cleanup { if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result "{} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)}\ 1 {can't find package SafeTestPackage1}\ @@ -2046,12 +2046,12 @@ test safe-17.2 {cf. safe-7.2 - negative non-module package require with specific -statics 0 -nested 1 -deleteHook {} -autoPath [list $tcl_library]} {}" # (not a counterpart of safe-7.3) test safe-17.3 {Check that default auto_path is the same as in the master interpreter, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set i [safe::interpCreate] } -body { @@ -2065,16 +2065,16 @@ test safe-17.3 {Check that default auto_path is the same as in the master interp } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result $::auto_path test safe-17.4 {cf. safe-7.4 - positive non-module package require with specific path and interpAddToAccessPath, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]] @@ -2105,19 +2105,19 @@ test safe-17.4 {cf. safe-7.4 - positive non-module package require with specific [safe::interpDelete $i] } -cleanup { if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result "{} {{\$p(:0:)}} {\$p(:0:)} {\$p(:*:)} {\$p(:*:)} 0 1.2.3\ {-accessPath {[list $tcl_library *$TestsDir/auto0 $TestsDir/auto0/auto1]}\ -statics 0 -nested 1 -deleteHook {}\ -autoPath {[list $tcl_library $TestsDir/auto0]}} {}" test safe-17.5 {cf. safe-7.5 - positive and negative module package require, including ancestor directory issue, Sync Mode off} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } tcl::tm::path add [file join $TestsDir auto0 modules] set i [safe::interpCreate] @@ -2135,17 +2135,17 @@ test safe-17.5 {cf. safe-7.5 - positive and negative module package require, inc } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {1 {can't find package test1} 0} ### 18. Test tokenization of directories available to a slave. test safe-18.1 {Check that each directory of the default auto_path is a valid token, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set i [safe::interpCreate] } -body { @@ -2162,16 +2162,16 @@ test safe-18.1 {Check that each directory of the default auto_path is a valid to } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {} test safe-18.1.1 {Check that each directory of the default auto_path is a valid token, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set i [safe::interpCreate] } -body { @@ -2188,14 +2188,14 @@ test safe-18.1.1 {Check that each directory of the default auto_path is a valid } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {} test safe-18.2 {Check that each directory of the module path is a valid token, Sync Mode on} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 1 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 1 } set i [safe::interpCreate] } -body { @@ -2212,16 +2212,16 @@ test safe-18.2 {Check that each directory of the module path is a valid token, S } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {} test safe-18.2.1 {Check that each directory of the module path is a valid token, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set i [safe::interpCreate] } -body { @@ -2238,7 +2238,7 @@ test safe-18.2.1 {Check that each directory of the module path is a valid token, } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -result {} @@ -2247,12 +2247,12 @@ test safe-18.2.1 {Check that each directory of the module path is a valid token, ### If Sync Mode is on, a corresponding test with Sync Mode off is 9.* test safe-19.8 {autoloading commands indexed in tclIndex files, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -2275,17 +2275,17 @@ test safe-19.8 {autoloading commands indexed in tclIndex files, Sync Mode off} - } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*}} test safe-19.9 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (dummy test of doreset), Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -2329,18 +2329,18 @@ test safe-19.9 {interpConfigure change the access path; tclIndex commands unaffe } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} -- 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} test safe-19.10 {interpConfigure change the access path; tclIndex commands unaffected by token rearrangement (actual test of doreset), Sync Mode off} -constraints {AutoSyncDefined} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { set i [safe::interpCreate -accessPath [list $tcl_library \ @@ -2382,19 +2382,19 @@ test safe-19.10 {interpConfigure change the access path; tclIndex commands unaff } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ 0 ok1 0 ok2 --\ {TCLLIB TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*}} test safe-19.11 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { # For complete correspondence to safe-stock87-9.11, include auto0 in access path. @@ -2440,19 +2440,19 @@ test safe-19.11 {interpConfigure change the access path; pkgIndex.tcl packages u } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:2:)} {$p(:3:)} -- {$p(:3:)} {$p(:2:)} -- 0 1.2.3 0 2.3.4 --\ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} --\ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ 0 OK1 0 OK2} test safe-19.12 {interpConfigure change the access path; pkgIndex.tcl packages unaffected by token rearrangement, safe-19.11 without path auto0, Sync Mode off} -constraints {AutoSyncDefined} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { # To manage without path auto0, use an auto_path that is unusual for @@ -2497,7 +2497,7 @@ test safe-19.12 {interpConfigure change the access path; pkgIndex.tcl packages u } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:1:)} {$p(:2:)} -- {$p(:2:)} {$p(:1:)} --\ 0 1.2.3 0 2.3.4 --\ @@ -2505,12 +2505,12 @@ test safe-19.12 {interpConfigure change the access path; pkgIndex.tcl packages u {TCLLIB TESTSDIR/auto0/auto2 TESTSDIR/auto0/auto1*} --\ 0 OK1 0 OK2} test safe-19.13 {interpConfigure change the access path; pkgIndex.tcl packages fail if directory de-listed, Sync Mode off} -constraints {AutoSyncDefined} -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } } -body { # Path auto0 added (cf. safe-9.3) because it is needed for auto_path. @@ -2547,18 +2547,18 @@ test safe-19.13 {interpConfigure change the access path; pkgIndex.tcl packages f } -cleanup { safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{$p(:2:)} {$p(:3:)} -- 1 {* not found in access path} --\ 1 {* not found in access path} -- 1 1 --\ {TCLLIB TESTSDIR/auto0 TESTSDIR/auto0/auto1 TESTSDIR/auto0/auto2*} -- {TCLLIB*}} test safe-19.20 {check module loading, Sync Mode off} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -2593,7 +2593,7 @@ test safe-19.20 {check module loading, Sync Mode off} -constraints AutoSyncDefin } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ 0 0.5 0 1.0 0 2.0 --\ @@ -2601,12 +2601,12 @@ test safe-19.20 {check module loading, Sync Mode off} -constraints AutoSyncDefin TESTSDIR/auto0/modules/mod2} -- res0 res1 res2} # See comments on lsort after test safe-9.20. test safe-19.21 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 1} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -2661,7 +2661,7 @@ test safe-19.21 {interpConfigure change the access path; check module loading, S } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ @@ -2673,12 +2673,12 @@ test safe-19.21 {interpConfigure change the access path; check module loading, S res0 res1 res2} # See comments on lsort after test safe-9.20. test safe-19.22 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 0} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -2728,7 +2728,7 @@ test safe-19.22 {interpConfigure change the access path; check module loading, S } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ @@ -2740,12 +2740,12 @@ test safe-19.22 {interpConfigure change the access path; check module loading, S res0 res1 res2} # See comments on lsort after test safe-9.20. test safe-19.23 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 3} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -2805,7 +2805,7 @@ test safe-19.23 {interpConfigure change the access path; check module loading, S } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ @@ -2817,12 +2817,12 @@ test safe-19.23 {interpConfigure change the access path; check module loading, S res0 res1 res2} # See comments on lsort after test safe-9.20. test safe-19.24 {interpConfigure change the access path; check module loading, Sync Mode off; stale data case 2 (worst case)} -constraints AutoSyncDefined -setup { - set SyncExists [expr {[info commands ::safe::setAutoPathSync] ne {}}] + set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { - set SyncVal_TMP [safe::setAutoPathSync] - safe::setAutoPathSync 0 + set SyncVal_TMP [safe::setSyncMode] + safe::setSyncMode 0 } else { - error {This test is meaningful only if the command ::safe::setAutoPathSync is defined} + error {This test is meaningful only if the command ::safe::setSyncMode is defined} } set oldTm [tcl::tm::path list] foreach path $oldTm { @@ -2877,7 +2877,7 @@ test safe-19.24 {interpConfigure change the access path; check module loading, S } safe::interpDelete $i if {$SyncExists} { - safe::setAutoPathSync $SyncVal_TMP + safe::setSyncMode $SyncVal_TMP } } -match glob -result {{{$p(:1:)} {$p(:2:)} {$p(:3:)}} -- {{$p(:1:)}} --\ {{$p(:3:)} {$p(:4:)} {$p(:5:)}} -- {{$p(:3:)}} --\ -- cgit v0.12 From 6bad0fe2c0035a1724e85f23cc97a86ca15ae2c0 Mon Sep 17 00:00:00 2001 From: kjnash Date: Sun, 26 Jul 2020 02:54:33 +0000 Subject: Fix merge error in library/safe.tcl. Has effect only if using private command safe::DetokPath with interp name that has namespace separators. --- library/safe.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/safe.tcl b/library/safe.tcl index 18360ce..b5ee95f 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -501,7 +501,7 @@ proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook au # nonsense in both the slave and the master. # proc ::safe::DetokPath {slave tokenPath} { - namespace upvar ::safe S$slave state + namespace upvar ::safe [VarName $slave] state set slavePath {} foreach token $tokenPath { -- cgit v0.12 From 1a08f933917a45ce6efae1951ab01ba5ebedacfc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 4 Dec 2021 17:55:32 +0000 Subject: Experiment: Make tcl.h from Tcl 9.0 usable to compile extensions for Tcl 8.x too (WIP) --- generic/tcl.decls | 170 ++++++++++++------------ generic/tcl.h | 85 +++++++++--- generic/tclDecls.h | 342 +++++++++++++++++++++++++------------------------ generic/tclPlatDecls.h | 4 +- 4 files changed, 324 insertions(+), 277 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 5b013e6..87242cc 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -40,22 +40,22 @@ declare 2 { TCL_NORETURN void Tcl_Panic(const char *format, ...) } declare 3 { - void *Tcl_Alloc(size_t size) + void *Tcl_Alloc(Tcl_Size size) } declare 4 { void Tcl_Free(void *ptr) } declare 5 { - void *Tcl_Realloc(void *ptr, size_t size) + void *Tcl_Realloc(void *ptr, Tcl_Size size) } declare 6 { - void *Tcl_DbCkalloc(size_t size, const char *file, int line) + void *Tcl_DbCkalloc(Tcl_Size size, const char *file, int line) } declare 7 { void Tcl_DbCkfree(void *ptr, const char *file, int line) } declare 8 { - void *Tcl_DbCkrealloc(void *ptr, size_t size, + void *Tcl_DbCkrealloc(void *ptr, Tcl_Size size, const char *file, int line) } @@ -86,7 +86,7 @@ declare 15 { void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...) } declare 16 { - void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, size_t length) + void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, Tcl_Size length) } declare 17 { Tcl_Obj *Tcl_ConcatObj(int objc, Tcl_Obj *const objv[]) @@ -109,7 +109,7 @@ declare 21 { # Tcl_Obj *Tcl_DbNewBooleanObj(int boolValue, const char *file, int line) #} declare 23 { - Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, size_t length, + Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, Tcl_Size numBytes, const char *file, int line) } declare 24 { @@ -128,7 +128,7 @@ declare 27 { Tcl_Obj *Tcl_DbNewObj(const char *file, int line) } declare 28 { - Tcl_Obj *Tcl_DbNewStringObj(const char *bytes, size_t length, + Tcl_Obj *Tcl_DbNewStringObj(const char *bytes, Tcl_Size length, const char *file, int line) } declare 29 { @@ -206,7 +206,7 @@ declare 48 { # Tcl_Obj *Tcl_NewBooleanObj(int boolValue) #} declare 50 { - Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, size_t length) + Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, Tcl_Size numBytes) } declare 51 { Tcl_Obj *Tcl_NewDoubleObj(double doubleValue) @@ -226,18 +226,18 @@ declare 55 { Tcl_Obj *Tcl_NewObj(void) } declare 56 { - Tcl_Obj *Tcl_NewStringObj(const char *bytes, size_t length) + Tcl_Obj *Tcl_NewStringObj(const char *bytes, Tcl_Size length) } # Removed in 9.0 (changed to macro): #declare 57 { # void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue) #} declare 58 { - unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, size_t length) + unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, Tcl_Size numBytes) } declare 59 { void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes, - size_t length) + Tcl_Size numBytes) } declare 60 { void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue) @@ -254,10 +254,10 @@ declare 62 { # void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue) #} declare 64 { - void Tcl_SetObjLength(Tcl_Obj *objPtr, size_t length) + void Tcl_SetObjLength(Tcl_Obj *objPtr, Tcl_Size length) } declare 65 { - void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, size_t length) + void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, Tcl_Size length) } # Removed in 9.0, replaced by macro. #declare 66 { @@ -323,10 +323,10 @@ declare 83 { char *Tcl_Concat(int argc, const char *const *argv) } declare 84 { - size_t Tcl_ConvertElement(const char *src, char *dst, int flags) + Tcl_Size Tcl_ConvertElement(const char *src, char *dst, int flags) } declare 85 { - size_t Tcl_ConvertCountedElement(const char *src, size_t length, char *dst, + Tcl_Size Tcl_ConvertCountedElement(const char *src, Tcl_Size length, char *dst, int flags) } declare 86 { @@ -446,7 +446,7 @@ declare 116 { void Tcl_DoWhenIdle(Tcl_IdleProc *proc, void *clientData) } declare 117 { - char *Tcl_DStringAppend(Tcl_DString *dsPtr, const char *bytes, size_t length) + char *Tcl_DStringAppend(Tcl_DString *dsPtr, const char *bytes, Tcl_Size length) } declare 118 { char *Tcl_DStringAppendElement(Tcl_DString *dsPtr, const char *element) @@ -467,7 +467,7 @@ declare 123 { void Tcl_DStringResult(Tcl_Interp *interp, Tcl_DString *dsPtr) } declare 124 { - void Tcl_DStringSetLength(Tcl_DString *dsPtr, size_t length) + void Tcl_DStringSetLength(Tcl_DString *dsPtr, Tcl_Size length) } declare 125 { void Tcl_DStringStartSublist(Tcl_DString *dsPtr) @@ -626,10 +626,10 @@ declare 168 { Tcl_PathType Tcl_GetPathType(const char *path) } declare 169 { - size_t Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr) + Tcl_Size Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr) } declare 170 { - size_t Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr) + Tcl_Size Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr) } declare 171 { int Tcl_GetServiceMode(void) @@ -758,7 +758,7 @@ declare 205 { void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position) } declare 206 { - size_t Tcl_Read(Tcl_Channel chan, char *bufPtr, size_t toRead) + Tcl_Size Tcl_Read(Tcl_Channel chan, char *bufPtr, Tcl_Size toRead) } declare 207 { void Tcl_ReapDetachedProcs(void) @@ -787,7 +787,7 @@ declare 214 { const char *pattern) } declare 215 { - void Tcl_RegExpRange(Tcl_RegExp regexp, size_t index, + void Tcl_RegExpRange(Tcl_RegExp regexp, Tcl_Size index, const char **startPtr, const char **endPtr) } declare 216 { @@ -797,10 +797,10 @@ declare 217 { void Tcl_ResetResult(Tcl_Interp *interp) } declare 218 { - size_t Tcl_ScanElement(const char *src, int *flagPtr) + Tcl_Size Tcl_ScanElement(const char *src, int *flagPtr) } declare 219 { - size_t Tcl_ScanCountedElement(const char *src, size_t length, int *flagPtr) + Tcl_Size Tcl_ScanCountedElement(const char *src, Tcl_Size length, int *flagPtr) } # Removed in 9.0: #declare 220 { @@ -913,7 +913,7 @@ declare 249 { Tcl_DString *bufferPtr) } declare 250 { - size_t Tcl_Ungets(Tcl_Channel chan, const char *str, size_t len, int atHead) + Tcl_Size Tcl_Ungets(Tcl_Channel chan, const char *str, Tcl_Size len, int atHead) } declare 251 { void Tcl_UnlinkVar(Tcl_Interp *interp, const char *varName) @@ -965,7 +965,7 @@ declare 262 { void *prevClientData) } declare 263 { - size_t Tcl_Write(Tcl_Channel chan, const char *s, size_t slen) + Tcl_Size Tcl_Write(Tcl_Channel chan, const char *s, Tcl_Size slen) } declare 264 { void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc, @@ -1089,7 +1089,7 @@ declare 289 { # void Tcl_DiscardResult(Tcl_SavedResult *statePtr) #} declare 291 { - int Tcl_EvalEx(Tcl_Interp *interp, const char *script, size_t numBytes, + int Tcl_EvalEx(Tcl_Interp *interp, const char *script, Tcl_Size numBytes, int flags) } declare 292 { @@ -1104,13 +1104,13 @@ declare 294 { } declare 295 { int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding, - const char *src, size_t srcLen, int flags, - Tcl_EncodingState *statePtr, char *dst, size_t dstLen, + const char *src, Tcl_Size srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr) } declare 296 { char *Tcl_ExternalToUtfDString(Tcl_Encoding encoding, - const char *src, size_t srcLen, Tcl_DString *dsPtr) + const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr) } declare 297 { void Tcl_FinalizeThread(void) @@ -1135,11 +1135,11 @@ declare 303 { } declare 304 { int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr, - const void *tablePtr, size_t offset, const char *msg, int flags, + const void *tablePtr, Tcl_Size offset, const char *msg, int flags, int *indexPtr) } declare 305 { - void *Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, size_t size) + void *Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, Tcl_Size size) } declare 306 { Tcl_Obj *Tcl_GetVar2Ex(Tcl_Interp *interp, const char *part1, @@ -1162,11 +1162,11 @@ declare 311 { const Tcl_Time *timePtr) } declare 312 { - size_t Tcl_NumUtfChars(const char *src, size_t length) + Tcl_Size Tcl_NumUtfChars(const char *src, Tcl_Size length) } declare 313 { - size_t Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, - size_t charsToRead, int appendFlag) + Tcl_Size Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, + Tcl_Size charsToRead, int appendFlag) } # Removed in 9.0, replaced by macro. #declare 314 { @@ -1191,7 +1191,7 @@ declare 319 { Tcl_QueuePosition position) } declare 320 { - int Tcl_UniCharAtIndex(const char *src, size_t index) + int Tcl_UniCharAtIndex(const char *src, Tcl_Size index) } declare 321 { int Tcl_UniCharToLower(int ch) @@ -1206,13 +1206,13 @@ declare 324 { int Tcl_UniCharToUtf(int ch, char *buf) } declare 325 { - const char *Tcl_UtfAtIndex(const char *src, size_t index) + const char *Tcl_UtfAtIndex(const char *src, Tcl_Size index) } declare 326 { - int TclUtfCharComplete(const char *src, size_t length) + int TclUtfCharComplete(const char *src, Tcl_Size length) } declare 327 { - size_t Tcl_UtfBackslash(const char *src, int *readPtr, char *dst) + Tcl_Size Tcl_UtfBackslash(const char *src, int *readPtr, char *dst) } declare 328 { const char *Tcl_UtfFindFirst(const char *src, int ch) @@ -1228,13 +1228,13 @@ declare 331 { } declare 332 { int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, - const char *src, size_t srcLen, int flags, - Tcl_EncodingState *statePtr, char *dst, size_t dstLen, + const char *src, Tcl_Size srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr) } declare 333 { char *Tcl_UtfToExternalDString(Tcl_Encoding encoding, - const char *src, size_t srcLen, Tcl_DString *dsPtr) + const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr) } declare 334 { int Tcl_UtfToLower(char *src) @@ -1249,10 +1249,10 @@ declare 337 { int Tcl_UtfToUpper(char *src) } declare 338 { - size_t Tcl_WriteChars(Tcl_Channel chan, const char *src, size_t srcLen) + Tcl_Size Tcl_WriteChars(Tcl_Channel chan, const char *src, Tcl_Size srcLen) } declare 339 { - size_t Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr) + Tcl_Size Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr) } declare 340 { char *Tcl_GetString(Tcl_Obj *objPtr) @@ -1294,20 +1294,20 @@ declare 351 { } # Removed in 9.0: #declare 352 { -# size_t Tcl_UniCharLen(const Tcl_UniChar *uniStr) +# int Tcl_UniCharLen(const Tcl_UniChar *uniStr) #} # Removed in 9.0: #declare 353 { # int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, -# size_t numChars) +# unsigned long numChars) #} declare 354 { char *Tcl_Char16ToUtfDString(const unsigned short *uniStr, - size_t uniLength, Tcl_DString *dsPtr) + Tcl_Size uniLength, Tcl_DString *dsPtr) } declare 355 { unsigned short *Tcl_UtfToChar16DString(const char *src, - size_t length, Tcl_DString *dsPtr) + Tcl_Size length, Tcl_DString *dsPtr) } declare 356 { Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, @@ -1323,29 +1323,29 @@ declare 358 { } declare 359 { void Tcl_LogCommandInfo(Tcl_Interp *interp, const char *script, - const char *command, size_t length) + const char *command, Tcl_Size length) } declare 360 { int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, - size_t numBytes, Tcl_Parse *parsePtr, int append, + Tcl_Size numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr) } declare 361 { int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, - size_t numBytes, int nested, Tcl_Parse *parsePtr) + Tcl_Size numBytes, int nested, Tcl_Parse *parsePtr) } declare 362 { - int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, size_t numBytes, + int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr) } declare 363 { int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start, - size_t numBytes, Tcl_Parse *parsePtr, int append, + Tcl_Size numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr) } declare 364 { int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, - size_t numBytes, Tcl_Parse *parsePtr, int append) + Tcl_Size numBytes, Tcl_Parse *parsePtr, int append) } # These 4 functions are obsolete, use Tcl_FSGetCwd, Tcl_FSChdir, # Tcl_FSAccess and Tcl_FSStat @@ -1384,35 +1384,35 @@ declare 375 { } declare 376 { int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp, - Tcl_Obj *textObj, size_t offset, size_t nmatches, int flags) + Tcl_Obj *textObj, Tcl_Size offset, Tcl_Size nmatches, int flags) } declare 377 { void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr) } declare 378 { - Tcl_Obj *Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, size_t numChars) + Tcl_Obj *Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, Tcl_Size numChars) } declare 379 { void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, - size_t numChars) + Tcl_Size numChars) } declare 380 { - size_t Tcl_GetCharLength(Tcl_Obj *objPtr) + Tcl_Size Tcl_GetCharLength(Tcl_Obj *objPtr) } declare 381 { - int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index) + int Tcl_GetUniChar(Tcl_Obj *objPtr, Tcl_Size index) } # Removed in 9.0, replaced by macro. #declare 382 { # Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr) #} declare 383 { - Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, size_t first, size_t last) + Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last) } # Removed in 9.0 #declare 384 { # void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, -# size_t length) +# int length) #} declare 385 { int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, @@ -1442,15 +1442,15 @@ declare 392 { } declare 393 { int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, - void *clientData, size_t stackSize, int flags) + void *clientData, Tcl_Size stackSize, int flags) } # Introduced in 8.3.2 declare 394 { - size_t Tcl_ReadRaw(Tcl_Channel chan, char *dst, size_t bytesToRead) + Tcl_Size Tcl_ReadRaw(Tcl_Channel chan, char *dst, Tcl_Size bytesToRead) } declare 395 { - size_t Tcl_WriteRaw(Tcl_Channel chan, const char *src, size_t srcLen) + Tcl_Size Tcl_WriteRaw(Tcl_Channel chan, const char *src, Tcl_Size srcLen) } declare 396 { Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan) @@ -1541,7 +1541,7 @@ declare 418 { # Removed in 9.0: #declare 419 { # int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, -# size_t numChars) +# unsigned long numChars) #} # Removed in 9.0: #declare 420 { @@ -1578,20 +1578,20 @@ declare 427 { int flags, Tcl_CommandTraceProc *proc, void *clientData) } declare 428 { - void *Tcl_AttemptAlloc(size_t size) + void *Tcl_AttemptAlloc(Tcl_Size size) } declare 429 { - void *Tcl_AttemptDbCkalloc(size_t size, const char *file, int line) + void *Tcl_AttemptDbCkalloc(Tcl_Size size, const char *file, int line) } declare 430 { - void *Tcl_AttemptRealloc(void *ptr, size_t size) + void *Tcl_AttemptRealloc(void *ptr, Tcl_Size size) } declare 431 { - void *Tcl_AttemptDbCkrealloc(void *ptr, size_t size, + void *Tcl_AttemptDbCkrealloc(void *ptr, Tcl_Size size, const char *file, int line) } declare 432 { - int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, size_t length) + int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, Tcl_Size length) } # TIP#10 (thread-aware channels) akupries @@ -1771,7 +1771,7 @@ declare 480 { # TIP#56 (evaluate a parsed script) msofer declare 481 { int Tcl_EvalTokensStandard(Tcl_Interp *interp, Tcl_Token *tokenPtr, - size_t count) + Tcl_Size count) } # TIP#73 (access to current time) kbk @@ -2152,7 +2152,7 @@ declare 574 { } declare 575 { void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, const char *bytes, - size_t length, size_t limit, const char *ellipsis) + Tcl_Size length, Tcl_Size limit, const char *ellipsis) } declare 576 { Tcl_Obj *Tcl_Format(Tcl_Interp *interp, const char *format, int objc, @@ -2304,15 +2304,15 @@ declare 610 { } declare 611 { int Tcl_ZlibInflate(Tcl_Interp *interp, int format, Tcl_Obj *data, - size_t buffersize, Tcl_Obj *gzipHeaderDictObj) + Tcl_Size buffersize, Tcl_Obj *gzipHeaderDictObj) } declare 612 { unsigned int Tcl_ZlibCRC32(unsigned int crc, const unsigned char *buf, - size_t len) + Tcl_Size len) } declare 613 { unsigned int Tcl_ZlibAdler32(unsigned int adler, const unsigned char *buf, - size_t len) + Tcl_Size len) } declare 614 { int Tcl_ZlibStreamInit(Tcl_Interp *interp, int mode, int format, @@ -2332,7 +2332,7 @@ declare 618 { } declare 619 { int Tcl_ZlibStreamGet(Tcl_ZlibStream zshandle, Tcl_Obj *data, - size_t count) + Tcl_Size count) } declare 620 { int Tcl_ZlibStreamClose(Tcl_ZlibStream zshandle) @@ -2415,7 +2415,7 @@ declare 636 { } declare 637 { char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, - size_t numBytes) + Tcl_Size numBytes) } declare 638 { Tcl_ObjInternalRep *Tcl_FetchInternalRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr) @@ -2444,12 +2444,12 @@ declare 643 { # TIP#312 New Tcl_LinkArray() function declare 644 { int Tcl_LinkArray(Tcl_Interp *interp, const char *varName, void *addr, - int type, size_t size) + int type, Tcl_Size size) } declare 645 { int Tcl_GetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, - size_t endValue, size_t *indexPtr) + Tcl_Size endValue, Tcl_Size *indexPtr) } # TIP #548 @@ -2458,21 +2458,21 @@ declare 646 { } declare 647 { char *Tcl_UniCharToUtfDString(const int *uniStr, - size_t uniLength, Tcl_DString *dsPtr) + Tcl_Size uniLength, Tcl_DString *dsPtr) } declare 648 { int *Tcl_UtfToUniCharDString(const char *src, - size_t length, Tcl_DString *dsPtr) + Tcl_Size length, Tcl_DString *dsPtr) } # TIP #568 declare 649 { unsigned char *TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - int *lengthPtr) + int *numBytesPtr) } declare 650 { unsigned char *Tcl_GetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - size_t *lengthPtr) + size_t *numBytesPtr) } # TIP #481 @@ -2483,12 +2483,12 @@ declare 652 { Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, size_t *lengthPtr) } declare 653 { - unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, size_t *lengthPtr) + unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, size_t *numBytesPtr) } # TIP #575 declare 654 { - int Tcl_UtfCharComplete(const char *src, size_t length) + int Tcl_UtfCharComplete(const char *src, Tcl_Size length) } declare 655 { const char *Tcl_UtfNext(const char *src) @@ -2524,7 +2524,7 @@ interface tclPlat declare 1 { int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, - int hasResourceFile, size_t maxPathLen, char *libraryPath) + int hasResourceFile, Tcl_Size maxPathLen, char *libraryPath) } declare 2 { void Tcl_MacOSXNotifierAddRunLoopMode(const void *runLoopMode) diff --git a/generic/tcl.h b/generic/tcl.h index c3db670..0f5eb2e 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -47,6 +47,7 @@ extern "C" { * unix/tcl.spec (1 LOC patch) */ +#if !defined(TCL_MAJOR_VERSION) || (TCL_MAJOR_VERSION == 9) #define TCL_MAJOR_VERSION 9 #define TCL_MINOR_VERSION 0 #define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE @@ -54,6 +55,7 @@ extern "C" { #define TCL_VERSION "9.0" #define TCL_PATCH_LEVEL "9.0a4" +#endif /* TCL_MAJOR_VERSION */ #if defined(RC_INVOKED) /* @@ -306,7 +308,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; #define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) #define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) -#if defined(_WIN32) +#ifdef _WIN32 typedef struct __stat64 Tcl_StatBuf; #elif defined(__CYGWIN__) typedef struct { @@ -448,6 +450,7 @@ typedef void (Tcl_ThreadCreateProc) (void *clientData); * string. */ +#if TCL_MAJOR_VERSION >= 9 typedef struct Tcl_RegExpIndices { size_t start; /* Character offset of first character in * match. */ @@ -462,6 +465,23 @@ typedef struct Tcl_RegExpInfo { size_t extendStart; /* The offset at which a subsequent match * might begin. */ } Tcl_RegExpInfo; +#else +typedef struct Tcl_RegExpIndices { + long start; /* Character offset of first character in + * match. */ + long end; /* Character offset of first character after + * the match. */ +} Tcl_RegExpIndices; + +typedef struct Tcl_RegExpInfo { + int nsubs; /* Number of subexpressions in the compiled + * expression. */ + Tcl_RegExpIndices *matches; /* Array of nsubs match offset pairs. */ + long extendStart; /* The offset at which a subsequent match + * might begin. */ + long reserved; /* Reserved for later use. */ +} Tcl_RegExpInfo; +#endif /* * Picky compilers complain if this typdef doesn't appear before the struct's @@ -635,9 +655,15 @@ typedef union Tcl_ObjInternalRep { /* The internal representation: */ * An object stores a value as either a string, some internal representation, * or both. */ +#if TCL_MAJOR_VERSION >= 9 +# define Tcl_Size size_t +#else +# define Tcl_Size int +#endif + typedef struct Tcl_Obj { - size_t refCount; /* When 0 the object will be freed. */ + Tcl_Size refCount; /* When 0 the object will be freed. */ char *bytes; /* This points to the first byte of the * object's string representation. The array * must be followed by a null byte (i.e., at @@ -649,7 +675,7 @@ typedef struct Tcl_Obj { * should use Tcl_GetStringFromObj or * Tcl_GetString to get a pointer to the byte * array as a readonly value. */ - size_t length; /* The number of bytes at *bytes, not + Tcl_Size length; /* The number of bytes at *bytes, not * including the terminating null. */ const Tcl_ObjType *typePtr; /* Denotes the object's type. Always * corresponds to the type of the object's @@ -779,9 +805,9 @@ typedef struct Tcl_CmdInfo { typedef struct Tcl_DString { char *string; /* Points to beginning of string: either * staticSpace below or a malloced array. */ - size_t length; /* Number of non-NULL characters in the + Tcl_Size length; /* Number of non-NULL characters in the * string. */ - size_t spaceAvl; /* Total number of bytes available for the + Tcl_Size spaceAvl; /* Total number of bytes available for the * string and its terminating NULL char. */ char staticSpace[TCL_DSTRING_STATIC_SIZE]; /* Space to use in common case where string is @@ -944,7 +970,11 @@ typedef struct Tcl_DString { */ #ifndef TCL_HASH_TYPE +#if TCL_MAJOR_VERSION >= 9 # define TCL_HASH_TYPE size_t +#else +# define TCL_HASH_TYPE unsigned +#endif #endif typedef struct Tcl_HashKeyType Tcl_HashKeyType; @@ -967,7 +997,7 @@ struct Tcl_HashEntry { * or NULL for end of chain. */ Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */ size_t hash; /* Hash value. */ - void *clientData; /* Application stores something here with + void *clientData; /* Application stores something here with * Tcl_SetHashValue. */ union { /* Key has one of these forms: */ char *oneWordValue; /* One-word value for key. */ @@ -1055,16 +1085,21 @@ struct Tcl_HashTable { Tcl_HashEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; /* Bucket array used for small tables (to * avoid mallocs and frees). */ - size_t numBuckets; /* Total number of buckets allocated at + Tcl_Size numBuckets; /* Total number of buckets allocated at * **bucketPtr. */ - size_t numEntries; /* Total number of entries present in + Tcl_Size numEntries; /* Total number of entries present in * table. */ - size_t rebuildSize; /* Enlarge table when numEntries gets to be + Tcl_Size rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ - size_t mask; /* Mask value used in hashing function. */ +#if TCL_MAJOR_VERSION >= 9 + Tcl_Size mask; /* Mask value used in hashing function. */ +#endif int downShift; /* Shift count used in hashing function. * Designed to use high-order bits of * randomized keys. */ +#if TCL_MAJOR_VERSION <= 8 + int mask; /* Mask value used in hashing function. */ +#endif int keyType; /* Type of keys used in this table. It's * either TCL_CUSTOM_KEYS, TCL_STRING_KEYS, * TCL_ONE_WORD_KEYS, or an integer giving the @@ -1085,7 +1120,7 @@ struct Tcl_HashTable { typedef struct Tcl_HashSearch { Tcl_HashTable *tablePtr; /* Table being searched. */ - size_t nextIndex; /* Index of next bucket to be enumerated after + Tcl_Size nextIndex; /* Index of next bucket to be enumerated after * present one. */ Tcl_HashEntry *nextEntryPtr;/* Next entry to be enumerated in the current * bucket. */ @@ -1126,7 +1161,7 @@ typedef struct Tcl_HashSearch { typedef struct { void *next; /* Search position for underlying hash * table. */ - size_t epoch; /* Epoch marker for dictionary being searched, + TCL_HASH_TYPE epoch; /* Epoch marker for dictionary being searched, * or 0 if search has terminated. */ Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */ } Tcl_DictSearch; @@ -1480,7 +1515,7 @@ typedef struct Tcl_FSVersion_ *Tcl_FSVersion; typedef struct Tcl_Filesystem { const char *typeName; /* The name of the filesystem. */ - size_t structureLength; /* Length of this structure, so future binary + Tcl_Size structureLength; /* Length of this structure, so future binary * compatibility can be assured. */ Tcl_FSVersion version; /* Version of the filesystem type. */ Tcl_FSPathInFilesystemProc *pathInFilesystemProc; @@ -1642,8 +1677,8 @@ typedef struct Tcl_Token { int type; /* Type of token, such as TCL_TOKEN_WORD; see * below for valid types. */ const char *start; /* First character in token. */ - size_t size; /* Number of bytes in token. */ - size_t numComponents; /* If this token is composed of other tokens, + Tcl_Size size; /* Number of bytes in token. */ + Tcl_Size numComponents; /* If this token is composed of other tokens, * this field tells how many of them there are * (including components of components, etc.). * The component tokens immediately follow @@ -1757,7 +1792,7 @@ typedef struct Tcl_Token { typedef struct Tcl_Parse { const char *commentStart; /* Pointer to # that begins the first of one * or more comments preceding the command. */ - size_t commentSize; /* Number of bytes in comments (up through + Tcl_Size commentSize; /* Number of bytes in comments (up through * newline character that terminates the last * comment). If there were no comments, this * field is 0. */ @@ -1930,7 +1965,11 @@ typedef struct Tcl_EncodingType { */ #ifndef TCL_UTF_MAX +#if TCL_MAJOR_VERSION >= 9 #define TCL_UTF_MAX 4 +#else +#define TCL_UTF_MAX 3 +#endif #endif /* @@ -2113,12 +2152,12 @@ typedef int (Tcl_ArgvGenFuncProc)(void *clientData, Tcl_Interp *interp, #define TCL_TCPSERVER_REUSEPORT (1<<1) /* - * Constants for special size_t-typed values, see TIP #494 + * Constants for special Tcl_Size-typed values, see TIP #494 */ -#define TCL_IO_FAILURE ((size_t)-1) -#define TCL_AUTO_LENGTH ((size_t)-1) -#define TCL_INDEX_NONE ((size_t)-1) +#define TCL_IO_FAILURE ((Tcl_Size)-1) +#define TCL_AUTO_LENGTH ((Tcl_Size)-1) +#define TCL_INDEX_NONE ((Tcl_Size)-1) /* *---------------------------------------------------------------------------- @@ -2134,7 +2173,11 @@ typedef int (Tcl_NRPostProc) (void *data[], Tcl_Interp *interp, * stubs tables. */ -#define TCL_STUB_MAGIC ((int) 0xFCA3BACB + (int) sizeof(void *)) +#if TCL_MAJOR_VERSION >= 9 +# define TCL_STUB_MAGIC ((int) 0xFCA3BACB + (int) sizeof(void *)) +#else +# define TCL_STUB_MAGIC ((int) 0xFCA3BACF) +#endif /* * The following function is required to be defined in all stubs aware diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 459ddc5..dea8d8c 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -59,18 +59,18 @@ EXTERN const char * Tcl_PkgRequireEx(Tcl_Interp *interp, /* 2 */ EXTERN TCL_NORETURN void Tcl_Panic(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 3 */ -EXTERN void * Tcl_Alloc(size_t size); +EXTERN void * Tcl_Alloc(Tcl_Size size); /* 4 */ EXTERN void Tcl_Free(void *ptr); /* 5 */ -EXTERN void * Tcl_Realloc(void *ptr, size_t size); +EXTERN void * Tcl_Realloc(void *ptr, Tcl_Size size); /* 6 */ -EXTERN void * Tcl_DbCkalloc(size_t size, const char *file, +EXTERN void * Tcl_DbCkalloc(Tcl_Size size, const char *file, int line); /* 7 */ EXTERN void Tcl_DbCkfree(void *ptr, const char *file, int line); /* 8 */ -EXTERN void * Tcl_DbCkrealloc(void *ptr, size_t size, +EXTERN void * Tcl_DbCkrealloc(void *ptr, Tcl_Size size, const char *file, int line); /* 9 */ EXTERN void Tcl_CreateFileHandler(int fd, int mask, @@ -90,7 +90,7 @@ EXTERN int Tcl_AppendAllObjTypes(Tcl_Interp *interp, EXTERN void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...); /* 16 */ EXTERN void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, - size_t length); + Tcl_Size length); /* 17 */ EXTERN Tcl_Obj * Tcl_ConcatObj(int objc, Tcl_Obj *const objv[]); /* 18 */ @@ -108,7 +108,8 @@ EXTERN int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, /* Slot 22 is reserved */ /* 23 */ EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes, - size_t length, const char *file, int line); + Tcl_Size numBytes, const char *file, + int line); /* 24 */ EXTERN Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, const char *file, int line); @@ -119,8 +120,8 @@ EXTERN Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv, /* 27 */ EXTERN Tcl_Obj * Tcl_DbNewObj(const char *file, int line); /* 28 */ -EXTERN Tcl_Obj * Tcl_DbNewStringObj(const char *bytes, size_t length, - const char *file, int line); +EXTERN Tcl_Obj * Tcl_DbNewStringObj(const char *bytes, + Tcl_Size length, const char *file, int line); /* 29 */ EXTERN Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr); /* 30 */ @@ -180,7 +181,7 @@ EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp, /* Slot 49 is reserved */ /* 50 */ EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes, - size_t length); + Tcl_Size numBytes); /* 51 */ EXTERN Tcl_Obj * Tcl_NewDoubleObj(double doubleValue); /* Slot 52 is reserved */ @@ -190,14 +191,15 @@ EXTERN Tcl_Obj * Tcl_NewListObj(int objc, Tcl_Obj *const objv[]); /* 55 */ EXTERN Tcl_Obj * Tcl_NewObj(void); /* 56 */ -EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, size_t length); +EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, Tcl_Size length); /* Slot 57 is reserved */ /* 58 */ EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, - size_t length); + Tcl_Size numBytes); /* 59 */ EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, - const unsigned char *bytes, size_t length); + const unsigned char *bytes, + Tcl_Size numBytes); /* 60 */ EXTERN void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue); /* Slot 61 is reserved */ @@ -206,10 +208,10 @@ EXTERN void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* Slot 63 is reserved */ /* 64 */ -EXTERN void Tcl_SetObjLength(Tcl_Obj *objPtr, size_t length); +EXTERN void Tcl_SetObjLength(Tcl_Obj *objPtr, Tcl_Size length); /* 65 */ EXTERN void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, - size_t length); + Tcl_Size length); /* Slot 66 is reserved */ /* Slot 67 is reserved */ /* 68 */ @@ -248,11 +250,11 @@ EXTERN int Tcl_CommandComplete(const char *cmd); /* 83 */ EXTERN char * Tcl_Concat(int argc, const char *const *argv); /* 84 */ -EXTERN size_t Tcl_ConvertElement(const char *src, char *dst, +EXTERN Tcl_Size Tcl_ConvertElement(const char *src, char *dst, int flags); /* 85 */ -EXTERN size_t Tcl_ConvertCountedElement(const char *src, - size_t length, char *dst, int flags); +EXTERN Tcl_Size Tcl_ConvertCountedElement(const char *src, + Tcl_Size length, char *dst, int flags); /* 86 */ EXTERN int Tcl_CreateAlias(Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, @@ -348,7 +350,7 @@ EXTERN int Tcl_DoOneEvent(int flags); EXTERN void Tcl_DoWhenIdle(Tcl_IdleProc *proc, void *clientData); /* 117 */ EXTERN char * Tcl_DStringAppend(Tcl_DString *dsPtr, - const char *bytes, size_t length); + const char *bytes, Tcl_Size length); /* 118 */ EXTERN char * Tcl_DStringAppendElement(Tcl_DString *dsPtr, const char *element); @@ -366,7 +368,7 @@ EXTERN void Tcl_DStringResult(Tcl_Interp *interp, Tcl_DString *dsPtr); /* 124 */ EXTERN void Tcl_DStringSetLength(Tcl_DString *dsPtr, - size_t length); + Tcl_Size length); /* 125 */ EXTERN void Tcl_DStringStartSublist(Tcl_DString *dsPtr); /* 126 */ @@ -483,9 +485,9 @@ EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp, /* 168 */ EXTERN Tcl_PathType Tcl_GetPathType(const char *path); /* 169 */ -EXTERN size_t Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr); +EXTERN Tcl_Size Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr); /* 170 */ -EXTERN size_t Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr); +EXTERN Tcl_Size Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 171 */ EXTERN int Tcl_GetServiceMode(void); /* 172 */ @@ -571,8 +573,8 @@ EXTERN const char * Tcl_PosixError(Tcl_Interp *interp); EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position); /* 206 */ -EXTERN size_t Tcl_Read(Tcl_Channel chan, char *bufPtr, - size_t toRead); +EXTERN Tcl_Size Tcl_Read(Tcl_Channel chan, char *bufPtr, + Tcl_Size toRead); /* 207 */ EXTERN void Tcl_ReapDetachedProcs(void); /* 208 */ @@ -596,17 +598,17 @@ EXTERN int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp, EXTERN int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text, const char *pattern); /* 215 */ -EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, size_t index, +EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, Tcl_Size index, const char **startPtr, const char **endPtr); /* 216 */ EXTERN void Tcl_Release(void *clientData); /* 217 */ EXTERN void Tcl_ResetResult(Tcl_Interp *interp); /* 218 */ -EXTERN size_t Tcl_ScanElement(const char *src, int *flagPtr); +EXTERN Tcl_Size Tcl_ScanElement(const char *src, int *flagPtr); /* 219 */ -EXTERN size_t Tcl_ScanCountedElement(const char *src, - size_t length, int *flagPtr); +EXTERN Tcl_Size Tcl_ScanCountedElement(const char *src, + Tcl_Size length, int *flagPtr); /* Slot 220 is reserved */ /* 221 */ EXTERN int Tcl_ServiceAll(void); @@ -676,8 +678,8 @@ EXTERN int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, EXTERN char * Tcl_TranslateFileName(Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 250 */ -EXTERN size_t Tcl_Ungets(Tcl_Channel chan, const char *str, - size_t len, int atHead); +EXTERN Tcl_Size Tcl_Ungets(Tcl_Channel chan, const char *str, + Tcl_Size len, int atHead); /* 251 */ EXTERN void Tcl_UnlinkVar(Tcl_Interp *interp, const char *varName); @@ -711,8 +713,8 @@ EXTERN void * Tcl_VarTraceInfo2(Tcl_Interp *interp, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 263 */ -EXTERN size_t Tcl_Write(Tcl_Channel chan, const char *s, - size_t slen); +EXTERN Tcl_Size Tcl_Write(Tcl_Channel chan, const char *s, + Tcl_Size slen); /* 264 */ EXTERN void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); @@ -771,7 +773,7 @@ EXTERN void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, /* Slot 290 is reserved */ /* 291 */ EXTERN int Tcl_EvalEx(Tcl_Interp *interp, const char *script, - size_t numBytes, int flags); + Tcl_Size numBytes, int flags); /* 292 */ EXTERN int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); @@ -783,13 +785,13 @@ EXTERN TCL_NORETURN void Tcl_ExitThread(int status); /* 295 */ EXTERN int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, - size_t srcLen, int flags, + Tcl_Size srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, - size_t dstLen, int *srcReadPtr, + Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 296 */ EXTERN char * Tcl_ExternalToUtfDString(Tcl_Encoding encoding, - const char *src, size_t srcLen, + const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr); /* 297 */ EXTERN void Tcl_FinalizeThread(void); @@ -808,11 +810,11 @@ EXTERN void Tcl_GetEncodingNames(Tcl_Interp *interp); /* 304 */ EXTERN int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, - size_t offset, const char *msg, int flags, + Tcl_Size offset, const char *msg, int flags, int *indexPtr); /* 305 */ EXTERN void * Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, - size_t size); + Tcl_Size size); /* 306 */ EXTERN Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, const char *part1, const char *part2, int flags); @@ -828,10 +830,10 @@ EXTERN void Tcl_ConditionNotify(Tcl_Condition *condPtr); EXTERN void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 312 */ -EXTERN size_t Tcl_NumUtfChars(const char *src, size_t length); +EXTERN Tcl_Size Tcl_NumUtfChars(const char *src, Tcl_Size length); /* 313 */ -EXTERN size_t Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, - size_t charsToRead, int appendFlag); +EXTERN Tcl_Size Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, + Tcl_Size charsToRead, int appendFlag); /* Slot 314 is reserved */ /* Slot 315 is reserved */ /* 316 */ @@ -847,7 +849,7 @@ EXTERN void Tcl_ThreadAlert(Tcl_ThreadId threadId); EXTERN void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 320 */ -EXTERN int Tcl_UniCharAtIndex(const char *src, size_t index); +EXTERN int Tcl_UniCharAtIndex(const char *src, Tcl_Size index); /* 321 */ EXTERN int Tcl_UniCharToLower(int ch); /* 322 */ @@ -857,11 +859,11 @@ EXTERN int Tcl_UniCharToUpper(int ch); /* 324 */ EXTERN int Tcl_UniCharToUtf(int ch, char *buf); /* 325 */ -EXTERN const char * Tcl_UtfAtIndex(const char *src, size_t index); +EXTERN const char * Tcl_UtfAtIndex(const char *src, Tcl_Size index); /* 326 */ -EXTERN int TclUtfCharComplete(const char *src, size_t length); +EXTERN int TclUtfCharComplete(const char *src, Tcl_Size length); /* 327 */ -EXTERN size_t Tcl_UtfBackslash(const char *src, int *readPtr, +EXTERN Tcl_Size Tcl_UtfBackslash(const char *src, int *readPtr, char *dst); /* 328 */ EXTERN const char * Tcl_UtfFindFirst(const char *src, int ch); @@ -874,13 +876,13 @@ EXTERN const char * TclUtfPrev(const char *src, const char *start); /* 332 */ EXTERN int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, - size_t srcLen, int flags, + Tcl_Size srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, - size_t dstLen, int *srcReadPtr, + Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 333 */ EXTERN char * Tcl_UtfToExternalDString(Tcl_Encoding encoding, - const char *src, size_t srcLen, + const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr); /* 334 */ EXTERN int Tcl_UtfToLower(char *src); @@ -892,10 +894,10 @@ EXTERN int Tcl_UtfToChar16(const char *src, /* 337 */ EXTERN int Tcl_UtfToUpper(char *src); /* 338 */ -EXTERN size_t Tcl_WriteChars(Tcl_Channel chan, const char *src, - size_t srcLen); +EXTERN Tcl_Size Tcl_WriteChars(Tcl_Channel chan, const char *src, + Tcl_Size srcLen); /* 339 */ -EXTERN size_t Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr); +EXTERN Tcl_Size Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 340 */ EXTERN char * Tcl_GetString(Tcl_Obj *objPtr); /* Slot 341 is reserved */ @@ -922,10 +924,10 @@ EXTERN int Tcl_UniCharIsWordChar(int ch); /* Slot 353 is reserved */ /* 354 */ EXTERN char * Tcl_Char16ToUtfDString(const unsigned short *uniStr, - size_t uniLength, Tcl_DString *dsPtr); + Tcl_Size uniLength, Tcl_DString *dsPtr); /* 355 */ EXTERN unsigned short * Tcl_UtfToChar16DString(const char *src, - size_t length, Tcl_DString *dsPtr); + Tcl_Size length, Tcl_DString *dsPtr); /* 356 */ EXTERN Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags); @@ -935,27 +937,27 @@ EXTERN void Tcl_FreeParse(Tcl_Parse *parsePtr); /* 359 */ EXTERN void Tcl_LogCommandInfo(Tcl_Interp *interp, const char *script, const char *command, - size_t length); + Tcl_Size length); /* 360 */ EXTERN int Tcl_ParseBraces(Tcl_Interp *interp, - const char *start, size_t numBytes, + const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 361 */ EXTERN int Tcl_ParseCommand(Tcl_Interp *interp, - const char *start, size_t numBytes, + const char *start, Tcl_Size numBytes, int nested, Tcl_Parse *parsePtr); /* 362 */ EXTERN int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, - size_t numBytes, Tcl_Parse *parsePtr); + Tcl_Size numBytes, Tcl_Parse *parsePtr); /* 363 */ EXTERN int Tcl_ParseQuotedString(Tcl_Interp *interp, - const char *start, size_t numBytes, + const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 364 */ EXTERN int Tcl_ParseVarName(Tcl_Interp *interp, - const char *start, size_t numBytes, + const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr, int append); /* 365 */ EXTERN char * Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr); @@ -984,24 +986,26 @@ EXTERN int Tcl_UniCharIsPunct(int ch); /* 376 */ EXTERN int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, - size_t offset, size_t nmatches, int flags); + Tcl_Size offset, Tcl_Size nmatches, + int flags); /* 377 */ EXTERN void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 378 */ EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, - size_t numChars); + Tcl_Size numChars); /* 379 */ EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, size_t numChars); + const Tcl_UniChar *unicode, + Tcl_Size numChars); /* 380 */ -EXTERN size_t Tcl_GetCharLength(Tcl_Obj *objPtr); +EXTERN Tcl_Size Tcl_GetCharLength(Tcl_Obj *objPtr); /* 381 */ -EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, size_t index); +EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, Tcl_Size index); /* Slot 382 is reserved */ /* 383 */ -EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, size_t first, - size_t last); +EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, Tcl_Size first, + Tcl_Size last); /* Slot 384 is reserved */ /* 385 */ EXTERN int Tcl_RegExpMatchObj(Tcl_Interp *interp, @@ -1025,13 +1029,13 @@ EXTERN void Tcl_MutexFinalize(Tcl_Mutex *mutex); /* 393 */ EXTERN int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, - size_t stackSize, int flags); + Tcl_Size stackSize, int flags); /* 394 */ -EXTERN size_t Tcl_ReadRaw(Tcl_Channel chan, char *dst, - size_t bytesToRead); +EXTERN Tcl_Size Tcl_ReadRaw(Tcl_Channel chan, char *dst, + Tcl_Size bytesToRead); /* 395 */ -EXTERN size_t Tcl_WriteRaw(Tcl_Channel chan, const char *src, - size_t srcLen); +EXTERN Tcl_Size Tcl_WriteRaw(Tcl_Channel chan, const char *src, + Tcl_Size srcLen); /* 396 */ EXTERN Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan); /* 397 */ @@ -1111,18 +1115,18 @@ EXTERN void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 428 */ -EXTERN void * Tcl_AttemptAlloc(size_t size); +EXTERN void * Tcl_AttemptAlloc(Tcl_Size size); /* 429 */ -EXTERN void * Tcl_AttemptDbCkalloc(size_t size, const char *file, +EXTERN void * Tcl_AttemptDbCkalloc(Tcl_Size size, const char *file, int line); /* 430 */ -EXTERN void * Tcl_AttemptRealloc(void *ptr, size_t size); +EXTERN void * Tcl_AttemptRealloc(void *ptr, Tcl_Size size); /* 431 */ -EXTERN void * Tcl_AttemptDbCkrealloc(void *ptr, size_t size, +EXTERN void * Tcl_AttemptDbCkrealloc(void *ptr, Tcl_Size size, const char *file, int line); /* 432 */ EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, - size_t length); + Tcl_Size length); /* 433 */ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel); /* 434 */ @@ -1248,7 +1252,7 @@ EXTERN int Tcl_OutputBuffered(Tcl_Channel chan); EXTERN void Tcl_FSMountsChanged(const Tcl_Filesystem *fsPtr); /* 481 */ EXTERN int Tcl_EvalTokensStandard(Tcl_Interp *interp, - Tcl_Token *tokenPtr, size_t count); + Tcl_Token *tokenPtr, Tcl_Size count); /* 482 */ EXTERN void Tcl_GetTime(Tcl_Time *timeBuf); /* 483 */ @@ -1518,8 +1522,8 @@ EXTERN void Tcl_AppendObjToErrorInfo(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 575 */ EXTERN void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, - const char *bytes, size_t length, - size_t limit, const char *ellipsis); + const char *bytes, Tcl_Size length, + Tcl_Size limit, const char *ellipsis); /* 576 */ EXTERN Tcl_Obj * Tcl_Format(Tcl_Interp *interp, const char *format, int objc, Tcl_Obj *const objv[]); @@ -1618,14 +1622,14 @@ EXTERN int Tcl_ZlibDeflate(Tcl_Interp *interp, int format, Tcl_Obj *gzipHeaderDictObj); /* 611 */ EXTERN int Tcl_ZlibInflate(Tcl_Interp *interp, int format, - Tcl_Obj *data, size_t buffersize, + Tcl_Obj *data, Tcl_Size buffersize, Tcl_Obj *gzipHeaderDictObj); /* 612 */ EXTERN unsigned int Tcl_ZlibCRC32(unsigned int crc, - const unsigned char *buf, size_t len); + const unsigned char *buf, Tcl_Size len); /* 613 */ EXTERN unsigned int Tcl_ZlibAdler32(unsigned int adler, - const unsigned char *buf, size_t len); + const unsigned char *buf, Tcl_Size len); /* 614 */ EXTERN int Tcl_ZlibStreamInit(Tcl_Interp *interp, int mode, int format, int level, Tcl_Obj *dictObj, @@ -1641,7 +1645,7 @@ EXTERN int Tcl_ZlibStreamPut(Tcl_ZlibStream zshandle, Tcl_Obj *data, int flush); /* 619 */ EXTERN int Tcl_ZlibStreamGet(Tcl_ZlibStream zshandle, - Tcl_Obj *data, size_t count); + Tcl_Obj *data, Tcl_Size count); /* 620 */ EXTERN int Tcl_ZlibStreamClose(Tcl_ZlibStream zshandle); /* 621 */ @@ -1697,7 +1701,7 @@ EXTERN int TclZipfs_MountBuffer(Tcl_Interp *interp, EXTERN void Tcl_FreeInternalRep(Tcl_Obj *objPtr); /* 637 */ EXTERN char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, - size_t numBytes); + Tcl_Size numBytes); /* 638 */ EXTERN Tcl_ObjInternalRep * Tcl_FetchInternalRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); @@ -1716,25 +1720,25 @@ EXTERN int Tcl_IsShared(Tcl_Obj *objPtr); /* 644 */ EXTERN int Tcl_LinkArray(Tcl_Interp *interp, const char *varName, void *addr, int type, - size_t size); + Tcl_Size size); /* 645 */ EXTERN int Tcl_GetIntForIndex(Tcl_Interp *interp, - Tcl_Obj *objPtr, size_t endValue, - size_t *indexPtr); + Tcl_Obj *objPtr, Tcl_Size endValue, + Tcl_Size *indexPtr); /* 646 */ EXTERN int Tcl_UtfToUniChar(const char *src, int *chPtr); /* 647 */ EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr, - size_t uniLength, Tcl_DString *dsPtr); + Tcl_Size uniLength, Tcl_DString *dsPtr); /* 648 */ EXTERN int * Tcl_UtfToUniCharDString(const char *src, - size_t length, Tcl_DString *dsPtr); + Tcl_Size length, Tcl_DString *dsPtr); /* 649 */ EXTERN unsigned char * TclGetBytesFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, int *lengthPtr); + Tcl_Obj *objPtr, int *numBytesPtr); /* 650 */ EXTERN unsigned char * Tcl_GetBytesFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, size_t *lengthPtr); + Tcl_Obj *objPtr, size_t *numBytesPtr); /* 651 */ EXTERN char * Tcl_GetStringFromObj(Tcl_Obj *objPtr, size_t *lengthPtr); @@ -1743,9 +1747,9 @@ EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, size_t *lengthPtr); /* 653 */ EXTERN unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, - size_t *lengthPtr); + size_t *numBytesPtr); /* 654 */ -EXTERN int Tcl_UtfCharComplete(const char *src, size_t length); +EXTERN int Tcl_UtfCharComplete(const char *src, Tcl_Size length); /* 655 */ EXTERN const char * Tcl_UtfNext(const char *src); /* 656 */ @@ -1771,12 +1775,12 @@ typedef struct TclStubs { int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */ const char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */ TCL_NORETURN1 void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */ - void * (*tcl_Alloc) (size_t size); /* 3 */ + void * (*tcl_Alloc) (Tcl_Size size); /* 3 */ void (*tcl_Free) (void *ptr); /* 4 */ - void * (*tcl_Realloc) (void *ptr, size_t size); /* 5 */ - void * (*tcl_DbCkalloc) (size_t size, const char *file, int line); /* 6 */ + void * (*tcl_Realloc) (void *ptr, Tcl_Size size); /* 5 */ + void * (*tcl_DbCkalloc) (Tcl_Size size, const char *file, int line); /* 6 */ void (*tcl_DbCkfree) (void *ptr, const char *file, int line); /* 7 */ - void * (*tcl_DbCkrealloc) (void *ptr, size_t size, const char *file, int line); /* 8 */ + void * (*tcl_DbCkrealloc) (void *ptr, Tcl_Size size, const char *file, int line); /* 8 */ void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, void *clientData); /* 9 */ void (*tcl_DeleteFileHandler) (int fd); /* 10 */ void (*tcl_SetTimer) (const Tcl_Time *timePtr); /* 11 */ @@ -1784,19 +1788,19 @@ typedef struct TclStubs { int (*tcl_WaitForEvent) (const Tcl_Time *timePtr); /* 13 */ int (*tcl_AppendAllObjTypes) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 14 */ void (*tcl_AppendStringsToObj) (Tcl_Obj *objPtr, ...); /* 15 */ - void (*tcl_AppendToObj) (Tcl_Obj *objPtr, const char *bytes, size_t length); /* 16 */ + void (*tcl_AppendToObj) (Tcl_Obj *objPtr, const char *bytes, Tcl_Size length); /* 16 */ Tcl_Obj * (*tcl_ConcatObj) (int objc, Tcl_Obj *const objv[]); /* 17 */ int (*tcl_ConvertToType) (Tcl_Interp *interp, Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 18 */ void (*tcl_DbDecrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 19 */ void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 20 */ int (*tcl_DbIsShared) (Tcl_Obj *objPtr, const char *file, int line); /* 21 */ void (*reserved22)(void); - Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, size_t length, const char *file, int line); /* 23 */ + Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, Tcl_Size numBytes, const char *file, int line); /* 23 */ Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */ Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */ void (*reserved26)(void); Tcl_Obj * (*tcl_DbNewObj) (const char *file, int line); /* 27 */ - Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, size_t length, const char *file, int line); /* 28 */ + Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, Tcl_Size length, const char *file, int line); /* 28 */ Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */ void (*tclFreeObj) (Tcl_Obj *objPtr); /* 30 */ int (*tcl_GetBoolean) (Tcl_Interp *interp, const char *src, int *boolPtr); /* 31 */ @@ -1818,22 +1822,22 @@ typedef struct TclStubs { int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */ int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 48 */ void (*reserved49)(void); - Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, size_t length); /* 50 */ + Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, Tcl_Size numBytes); /* 50 */ Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */ void (*reserved52)(void); Tcl_Obj * (*tcl_NewListObj) (int objc, Tcl_Obj *const objv[]); /* 53 */ void (*reserved54)(void); Tcl_Obj * (*tcl_NewObj) (void); /* 55 */ - Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, size_t length); /* 56 */ + Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, Tcl_Size length); /* 56 */ void (*reserved57)(void); - unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, size_t length); /* 58 */ - void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, size_t length); /* 59 */ + unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, Tcl_Size numBytes); /* 58 */ + void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, Tcl_Size numBytes); /* 59 */ void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */ void (*reserved61)(void); void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 62 */ void (*reserved63)(void); - void (*tcl_SetObjLength) (Tcl_Obj *objPtr, size_t length); /* 64 */ - void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, size_t length); /* 65 */ + void (*tcl_SetObjLength) (Tcl_Obj *objPtr, Tcl_Size length); /* 64 */ + void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, Tcl_Size length); /* 65 */ void (*reserved66)(void); void (*reserved67)(void); void (*tcl_AllowExceptions) (Tcl_Interp *interp); /* 68 */ @@ -1852,8 +1856,8 @@ typedef struct TclStubs { void (*reserved81)(void); int (*tcl_CommandComplete) (const char *cmd); /* 82 */ char * (*tcl_Concat) (int argc, const char *const *argv); /* 83 */ - size_t (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */ - size_t (*tcl_ConvertCountedElement) (const char *src, size_t length, char *dst, int flags); /* 85 */ + Tcl_Size (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */ + Tcl_Size (*tcl_ConvertCountedElement) (const char *src, Tcl_Size length, char *dst, int flags); /* 85 */ int (*tcl_CreateAlias) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 86 */ int (*tcl_CreateAliasObj) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */ Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, void *instanceData, int mask); /* 88 */ @@ -1885,14 +1889,14 @@ typedef struct TclStubs { void (*tcl_DontCallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); /* 114 */ int (*tcl_DoOneEvent) (int flags); /* 115 */ void (*tcl_DoWhenIdle) (Tcl_IdleProc *proc, void *clientData); /* 116 */ - char * (*tcl_DStringAppend) (Tcl_DString *dsPtr, const char *bytes, size_t length); /* 117 */ + char * (*tcl_DStringAppend) (Tcl_DString *dsPtr, const char *bytes, Tcl_Size length); /* 117 */ char * (*tcl_DStringAppendElement) (Tcl_DString *dsPtr, const char *element); /* 118 */ void (*tcl_DStringEndSublist) (Tcl_DString *dsPtr); /* 119 */ void (*tcl_DStringFree) (Tcl_DString *dsPtr); /* 120 */ void (*tcl_DStringGetResult) (Tcl_Interp *interp, Tcl_DString *dsPtr); /* 121 */ void (*tcl_DStringInit) (Tcl_DString *dsPtr); /* 122 */ void (*tcl_DStringResult) (Tcl_Interp *interp, Tcl_DString *dsPtr); /* 123 */ - void (*tcl_DStringSetLength) (Tcl_DString *dsPtr, size_t length); /* 124 */ + void (*tcl_DStringSetLength) (Tcl_DString *dsPtr, Tcl_Size length); /* 124 */ void (*tcl_DStringStartSublist) (Tcl_DString *dsPtr); /* 125 */ int (*tcl_Eof) (Tcl_Channel chan); /* 126 */ const char * (*tcl_ErrnoId) (void); /* 127 */ @@ -1937,8 +1941,8 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_GetObjResult) (Tcl_Interp *interp); /* 166 */ int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr); /* 167 */ Tcl_PathType (*tcl_GetPathType) (const char *path); /* 168 */ - size_t (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */ - size_t (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */ + Tcl_Size (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */ + Tcl_Size (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */ int (*tcl_GetServiceMode) (void); /* 171 */ Tcl_Interp * (*tcl_GetChild) (Tcl_Interp *interp, const char *name); /* 172 */ Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */ @@ -1974,7 +1978,7 @@ typedef struct TclStubs { int (*tcl_PutEnv) (const char *assignment); /* 203 */ const char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */ void (*tcl_QueueEvent) (Tcl_Event *evPtr, Tcl_QueuePosition position); /* 205 */ - size_t (*tcl_Read) (Tcl_Channel chan, char *bufPtr, size_t toRead); /* 206 */ + Tcl_Size (*tcl_Read) (Tcl_Channel chan, char *bufPtr, Tcl_Size toRead); /* 206 */ void (*tcl_ReapDetachedProcs) (void); /* 207 */ int (*tcl_RecordAndEval) (Tcl_Interp *interp, const char *cmd, int flags); /* 208 */ int (*tcl_RecordAndEvalObj) (Tcl_Interp *interp, Tcl_Obj *cmdPtr, int flags); /* 209 */ @@ -1983,11 +1987,11 @@ typedef struct TclStubs { Tcl_RegExp (*tcl_RegExpCompile) (Tcl_Interp *interp, const char *pattern); /* 212 */ int (*tcl_RegExpExec) (Tcl_Interp *interp, Tcl_RegExp regexp, const char *text, const char *start); /* 213 */ int (*tcl_RegExpMatch) (Tcl_Interp *interp, const char *text, const char *pattern); /* 214 */ - void (*tcl_RegExpRange) (Tcl_RegExp regexp, size_t index, const char **startPtr, const char **endPtr); /* 215 */ + void (*tcl_RegExpRange) (Tcl_RegExp regexp, Tcl_Size index, const char **startPtr, const char **endPtr); /* 215 */ void (*tcl_Release) (void *clientData); /* 216 */ void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */ - size_t (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */ - size_t (*tcl_ScanCountedElement) (const char *src, size_t length, int *flagPtr); /* 219 */ + Tcl_Size (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */ + Tcl_Size (*tcl_ScanCountedElement) (const char *src, Tcl_Size length, int *flagPtr); /* 219 */ void (*reserved220)(void); int (*tcl_ServiceAll) (void); /* 221 */ int (*tcl_ServiceEvent) (int flags); /* 222 */ @@ -2018,7 +2022,7 @@ typedef struct TclStubs { void (*reserved247)(void); int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 248 */ char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */ - size_t (*tcl_Ungets) (Tcl_Channel chan, const char *str, size_t len, int atHead); /* 250 */ + Tcl_Size (*tcl_Ungets) (Tcl_Channel chan, const char *str, Tcl_Size len, int atHead); /* 250 */ void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */ int (*tcl_UnregisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 252 */ void (*reserved253)(void); @@ -2031,7 +2035,7 @@ typedef struct TclStubs { int (*tcl_VarEval) (Tcl_Interp *interp, ...); /* 260 */ void (*reserved261)(void); void * (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 262 */ - size_t (*tcl_Write) (Tcl_Channel chan, const char *s, size_t slen); /* 263 */ + Tcl_Size (*tcl_Write) (Tcl_Channel chan, const char *s, Tcl_Size slen); /* 263 */ void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */ int (*tcl_DumpActiveMemory) (const char *fileName); /* 265 */ void (*tcl_ValidateAllMemory) (const char *file, int line); /* 266 */ @@ -2059,12 +2063,12 @@ typedef struct TclStubs { void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 288 */ void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 289 */ void (*reserved290)(void); - int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, size_t numBytes, int flags); /* 291 */ + int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, Tcl_Size numBytes, int flags); /* 291 */ int (*tcl_EvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 292 */ int (*tcl_EvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 293 */ TCL_NORETURN1 void (*tcl_ExitThread) (int status); /* 294 */ - int (*tcl_ExternalToUtf) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, size_t srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, size_t dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */ - char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, size_t srcLen, Tcl_DString *dsPtr); /* 296 */ + int (*tcl_ExternalToUtf) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */ + char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr); /* 296 */ void (*tcl_FinalizeThread) (void); /* 297 */ void (*tcl_FinalizeNotifier) (void *clientData); /* 298 */ void (*tcl_FreeEncoding) (Tcl_Encoding encoding); /* 299 */ @@ -2072,42 +2076,42 @@ typedef struct TclStubs { Tcl_Encoding (*tcl_GetEncoding) (Tcl_Interp *interp, const char *name); /* 301 */ const char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */ void (*tcl_GetEncodingNames) (Tcl_Interp *interp); /* 303 */ - int (*tcl_GetIndexFromObjStruct) (Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, size_t offset, const char *msg, int flags, int *indexPtr); /* 304 */ - void * (*tcl_GetThreadData) (Tcl_ThreadDataKey *keyPtr, size_t size); /* 305 */ + int (*tcl_GetIndexFromObjStruct) (Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, Tcl_Size offset, const char *msg, int flags, int *indexPtr); /* 304 */ + void * (*tcl_GetThreadData) (Tcl_ThreadDataKey *keyPtr, Tcl_Size size); /* 305 */ Tcl_Obj * (*tcl_GetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 306 */ void * (*tcl_InitNotifier) (void); /* 307 */ void (*tcl_MutexLock) (Tcl_Mutex *mutexPtr); /* 308 */ void (*tcl_MutexUnlock) (Tcl_Mutex *mutexPtr); /* 309 */ void (*tcl_ConditionNotify) (Tcl_Condition *condPtr); /* 310 */ void (*tcl_ConditionWait) (Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 311 */ - size_t (*tcl_NumUtfChars) (const char *src, size_t length); /* 312 */ - size_t (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, size_t charsToRead, int appendFlag); /* 313 */ + Tcl_Size (*tcl_NumUtfChars) (const char *src, Tcl_Size length); /* 312 */ + Tcl_Size (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, Tcl_Size charsToRead, int appendFlag); /* 313 */ void (*reserved314)(void); void (*reserved315)(void); int (*tcl_SetSystemEncoding) (Tcl_Interp *interp, const char *name); /* 316 */ Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */ void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */ void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 319 */ - int (*tcl_UniCharAtIndex) (const char *src, size_t index); /* 320 */ + int (*tcl_UniCharAtIndex) (const char *src, Tcl_Size index); /* 320 */ int (*tcl_UniCharToLower) (int ch); /* 321 */ int (*tcl_UniCharToTitle) (int ch); /* 322 */ int (*tcl_UniCharToUpper) (int ch); /* 323 */ int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */ - const char * (*tcl_UtfAtIndex) (const char *src, size_t index); /* 325 */ - int (*tclUtfCharComplete) (const char *src, size_t length); /* 326 */ - size_t (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */ + const char * (*tcl_UtfAtIndex) (const char *src, Tcl_Size index); /* 325 */ + int (*tclUtfCharComplete) (const char *src, Tcl_Size length); /* 326 */ + Tcl_Size (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */ const char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */ const char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */ const char * (*tclUtfNext) (const char *src); /* 330 */ const char * (*tclUtfPrev) (const char *src, const char *start); /* 331 */ - int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, size_t srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, size_t dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */ - char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, size_t srcLen, Tcl_DString *dsPtr); /* 333 */ + int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */ + char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr); /* 333 */ int (*tcl_UtfToLower) (char *src); /* 334 */ int (*tcl_UtfToTitle) (char *src); /* 335 */ int (*tcl_UtfToChar16) (const char *src, unsigned short *chPtr); /* 336 */ int (*tcl_UtfToUpper) (char *src); /* 337 */ - size_t (*tcl_WriteChars) (Tcl_Channel chan, const char *src, size_t srcLen); /* 338 */ - size_t (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */ + Tcl_Size (*tcl_WriteChars) (Tcl_Channel chan, const char *src, Tcl_Size srcLen); /* 338 */ + Tcl_Size (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */ char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */ void (*reserved341)(void); void (*reserved342)(void); @@ -2122,17 +2126,17 @@ typedef struct TclStubs { int (*tcl_UniCharIsWordChar) (int ch); /* 351 */ void (*reserved352)(void); void (*reserved353)(void); - char * (*tcl_Char16ToUtfDString) (const unsigned short *uniStr, size_t uniLength, Tcl_DString *dsPtr); /* 354 */ - unsigned short * (*tcl_UtfToChar16DString) (const char *src, size_t length, Tcl_DString *dsPtr); /* 355 */ + char * (*tcl_Char16ToUtfDString) (const unsigned short *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr); /* 354 */ + unsigned short * (*tcl_UtfToChar16DString) (const char *src, Tcl_Size length, Tcl_DString *dsPtr); /* 355 */ Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */ void (*reserved357)(void); void (*tcl_FreeParse) (Tcl_Parse *parsePtr); /* 358 */ - void (*tcl_LogCommandInfo) (Tcl_Interp *interp, const char *script, const char *command, size_t length); /* 359 */ - int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, size_t numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 360 */ - int (*tcl_ParseCommand) (Tcl_Interp *interp, const char *start, size_t numBytes, int nested, Tcl_Parse *parsePtr); /* 361 */ - int (*tcl_ParseExpr) (Tcl_Interp *interp, const char *start, size_t numBytes, Tcl_Parse *parsePtr); /* 362 */ - int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, size_t numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 363 */ - int (*tcl_ParseVarName) (Tcl_Interp *interp, const char *start, size_t numBytes, Tcl_Parse *parsePtr, int append); /* 364 */ + void (*tcl_LogCommandInfo) (Tcl_Interp *interp, const char *script, const char *command, Tcl_Size length); /* 359 */ + int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 360 */ + int (*tcl_ParseCommand) (Tcl_Interp *interp, const char *start, Tcl_Size numBytes, int nested, Tcl_Parse *parsePtr); /* 361 */ + int (*tcl_ParseExpr) (Tcl_Interp *interp, const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr); /* 362 */ + int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 363 */ + int (*tcl_ParseVarName) (Tcl_Interp *interp, const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr, int append); /* 364 */ char * (*tcl_GetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 365 */ int (*tcl_Chdir) (const char *dirName); /* 366 */ int (*tcl_Access) (const char *path, int mode); /* 367 */ @@ -2144,14 +2148,14 @@ typedef struct TclStubs { int (*tcl_UniCharIsGraph) (int ch); /* 373 */ int (*tcl_UniCharIsPrint) (int ch); /* 374 */ int (*tcl_UniCharIsPunct) (int ch); /* 375 */ - int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, size_t offset, size_t nmatches, int flags); /* 376 */ + int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, Tcl_Size offset, Tcl_Size nmatches, int flags); /* 376 */ void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */ - Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, size_t numChars); /* 378 */ - void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, size_t numChars); /* 379 */ - size_t (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ - int (*tcl_GetUniChar) (Tcl_Obj *objPtr, size_t index); /* 381 */ + Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, Tcl_Size numChars); /* 378 */ + void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, Tcl_Size numChars); /* 379 */ + Tcl_Size (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ + int (*tcl_GetUniChar) (Tcl_Obj *objPtr, Tcl_Size index); /* 381 */ void (*reserved382)(void); - Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, size_t first, size_t last); /* 383 */ + Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 383 */ void (*reserved384)(void); int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ void (*tcl_SetNotifier) (Tcl_NotifierProcs *notifierProcPtr); /* 386 */ @@ -2161,9 +2165,9 @@ typedef struct TclStubs { int (*tcl_ProcObjCmd) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 390 */ void (*tcl_ConditionFinalize) (Tcl_Condition *condPtr); /* 391 */ void (*tcl_MutexFinalize) (Tcl_Mutex *mutex); /* 392 */ - int (*tcl_CreateThread) (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, size_t stackSize, int flags); /* 393 */ - size_t (*tcl_ReadRaw) (Tcl_Channel chan, char *dst, size_t bytesToRead); /* 394 */ - size_t (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, size_t srcLen); /* 395 */ + int (*tcl_CreateThread) (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, Tcl_Size stackSize, int flags); /* 393 */ + Tcl_Size (*tcl_ReadRaw) (Tcl_Channel chan, char *dst, Tcl_Size bytesToRead); /* 394 */ + Tcl_Size (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, Tcl_Size srcLen); /* 395 */ Tcl_Channel (*tcl_GetTopChannel) (Tcl_Channel chan); /* 396 */ int (*tcl_ChannelBuffered) (Tcl_Channel chan); /* 397 */ const char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */ @@ -2196,11 +2200,11 @@ typedef struct TclStubs { void * (*tcl_CommandTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, void *prevClientData); /* 425 */ int (*tcl_TraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 426 */ void (*tcl_UntraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 427 */ - void * (*tcl_AttemptAlloc) (size_t size); /* 428 */ - void * (*tcl_AttemptDbCkalloc) (size_t size, const char *file, int line); /* 429 */ - void * (*tcl_AttemptRealloc) (void *ptr, size_t size); /* 430 */ - void * (*tcl_AttemptDbCkrealloc) (void *ptr, size_t size, const char *file, int line); /* 431 */ - int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, size_t length); /* 432 */ + void * (*tcl_AttemptAlloc) (Tcl_Size size); /* 428 */ + void * (*tcl_AttemptDbCkalloc) (Tcl_Size size, const char *file, int line); /* 429 */ + void * (*tcl_AttemptRealloc) (void *ptr, Tcl_Size size); /* 430 */ + void * (*tcl_AttemptDbCkrealloc) (void *ptr, Tcl_Size size, const char *file, int line); /* 431 */ + int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, Tcl_Size length); /* 432 */ Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */ Tcl_UniChar * (*tclGetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */ void (*reserved435)(void); @@ -2249,7 +2253,7 @@ typedef struct TclStubs { Tcl_PathType (*tcl_FSGetPathType) (Tcl_Obj *pathPtr); /* 478 */ int (*tcl_OutputBuffered) (Tcl_Channel chan); /* 479 */ void (*tcl_FSMountsChanged) (const Tcl_Filesystem *fsPtr); /* 480 */ - int (*tcl_EvalTokensStandard) (Tcl_Interp *interp, Tcl_Token *tokenPtr, size_t count); /* 481 */ + int (*tcl_EvalTokensStandard) (Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Size count); /* 481 */ void (*tcl_GetTime) (Tcl_Time *timeBuf); /* 482 */ Tcl_Trace (*tcl_CreateObjTrace) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 483 */ int (*tcl_GetCommandInfoFromToken) (Tcl_Command token, Tcl_CmdInfo *infoPtr); /* 484 */ @@ -2343,7 +2347,7 @@ typedef struct TclStubs { const char * (*tcl_GetEncodingNameFromEnvironment) (Tcl_DString *bufPtr); /* 572 */ int (*tcl_PkgRequireProc) (Tcl_Interp *interp, const char *name, int objc, Tcl_Obj *const objv[], void *clientDataPtr); /* 573 */ void (*tcl_AppendObjToErrorInfo) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 574 */ - void (*tcl_AppendLimitedToObj) (Tcl_Obj *objPtr, const char *bytes, size_t length, size_t limit, const char *ellipsis); /* 575 */ + void (*tcl_AppendLimitedToObj) (Tcl_Obj *objPtr, const char *bytes, Tcl_Size length, Tcl_Size limit, const char *ellipsis); /* 575 */ Tcl_Obj * (*tcl_Format) (Tcl_Interp *interp, const char *format, int objc, Tcl_Obj *const objv[]); /* 576 */ int (*tcl_AppendFormatToObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, int objc, Tcl_Obj *const objv[]); /* 577 */ Tcl_Obj * (*tcl_ObjPrintf) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 578 */ @@ -2379,15 +2383,15 @@ typedef struct TclStubs { int (*tcl_InterpActive) (Tcl_Interp *interp); /* 608 */ void (*tcl_BackgroundException) (Tcl_Interp *interp, int code); /* 609 */ int (*tcl_ZlibDeflate) (Tcl_Interp *interp, int format, Tcl_Obj *data, int level, Tcl_Obj *gzipHeaderDictObj); /* 610 */ - int (*tcl_ZlibInflate) (Tcl_Interp *interp, int format, Tcl_Obj *data, size_t buffersize, Tcl_Obj *gzipHeaderDictObj); /* 611 */ - unsigned int (*tcl_ZlibCRC32) (unsigned int crc, const unsigned char *buf, size_t len); /* 612 */ - unsigned int (*tcl_ZlibAdler32) (unsigned int adler, const unsigned char *buf, size_t len); /* 613 */ + int (*tcl_ZlibInflate) (Tcl_Interp *interp, int format, Tcl_Obj *data, Tcl_Size buffersize, Tcl_Obj *gzipHeaderDictObj); /* 611 */ + unsigned int (*tcl_ZlibCRC32) (unsigned int crc, const unsigned char *buf, Tcl_Size len); /* 612 */ + unsigned int (*tcl_ZlibAdler32) (unsigned int adler, const unsigned char *buf, Tcl_Size len); /* 613 */ int (*tcl_ZlibStreamInit) (Tcl_Interp *interp, int mode, int format, int level, Tcl_Obj *dictObj, Tcl_ZlibStream *zshandle); /* 614 */ Tcl_Obj * (*tcl_ZlibStreamGetCommandName) (Tcl_ZlibStream zshandle); /* 615 */ int (*tcl_ZlibStreamEof) (Tcl_ZlibStream zshandle); /* 616 */ int (*tcl_ZlibStreamChecksum) (Tcl_ZlibStream zshandle); /* 617 */ int (*tcl_ZlibStreamPut) (Tcl_ZlibStream zshandle, Tcl_Obj *data, int flush); /* 618 */ - int (*tcl_ZlibStreamGet) (Tcl_ZlibStream zshandle, Tcl_Obj *data, size_t count); /* 619 */ + int (*tcl_ZlibStreamGet) (Tcl_ZlibStream zshandle, Tcl_Obj *data, Tcl_Size count); /* 619 */ int (*tcl_ZlibStreamClose) (Tcl_ZlibStream zshandle); /* 620 */ int (*tcl_ZlibStreamReset) (Tcl_ZlibStream zshandle); /* 621 */ void (*tcl_SetStartupScript) (Tcl_Obj *path, const char *encoding); /* 622 */ @@ -2405,24 +2409,24 @@ typedef struct TclStubs { Tcl_Obj * (*tclZipfs_TclLibrary) (void); /* 634 */ int (*tclZipfs_MountBuffer) (Tcl_Interp *interp, const char *mountPoint, unsigned char *data, size_t datalen, int copy); /* 635 */ void (*tcl_FreeInternalRep) (Tcl_Obj *objPtr); /* 636 */ - char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, size_t numBytes); /* 637 */ + char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, Tcl_Size numBytes); /* 637 */ Tcl_ObjInternalRep * (*tcl_FetchInternalRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 638 */ void (*tcl_StoreInternalRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjInternalRep *irPtr); /* 639 */ int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */ void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */ void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */ int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */ - int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, size_t size); /* 644 */ - int (*tcl_GetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t endValue, size_t *indexPtr); /* 645 */ + int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, Tcl_Size size); /* 644 */ + int (*tcl_GetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size endValue, Tcl_Size *indexPtr); /* 645 */ int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */ - char * (*tcl_UniCharToUtfDString) (const int *uniStr, size_t uniLength, Tcl_DString *dsPtr); /* 647 */ - int * (*tcl_UtfToUniCharDString) (const char *src, size_t length, Tcl_DString *dsPtr); /* 648 */ - unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *lengthPtr); /* 649 */ - unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *lengthPtr); /* 650 */ + char * (*tcl_UniCharToUtfDString) (const int *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr); /* 647 */ + int * (*tcl_UtfToUniCharDString) (const char *src, Tcl_Size length, Tcl_DString *dsPtr); /* 648 */ + unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *numBytesPtr); /* 649 */ + unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *numBytesPtr); /* 650 */ char * (*tcl_GetStringFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 651 */ Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 652 */ - unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 653 */ - int (*tcl_UtfCharComplete) (const char *src, size_t length); /* 654 */ + unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, size_t *numBytesPtr); /* 653 */ + int (*tcl_UtfCharComplete) (const char *src, Tcl_Size length); /* 654 */ const char * (*tcl_UtfNext) (const char *src); /* 655 */ const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */ int (*tcl_UniCharIsUnicode) (int ch); /* 657 */ diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index 871a2d3..bcaff5e 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -63,7 +63,7 @@ extern "C" { EXTERN int Tcl_MacOSXOpenVersionedBundleResources( Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, - int hasResourceFile, size_t maxPathLen, + int hasResourceFile, Tcl_Size maxPathLen, char *libraryPath); /* 2 */ EXTERN void Tcl_MacOSXNotifierAddRunLoopMode( @@ -76,7 +76,7 @@ typedef struct TclPlatStubs { void *hooks; void (*reserved0)(void); - int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, size_t maxPathLen, char *libraryPath); /* 1 */ + int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, Tcl_Size maxPathLen, char *libraryPath); /* 1 */ void (*tcl_MacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 2 */ void (*tcl_WinConvertError) (unsigned errCode); /* 3 */ } TclPlatStubs; -- cgit v0.12 From e3074edc8ab3d499540f736d2beebe02d46200aa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 22 Feb 2022 21:01:20 +0000 Subject: TIP #618: New Tcl_GetBool* functions with INDEX_NULL_OK flag --- doc/BoolObj.3 | 13 ++++++++--- doc/GetIndex.3 | 4 ++-- generic/tcl.decls | 13 +++++++++-- generic/tcl.h | 4 ++-- generic/tclCmdMZ.c | 2 +- generic/tclDecls.h | 61 +++++++++++++++++++++++++++++++++++++++++++++++---- generic/tclExecute.c | 8 +++---- generic/tclGet.c | 23 ++++++++++++++++--- generic/tclIndexObj.c | 8 +++---- generic/tclInt.h | 4 ++-- generic/tclObj.c | 57 ++++++++++++++++++++++++++++++++++++++--------- generic/tclStubInit.c | 9 ++++++++ generic/tclTest.c | 15 +++++++------ tests/indexObj.test | 4 ++-- 14 files changed, 179 insertions(+), 46 deletions(-) diff --git a/doc/BoolObj.3 b/doc/BoolObj.3 index 9bbdc7e..afbd1d1 100644 --- a/doc/BoolObj.3 +++ b/doc/BoolObj.3 @@ -9,7 +9,7 @@ .so man.macros .BS .SH NAME -Tcl_NewBooleanObj, Tcl_SetBooleanObj, Tcl_GetBooleanFromObj \- store/retrieve boolean value in a Tcl_Obj +Tcl_NewBooleanObj, Tcl_SetBooleanObj, Tcl_GetBooleanFromObj, Tcl_GetBoolFromObj \- store/retrieve boolean value in a Tcl_Obj .SH SYNOPSIS .nf \fB#include \fR @@ -21,6 +21,9 @@ Tcl_Obj * .sp int \fBTcl_GetBooleanFromObj\fR(\fIinterp, objPtr, boolPtr\fR) +.sp +int +\fBTcl_GetBoolFromObj\fR(\fIinterp, objPtr, flags. boolPtr\fR) .SH ARGUMENTS .AS Tcl_Interp boolValue in/out .AP int boolValue in @@ -32,9 +35,13 @@ retrieve a boolean value. If a boolean value cannot be retrieved, an error message is left in the interpreter's result value unless \fIinterp\fR is NULL. -.AP int *boolPtr out -Points to place where \fBTcl_GetBooleanFromObj\fR +.AP int | short | char *boolPtr out +Points to place where \fBTcl_GetBooleanFromObj\fR/\fBTcl_GetBoolFromObj\fR stores the boolean value (0 or 1) obtained from \fIobjPtr\fR. +.AP int flags in +Value 0 or TCL_NULL_OK. If TCL_NULL_OK, then the empty +string or NULL will result in \fBTcl_GetBoolFromObj\fR return +TCL_OK, the *boolPtr filled with the value -1; .BE .SH DESCRIPTION diff --git a/doc/GetIndex.3 b/doc/GetIndex.3 index 1169c6c..176b0b2 100644 --- a/doc/GetIndex.3 +++ b/doc/GetIndex.3 @@ -54,7 +54,7 @@ Null-terminated string describing what is being looked up, such as .AP int flags in OR-ed combination of bits providing additional information for operation. The only bits that are currently defined are \fBTCL_EXACT\fR -, \fBTCL_INDEX_TEMP_TABLE\fR, and \fBTCL_INDEX_NULL_OK\fR. +, \fBTCL_INDEX_TEMP_TABLE\fR, and \fBTCL_NULL_OK\fR. .AP enum|char|short|int|long *indexPtr out If not (int *)NULL, the index of the string in \fItablePtr\fR that matches the value of \fIobjPtr\fR is returned here. The variable can @@ -93,7 +93,7 @@ operation. Note: \fBTcl_GetIndexFromObj\fR assumes that the entries in \fItablePtr\fR are static: they must not change between invocations. This caching mechanism can be disallowed by specifying the \fBTCL_INDEX_TEMP_TABLE\fR flag. -If the \fBTCL_INDEX_NULL_OK\fR flag was specified, objPtr is allowed +If the \fBTCL_NULL_OK\fR flag was specified, objPtr is allowed to be NULL or the empty string. The resulting index is -1. Otherwise, if the value of \fIobjPtr\fR is the empty string, \fBTcl_GetIndexFromObj\fR will treat it as a non-matching value diff --git a/generic/tcl.decls b/generic/tcl.decls index c137a88..4d630ca 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -136,11 +136,11 @@ declare 30 { void TclFreeObj(Tcl_Obj *objPtr) } declare 31 { - int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *boolPtr) + int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, void *boolPtr) } declare 32 { int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - int *boolPtr) + void *boolPtr) } declare 33 { unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *numBytesPtr) @@ -2442,6 +2442,15 @@ declare 660 { int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber) } +declare 668 { + int Tcl_GetBool(Tcl_Interp *interp, const char *src, int flags, + void *boolPtr) +} +declare 669 { + int Tcl_GetBoolFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + int flags, void *boolPtr) +} + # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## diff --git a/generic/tcl.h b/generic/tcl.h index b82cf0a..560d441 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -979,13 +979,13 @@ typedef struct Tcl_DString { * TCL_EXACT disallows abbreviated strings. * TCL_INDEX_TEMP_TABLE disallows caching of lookups. A possible use case is * a table that will not live long enough to make it worthwhile. - * TCL_INDEX_NULL_OK allows the empty string or NULL to return TCL_OK. + * TCL_NULL_OK allows the empty string or NULL to return TCL_OK. * The returned value will be -1; */ #define TCL_EXACT 1 #define TCL_INDEX_TEMP_TABLE 2 -#define TCL_INDEX_NULL_OK 4 +#define TCL_NULL_OK 32 /* *---------------------------------------------------------------------------- diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index f394035..6b991eb 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1620,7 +1620,7 @@ StringIsCmd( result = length1 == 0; } } else if (index != STR_IS_BOOL) { - TclGetBooleanFromObj(NULL, objPtr, &i); + TclGetBoolFromObj(NULL, objPtr, 0, &i); if ((index == STR_IS_TRUE) ^ i) { result = 0; } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index b5697ea..da28cb7 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -146,10 +146,10 @@ EXTERN Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr); EXTERN void TclFreeObj(Tcl_Obj *objPtr); /* 31 */ EXTERN int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, - int *boolPtr); + void *boolPtr); /* 32 */ EXTERN int Tcl_GetBooleanFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, int *boolPtr); + Tcl_Obj *objPtr, void *boolPtr); /* 33 */ EXTERN unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *numBytesPtr); @@ -1948,6 +1948,19 @@ EXTERN int Tcl_UniCharIsUnicode(int ch); /* 660 */ EXTERN int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber); +/* Slot 661 is reserved */ +/* Slot 662 is reserved */ +/* Slot 663 is reserved */ +/* Slot 664 is reserved */ +/* Slot 665 is reserved */ +/* Slot 666 is reserved */ +/* Slot 667 is reserved */ +/* 668 */ +EXTERN int Tcl_GetBool(Tcl_Interp *interp, const char *src, + int flags, void *boolPtr); +/* 669 */ +EXTERN int Tcl_GetBoolFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, int flags, void *boolPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2006,8 +2019,8 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, int length, const char *file, int line); /* 28 */ Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */ void (*tclFreeObj) (Tcl_Obj *objPtr); /* 30 */ - int (*tcl_GetBoolean) (Tcl_Interp *interp, const char *src, int *boolPtr); /* 31 */ - int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *boolPtr); /* 32 */ + int (*tcl_GetBoolean) (Tcl_Interp *interp, const char *src, void *boolPtr); /* 31 */ + int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void *boolPtr); /* 32 */ unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *numBytesPtr); /* 33 */ int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */ int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */ @@ -2644,6 +2657,15 @@ typedef struct TclStubs { void (*reserved658)(void); void (*reserved659)(void); int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */ + void (*reserved661)(void); + void (*reserved662)(void); + void (*reserved663)(void); + void (*reserved664)(void); + void (*reserved665)(void); + void (*reserved666)(void); + void (*reserved667)(void); + int (*tcl_GetBool) (Tcl_Interp *interp, const char *src, int flags, void *boolPtr); /* 668 */ + int (*tcl_GetBoolFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, void *boolPtr); /* 669 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -3994,6 +4016,17 @@ extern const TclStubs *tclStubsPtr; /* Slot 659 is reserved */ #define Tcl_AsyncMarkFromSignal \ (tclStubsPtr->tcl_AsyncMarkFromSignal) /* 660 */ +/* Slot 661 is reserved */ +/* Slot 662 is reserved */ +/* Slot 663 is reserved */ +/* Slot 664 is reserved */ +/* Slot 665 is reserved */ +/* Slot 666 is reserved */ +/* Slot 667 is reserved */ +#define Tcl_GetBool \ + (tclStubsPtr->tcl_GetBool) /* 668 */ +#define Tcl_GetBoolFromObj \ + (tclStubsPtr->tcl_GetBoolFromObj) /* 669 */ #endif /* defined(USE_TCL_STUBS) */ @@ -4210,6 +4243,10 @@ extern const TclStubs *tclStubsPtr; Tcl_GetUnicodeFromObj(objPtr, (int *)NULL) #undef Tcl_GetBytesFromObj #undef Tcl_GetIndexFromObjStruct +#undef Tcl_GetBoolFromObj +#undef Tcl_GetBool +#undef Tcl_GetBooleanFromObj +#undef Tcl_GetBoolean #ifdef TCL_NO_DEPRECATED #undef Tcl_GetStringFromObj #undef Tcl_GetUnicodeFromObj @@ -4220,6 +4257,14 @@ extern const TclStubs *tclStubsPtr; (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)sizePtr) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)sizePtr)) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*indexPtr)<<8), (indexPtr))) +#define Tcl_GetBoolFromObj(interp, objPtr, flags, boolPtr) \ + (tclStubsPtr->tcl_GetBoolFromObj((interp), (objPtr), (flags)|(int)(sizeof(*boolPtr)<<8), (boolPtr))) +#define Tcl_GetBool(interp, objPtr, flags, boolPtr) \ + (tclStubsPtr->tcl_GetBool((interp), (objPtr), (flags)|(int)(sizeof(*boolPtr)<<8), (boolPtr))) +#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ + (sizeof(*boolPtr) == sizeof(int) ? tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)boolPtr) : Tcl_GetBoolFromObj(interp, objPtr, 0, boolPtr)) +#define Tcl_GetBoolean(interp, src, boolPtr) \ + (sizeof(*boolPtr) == sizeof(int) ? tclStubsPtr->tcl_GetBoolean(interp, src, (int *)boolPtr) : Tcl_GetBool(interp, src, 0, boolPtr)) #ifdef TCL_NO_DEPRECATED #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*sizePtr) <= sizeof(int) ? tclStubsPtr->tcl_GetStringFromObj(objPtr, (int *)sizePtr) : tclStubsPtr->tclGetStringFromObj(objPtr, (size_t *)sizePtr)) @@ -4233,6 +4278,14 @@ extern const TclStubs *tclStubsPtr; (sizeof(*sizePtr) <= sizeof(int) ? (TclGetBytesFromObj)(interp, objPtr, (int *)sizePtr) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)sizePtr)) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*indexPtr)<<8), (indexPtr))) +#define Tcl_GetBoolFromObj(interp, objPtr, flags, boolPtr) \ + ((Tcl_GetBoolFromObj)((interp), (objPtr), (flags)|(int)(sizeof(*boolPtr)<<8), (boolPtr))) +#define Tcl_GetBool(interp, objPtr, flags, boolPtr) \ + ((Tcl_GetBool)((interp), (objPtr), (flags)|(int)(sizeof(*boolPtr)<<8), (boolPtr))) +#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ + (sizeof(*boolPtr) == sizeof(int) ? (Tcl_GetBooleanFromObj)(interp, objPtr, (int *)boolPtr) : Tcl_GetBoolFromObj(interp, objPtr, 0, boolPtr)) +#define Tcl_GetBoolean(interp, src, boolPtr) \ + (sizeof(*boolPtr) == sizeof(int) ? (Tcl_GetBoolean)(interp, src, (int *)boolPtr) : Tcl_GetBool(interp, src, 0, boolPtr)) #ifdef TCL_NO_DEPRECATED #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*sizePtr) <= sizeof(int) ? (Tcl_GetStringFromObj)(objPtr, (int *)sizePtr) : (TclGetStringFromObj)(objPtr, (size_t *)sizePtr)) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index dfb195a..2c4cde4 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4346,7 +4346,7 @@ TEBCresume( /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ - if (TclGetBooleanFromObj(interp, valuePtr, &b) != TCL_OK) { + if (TclGetBoolFromObj(interp, valuePtr, 0, &b) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -4414,7 +4414,7 @@ TEBCresume( value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; - if (TclGetBooleanFromObj(NULL, valuePtr, &i1) != TCL_OK) { + if (TclGetBoolFromObj(NULL, valuePtr, 0, &i1) != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); @@ -4423,7 +4423,7 @@ TEBCresume( goto gotError; } - if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) { + if (TclGetBoolFromObj(NULL, value2Ptr, 0, &i2) != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); DECACHE_STACK_INFO(); @@ -6222,7 +6222,7 @@ TEBCresume( /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ - if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) { + if (TclGetBoolFromObj(NULL, valuePtr, 0, &b) != TCL_OK) { TRACE(("\"%.20s\" => ERROR: illegal type %s\n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); diff --git a/generic/tclGet.c b/generic/tclGet.c index 970e093..1beac24 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -121,17 +121,22 @@ Tcl_GetDouble( *---------------------------------------------------------------------- */ +#undef Tcl_GetBool int -Tcl_GetBoolean( +Tcl_GetBool( Tcl_Interp *interp, /* Interpreter used for error reporting. */ const char *src, /* String containing one of the boolean values * 1, 0, true, false, yes, no, on, off. */ - int *boolPtr) /* Place to store converted result, which will + int flags, + void *boolPtr) /* Place to store converted result, which will * be 0 or 1. */ { Tcl_Obj obj; int code; + if (((src == NULL) || (*src == '\0')) && (flags & TCL_NULL_OK)) { + return (Tcl_GetBoolFromObj)(NULL, NULL, flags, boolPtr); + } obj.refCount = 1; obj.bytes = (char *) src; obj.length = strlen(src); @@ -142,10 +147,22 @@ Tcl_GetBoolean( Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } if (code == TCL_OK) { - TclGetBooleanFromObj(NULL, &obj, boolPtr); + (Tcl_GetBoolFromObj)(NULL, &obj, flags, boolPtr); } return code; } + +#undef Tcl_GetBoolean +int +Tcl_GetBoolean( + Tcl_Interp *interp, /* Interpreter used for error reporting. */ + const char *src, /* String containing one of the boolean values + * 1, 0, true, false, yes, no, on, off. */ + void *boolPtr) /* Place to store converted result, which will + * be 0 or 1. */ +{ + return Tcl_GetBool(interp, src, 0, boolPtr); +} /* * Local Variables: diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 1f600c5..f5e3958 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -263,7 +263,7 @@ Tcl_GetIndexFromObjStruct( int offset, /* The number of bytes between entries */ const char *msg, /* Identifying word to use in error * messages. */ - int flags, /* 0, TCL_EXACT, TCL_INDEX_TEMP_TABLE or TCL_INDEX_NULL_OK */ + int flags, /* 0, TCL_EXACT, TCL_INDEX_TEMP_TABLE or TCL_NULL_OK */ void *indexPtr) /* Place to store resulting index. */ { int index, idx, numAbbrev; @@ -304,7 +304,7 @@ Tcl_GetIndexFromObjStruct( index = -1; numAbbrev = 0; - if (!*key && (flags & TCL_INDEX_NULL_OK)) { + if (!*key && (flags & TCL_NULL_OK)) { goto uncachedDone; } /* @@ -411,7 +411,7 @@ Tcl_GetIndexFromObjStruct( *entryPtr, NULL); entryPtr = NEXT_ENTRY(entryPtr, offset); while (*entryPtr != NULL) { - if ((*NEXT_ENTRY(entryPtr, offset) == NULL) && !(flags & TCL_INDEX_NULL_OK)) { + if ((*NEXT_ENTRY(entryPtr, offset) == NULL) && !(flags & TCL_NULL_OK)) { Tcl_AppendStringsToObj(resultPtr, (count > 0 ? "," : ""), " or ", *entryPtr, NULL); } else if (**entryPtr) { @@ -420,7 +420,7 @@ Tcl_GetIndexFromObjStruct( } entryPtr = NEXT_ENTRY(entryPtr, offset); } - if ((flags & TCL_INDEX_NULL_OK)) { + if ((flags & TCL_NULL_OK)) { Tcl_AppendStringsToObj(resultPtr, ", or \"\"", NULL); } } diff --git a/generic/tclInt.h b/generic/tclInt.h index 75cd6e5..25593b2 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2504,12 +2504,12 @@ typedef struct List { * WARNING: these macros eval their args more than once. */ -#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ +#define TclGetBoolFromObj(interp, objPtr, flags, boolPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(boolPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ : ((objPtr)->typePtr == &tclBooleanType) \ ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ - : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr))) + : Tcl_GetBoolFromObj((interp), (objPtr), (flags), (boolPtr))) #ifdef TCL_WIDE_INT_IS_LONG #define TclGetLongFromObj(interp, objPtr, longPtr) \ diff --git a/generic/tclObj.c b/generic/tclObj.c index a06b8fd..636f8e0 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2139,7 +2139,7 @@ Tcl_SetBooleanObj( /* *---------------------------------------------------------------------- * - * Tcl_GetBooleanFromObj -- + * Tcl_GetBoolFromObj, Tcl_GetBooleanFromObj -- * * Attempt to return a boolean from the Tcl object "objPtr". This * includes conversion from any of Tcl's numeric types. @@ -2155,20 +2155,28 @@ Tcl_SetBooleanObj( *---------------------------------------------------------------------- */ +#undef Tcl_GetBoolFromObj int -Tcl_GetBooleanFromObj( +Tcl_GetBoolFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* The object from which to get boolean. */ - int *boolPtr) /* Place to store resulting boolean. */ + int flags, + void *boolPtr) /* Place to store resulting boolean. */ { + int result; + + if ((flags & TCL_NULL_OK) && (objPtr == NULL || Tcl_GetString(objPtr)[0] == '\0')) { + result = -1; + goto boolEnd; + } do { if (objPtr->typePtr == &tclIntType) { - *boolPtr = (objPtr->internalRep.wideValue != 0); - return TCL_OK; + result = (objPtr->internalRep.wideValue != 0); + goto boolEnd; } if (objPtr->typePtr == &tclBooleanType) { - *boolPtr = objPtr->internalRep.longValue != 0; - return TCL_OK; + result = objPtr->internalRep.longValue != 0; + goto boolEnd; } if (objPtr->typePtr == &tclDoubleType) { /* @@ -2184,11 +2192,30 @@ Tcl_GetBooleanFromObj( if (Tcl_GetDoubleFromObj(interp, objPtr, &d) != TCL_OK) { return TCL_ERROR; } - *boolPtr = (d != 0.0); - return TCL_OK; + result = (d != 0.0); + goto boolEnd; } if (objPtr->typePtr == &tclBignumType) { - *boolPtr = 1; + result = 1; + boolEnd: + if (boolPtr != NULL) { + if ((flags>>8) & (int)~sizeof(int)) { + if ((flags>>8) == sizeof(uint64_t)) { + *(uint64_t *)boolPtr = result; + return TCL_OK; + } else if ((flags>>8) == sizeof(uint32_t)) { + *(uint32_t *)boolPtr = result; + return TCL_OK; + } else if ((flags>>8) == sizeof(uint16_t)) { + *(uint16_t *)boolPtr = result; + return TCL_OK; + } else if ((flags>>8) == sizeof(uint8_t)) { + *(uint8_t *)boolPtr = result; + return TCL_OK; + } + } + *(int *)boolPtr = result; + } return TCL_OK; } } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == @@ -2196,6 +2223,16 @@ Tcl_GetBooleanFromObj( return TCL_ERROR; } +#undef Tcl_GetBooleanFromObj +int +Tcl_GetBooleanFromObj( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* The object from which to get boolean. */ + void *boolPtr) /* Place to store resulting boolean. */ +{ + return Tcl_GetBoolFromObj(interp, objPtr, 0, boolPtr); +} + /* *---------------------------------------------------------------------- * diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index a1878c1..ff2b296 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1944,6 +1944,15 @@ const TclStubs tclStubs = { 0, /* 658 */ 0, /* 659 */ Tcl_AsyncMarkFromSignal, /* 660 */ + 0, /* 661 */ + 0, /* 662 */ + 0, /* 663 */ + 0, /* 664 */ + 0, /* 665 */ + 0, /* 666 */ + 0, /* 667 */ + Tcl_GetBool, /* 668 */ + Tcl_GetBoolFromObj, /* 669 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 009c95f..97fd57f 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -2174,7 +2174,7 @@ TesteventProc( Tcl_Obj *command = ev->command; int result = Tcl_EvalObjEx(interp, command, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); - int retval; + char retval[3]; if (result != TCL_OK) { Tcl_AddErrorInfo(interp, @@ -2183,18 +2183,18 @@ TesteventProc( return 1; /* Avoid looping on errors */ } if (Tcl_GetBooleanFromObj(interp, Tcl_GetObjResult(interp), - &retval) != TCL_OK) { + &retval[1]) != TCL_OK) { Tcl_AddErrorInfo(interp, " (return value from \"testevent\" callback)"); Tcl_BackgroundException(interp, TCL_ERROR); return 1; } - if (retval) { + if (retval[1]) { Tcl_DecrRefCount(ev->tag); Tcl_DecrRefCount(ev->command); } - return retval; + return retval[1]; } /* @@ -5188,7 +5188,8 @@ TestsaveresultCmd( Tcl_Obj *const objv[]) /* The argument objects. */ { Interp* iPtr = (Interp*) interp; - int discard, result, index; + int result, index; + short discard[3]; Tcl_SavedResult state; Tcl_Obj *objPtr; static const char *const optionStrings[] = { @@ -5210,7 +5211,7 @@ TestsaveresultCmd( &index) != TCL_OK) { return TCL_ERROR; } - if (Tcl_GetBooleanFromObj(interp, objv[3], &discard) != TCL_OK) { + if (Tcl_GetBooleanFromObj(interp, objv[3], &discard[1]) != TCL_OK) { return TCL_ERROR; } @@ -5247,7 +5248,7 @@ TestsaveresultCmd( result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), -1, 0); } - if (discard) { + if (discard[1]) { Tcl_DiscardResult(&state); } else { Tcl_RestoreResult(interp, &state); diff --git a/tests/indexObj.test b/tests/indexObj.test index c327274..f10bd2a 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -142,8 +142,8 @@ test indexObj-6.6 {Tcl_GetIndexFromObjStruct with NULL input} -constraints testi } -returnCodes error -result {ambiguous dummy "": must be a, c, or ee} test indexObj-6.7 {Tcl_GetIndexFromObjStruct} testindexobj { set x "" - testgetindexfromobjstruct $x -1 4 -} "wrong # args: should be \"testgetindexfromobjstruct {} -1 4\"" + testgetindexfromobjstruct $x -1 32 +} "wrong # args: should be \"testgetindexfromobjstruct {} -1 32\"" test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs { testparseargs -- cgit v0.12 From b488f3edf6ee202281aca13745c0d4212310f654 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 3 Mar 2022 13:05:38 +0000 Subject: TIP #619 implementation. tests not working yet --- generic/tcl.h | 7 +++++++ generic/tclCmdMZ.c | 2 ++ generic/tclDecls.h | 8 ++++++++ generic/tclEncoding.c | 21 ++++++++++++--------- generic/tclParse.c | 7 ++++--- generic/tclUtf.c | 18 +++++++++++++++--- tests/utf.test | 6 +++--- 7 files changed, 51 insertions(+), 18 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 6b69929..8778203 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -835,6 +835,13 @@ typedef struct Tcl_DString { #define TCL_INDEX_NULL_OK 4 /* + * Flags that may be passed to Tcl_UniCharToUtf. + * TCL_COMBINE Combine surrogates + */ + +#define TCL_COMBINE 0x200000 + +/* *---------------------------------------------------------------------------- * Flag values passed to Tcl_RecordAndEval, Tcl_EvalObj, Tcl_EvalObjv. * WARNING: these bit choices must not conflict with the bit choices for diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 85174ec..b50eacb 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1432,9 +1432,11 @@ StringIndexCmd( char buf[4] = ""; end = Tcl_UniCharToUtf(ch, buf); +#if TCL_UTF_MAX < 4 if ((ch >= 0xD800) && (end < 3)) { end += Tcl_UniCharToUtf(-1, buf + end); } +#endif Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, end)); } } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 9205401..d073edd 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3919,6 +3919,14 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfToUniChar Tcl_UtfToChar16 # undef Tcl_UniCharLen # define Tcl_UniCharLen Tcl_Char16Len +# undef Tcl_UniCharToUtf +# if defined(USE_TCL_STUBS) +# define Tcl_UniCharToUtf(c, p) \ + (tclStubsPtr->tcl_UniCharToUtf((c)|TCL_COMBINE, (p))) +# else +# define Tcl_UniCharToUtf(c, p) \ + ((Tcl_UniCharToUtf)((c)|TCL_COMBINE, (p))) +# endif #endif #if defined(USE_TCL_STUBS) # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 3a6385f..765f98b 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2228,7 +2228,6 @@ UtfToUtfProc( } dst += Tcl_UniCharToUtf(ch, dst); } else { - int low; const char *saveSrc = src; size_t len = TclUtfToUCS4(src, &ch); if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_STOPONERROR) @@ -2246,13 +2245,20 @@ UtfToUtfProc( *dst++ = (char) (((ch >> 10) & 0x3F) | 0x80); ch = (ch & 0x0CFF) | 0xDC00; } - goto cesu8; +#if TCL_UTF_MAX < 4 + cesu8: +#endif + *dst++ = (char) (((ch >> 12) | 0xE0) & 0xEF); + *dst++ = (char) (((ch >> 6) | 0x80) & 0xBF); + *dst++ = (char) ((ch | 0x80) & 0xBF); + continue; +#if TCL_UTF_MAX < 4 } else if ((ch | 0x7FF) == 0xDFFF) { /* * A surrogate character is detected, handle especially. */ - low = ch; + int low = ch; len = (src <= srcEnd-3) ? TclUtfToUCS4(src, &low) : 0; if (((low & ~0x3FF) != 0xDC00) || (ch & 0x400)) { @@ -2261,15 +2267,12 @@ UtfToUtfProc( src = saveSrc; break; } - cesu8: - *dst++ = (char) (((ch >> 12) | 0xE0) & 0xEF); - *dst++ = (char) (((ch >> 6) | 0x80) & 0xBF); - *dst++ = (char) ((ch | 0x80) & 0xBF); - continue; + goto cesu8; } src += len; dst += Tcl_UniCharToUtf(ch, dst); ch = low; +#endif } else if (!Tcl_UniCharIsUnicode(ch)) { if (flags & TCL_ENCODING_STOPONERROR) { result = TCL_CONVERT_UNKNOWN; @@ -2578,7 +2581,7 @@ Utf16ToUtfProc( if (ch && ch < 0x80) { *dst++ = (ch & 0xFF); } else { - dst += Tcl_UniCharToUtf(ch, dst); + dst += Tcl_UniCharToUtf(ch | TCL_COMBINE, dst); } src += sizeof(unsigned short); } diff --git a/generic/tclParse.c b/generic/tclParse.c index 614401f..fdd1478 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -869,6 +869,7 @@ TclParseBackslash( * No hexdigits -> This is just "u". */ result = 'u'; +#if TCL_UTF_MAX < 4 } else if (((result & 0xFC00) == 0xD800) && (count == 6) && (p[5] == '\\') && (p[6] == 'u') && (numBytes >= 10)) { /* If high surrogate is immediately followed by a low surrogate @@ -879,6 +880,7 @@ TclParseBackslash( result = ((result & 0x3FF)<<10 | (low & 0x3FF)) + 0x10000; count += count2 + 2; } +#endif } break; case 'U': @@ -888,9 +890,6 @@ TclParseBackslash( * No hexdigits -> This is just "U". */ result = 'U'; - } else if ((result | 0x7FF) == 0xDFFF) { - /* Upper or lower surrogate, not allowed in this syntax. */ - result = 0xFFFD; } break; case '\n': @@ -954,10 +953,12 @@ TclParseBackslash( *readPtr = count; } count = Tcl_UniCharToUtf(result, dst); +#if TCL_UTF_MAX < 4 if ((result >= 0xD800) && (count < 3)) { /* Special case for handling high surrogates. */ count += Tcl_UniCharToUtf(-1, dst + count); } +#endif return count; } diff --git a/generic/tclUtf.c b/generic/tclUtf.c index e353b7f..a04e41c 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -208,15 +208,23 @@ Invalid( *--------------------------------------------------------------------------- */ +#undef Tcl_UniCharToUtf int Tcl_UniCharToUtf( int ch, /* The Tcl_UniChar to be stored in the - * buffer. */ + * buffer. Can be or'ed with flag TCL_COMBINE */ char *buf) /* Buffer in which the UTF-8 representation of * the Tcl_UniChar is stored. Buffer must be * large enough to hold the UTF-8 character * (at most 4 bytes). */ { +#if TCL_UTF_MAX > 3 + int flags = ch; +#endif + + if (ch >= TCL_COMBINE) { + ch &= (TCL_COMBINE - 1); + } if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) { buf[0] = (char) ch; return 1; @@ -228,7 +236,11 @@ Tcl_UniCharToUtf( return 2; } if (ch <= 0xFFFF) { - if ((ch & 0xF800) == 0xD800) { + if ( +#if TCL_UTF_MAX > 3 + (flags & TCL_COMBINE) && +#endif + ((ch & 0xF800) == 0xD800)) { if (ch & 0x0400) { /* Low surrogate */ if (((buf[0] & 0xC0) == 0x80) && ((buf[1] & 0xCF) == 0)) { @@ -377,7 +389,7 @@ Tcl_Char16ToUtfDString( /* Special case for handling high surrogates. */ p += Tcl_UniCharToUtf(-1, p); } - len = Tcl_UniCharToUtf(*w, p); + len = Tcl_UniCharToUtf(*w | TCL_COMBINE, p); p += len; if ((*w >= 0xD800) && (len < 3)) { len = 0; /* Indication that high surrogate was found */ diff --git a/tests/utf.test b/tests/utf.test index 09599b6..f094a23 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -78,11 +78,11 @@ test utf-1.11 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring test utf-1.12 {Tcl_UniCharToUtf: 4 byte sequence, high/low surrogate} {pairsTo4bytes testbytestring} { expr {"\uD842\uDC42" eq [testbytestring \xF0\xA0\xA1\x82]} } 1 -test utf-1.13.0 {Tcl_UniCharToUtf: Invalid surrogate} {Uesc ucs2} { +test utf-1.13.0 {Tcl_UniCharToUtf: Invalid surrogate} {Uesc} { expr {"\UD842" eq "\uD842"} } 1 -test utf-1.13.1 {Tcl_UniCharToUtf: Invalid surrogate} {fullutf testbytestring} { - expr {"\UD842" eq [testbytestring \xEF\xBF\xBD]} +test utf-1.13.1 {Tcl_UniCharToUtf: Invalid surrogate} {testbytestring} { + expr {"\UD842" eq [testbytestring \xED\xA1\x82]} } 1 test utf-1.14 {Tcl_UniCharToUtf: surrogate pairs from concat} { set lo \uDE02 -- cgit v0.12 From e9e4041670725dbaa04756d51351bb717a17fa46 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 31 Mar 2022 07:20:00 +0000 Subject: Minor change in utf.test --- tests/utf.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/utf.test b/tests/utf.test index f094a23..389bbce 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -81,7 +81,7 @@ test utf-1.12 {Tcl_UniCharToUtf: 4 byte sequence, high/low surrogate} {pairsTo4b test utf-1.13.0 {Tcl_UniCharToUtf: Invalid surrogate} {Uesc} { expr {"\UD842" eq "\uD842"} } 1 -test utf-1.13.1 {Tcl_UniCharToUtf: Invalid surrogate} {testbytestring} { +test utf-1.13.1 {Tcl_UniCharToUtf: Invalid surrogate} {fullutf testbytestring} { expr {"\UD842" eq [testbytestring \xED\xA1\x82]} } 1 test utf-1.14 {Tcl_UniCharToUtf: surrogate pairs from concat} { -- cgit v0.12 From e9f9cac4be915b90b69b1ee6d0b72c2f57ce590d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 31 Mar 2022 09:44:20 +0000 Subject: Oops --- generic/tclStringObj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index f1dc0f5..47b532d 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -70,7 +70,7 @@ static void SetUnicodeObj(Tcl_Obj *objPtr, static size_t UnicodeLength(const Tcl_UniChar *unicode); static void UpdateStringOfString(Tcl_Obj *objPtr); -#if TCL+UTF_MAX > 3 +#if TCL_UTF_MAX > 3 #define ISCONTINUATION(bytes) (\ ((bytes)[0] & 0xC0) == 0x80) #else -- cgit v0.12 From e0f543167d530ab16a23c67931db48f52c6a8ef3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 31 Mar 2022 10:08:13 +0000 Subject: Final tweaks in testcases --- tests/encoding.test | 10 +++++----- tests/utf.test | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/tests/encoding.test b/tests/encoding.test index dfe844f..99ea70c 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -340,13 +340,13 @@ test encoding-15.3 {UtfToUtfProc null character input} teststringbytes { test encoding-15.4 {UtfToUtfProc emoji character input} -body { set x \xED\xA0\xBD\xED\xB8\x82 set y [encoding convertfrom -nocomplain utf-8 \xED\xA0\xBD\xED\xB8\x82] - list [string length $y] $y -} -result "2 \uD83D\uDE02" -test encoding-15.5 {UtfToUtfProc emoji character input} ucs4 { + list [string length $x] $y +} -result "6 \uD83D\uDE02" +test encoding-15.5 {UtfToUtfProc emoji character input} { set x \xF0\x9F\x98\x82 set y [encoding convertfrom utf-8 \xF0\x9F\x98\x82] - list [string length $y] $y -} "1 😂" + list [string length $x] $y +} "4 😂" test encoding-15.6 {UtfToUtfProc emoji character output} ucs4 { set x \uDE02\uD83D\uDE02\uD83D set y [encoding convertto -nocomplain utf-8 \uDE02\uD83D\uDE02\uD83D] diff --git a/tests/utf.test b/tests/utf.test index 389bbce..4a1c063 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -78,7 +78,7 @@ test utf-1.11 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring test utf-1.12 {Tcl_UniCharToUtf: 4 byte sequence, high/low surrogate} {pairsTo4bytes testbytestring} { expr {"\uD842\uDC42" eq [testbytestring \xF0\xA0\xA1\x82]} } 1 -test utf-1.13.0 {Tcl_UniCharToUtf: Invalid surrogate} {Uesc} { +test utf-1.13.0 {Tcl_UniCharToUtf: Invalid surrogate} Uesc { expr {"\UD842" eq "\uD842"} } 1 test utf-1.13.1 {Tcl_UniCharToUtf: Invalid surrogate} {fullutf testbytestring} { -- cgit v0.12 From c9e33a6348a3521e24d190c2d8a653a70e62f0ee Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 31 Mar 2022 13:24:31 +0000 Subject: uint??_t -> int??_t --- generic/tclObj.c | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index 636f8e0..11a8530 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2200,17 +2200,17 @@ Tcl_GetBoolFromObj( boolEnd: if (boolPtr != NULL) { if ((flags>>8) & (int)~sizeof(int)) { - if ((flags>>8) == sizeof(uint64_t)) { - *(uint64_t *)boolPtr = result; + if ((flags>>8) == sizeof(int64_t)) { + *(int64_t *)boolPtr = result; return TCL_OK; - } else if ((flags>>8) == sizeof(uint32_t)) { - *(uint32_t *)boolPtr = result; + } else if ((flags>>8) == sizeof(int32_t)) { + *(int32_t *)boolPtr = result; return TCL_OK; - } else if ((flags>>8) == sizeof(uint16_t)) { - *(uint16_t *)boolPtr = result; + } else if ((flags>>8) == sizeof(int16_t)) { + *(int16_t *)boolPtr = result; return TCL_OK; - } else if ((flags>>8) == sizeof(uint8_t)) { - *(uint8_t *)boolPtr = result; + } else if ((flags>>8) == sizeof(int8_t)) { + *(int8_t *)boolPtr = result; return TCL_OK; } } -- cgit v0.12 From d78db33c23ca9fad833989314d1288dafbfd039e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 31 Mar 2022 13:37:09 +0000 Subject: Handle objPtr == NULL / interp == NULL better --- generic/tclObj.c | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/generic/tclObj.c b/generic/tclObj.c index 11a8530..ae20e16 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2168,6 +2168,13 @@ Tcl_GetBoolFromObj( if ((flags & TCL_NULL_OK) && (objPtr == NULL || Tcl_GetString(objPtr)[0] == '\0')) { result = -1; goto boolEnd; + } else if (objPtr == NULL) { + if (interp) { + TclNewObj(objPtr); + TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0); + Tcl_DecrRefCount(objPtr); + } + return TCL_ERROR; } do { if (objPtr->typePtr == &tclIntType) { -- cgit v0.12 From 9ad31cfcf31c75506cd932dfb2d637d4ff299131 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 31 Mar 2022 13:48:51 +0000 Subject: Better errpr-handling --- generic/tclGet.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclGet.c b/generic/tclGet.c index 1beac24..27f3235 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -134,8 +134,8 @@ Tcl_GetBool( Tcl_Obj obj; int code; - if (((src == NULL) || (*src == '\0')) && (flags & TCL_NULL_OK)) { - return (Tcl_GetBoolFromObj)(NULL, NULL, flags, boolPtr); + if ((src == NULL) || (*src == '\0')) { + return (Tcl_GetBoolFromObj)(interp, NULL, flags, boolPtr); } obj.refCount = 1; obj.bytes = (char *) src; -- cgit v0.12 From 05de893f6ff1e5b322d9579f183a83ad49be48df Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 1 Apr 2022 09:48:44 +0000 Subject: Fix some more testcases (involving string reverse/trim) --- tests/string.test | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/tests/string.test b/tests/string.test index 70b0e0f..8d99e88 100644 --- a/tests/string.test +++ b/tests/string.test @@ -34,6 +34,8 @@ testConstraint testindexobj [expr {[info commands testindexobj] ne {}}] testConstraint testevalex [expr {[info commands testevalex] ne {}}] testConstraint fullutf [expr {[string length \U010000] == 1}] testConstraint testbytestring [llength [info commands testbytestring]] +testConstraint ucs4 [expr {[testConstraint fullutf] + && [string length [format %c 0x10000]] == 1}] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] @@ -1941,13 +1943,13 @@ test string-21.22.$noComp {string trimright, unicode} { run {string trimright "\uF602Hello world!\uF602" \uD83D\uDE02} } "\uF602Hello world!\uF602" test string-21.23.$noComp {string trim, unicode} { - run {string trim "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02} + run {string trim "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D} } "\uD83D\uDE02Hello world!\uD83D\uDE02" test string-21.24.$noComp {string trimleft, unicode} { run {string trimleft "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02} } "\uD83D\uDE02Hello world!\uD83D\uDE02" test string-21.25.$noComp {string trimright, unicode} { - run {string trimright "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D\uDE02} + run {string trimright "\uD83D\uDE02Hello world!\uD83D\uDE02" \uD93D} } "\uD83D\uDE02Hello world!\uD83D\uDE02" test string-22.1.$noComp {string wordstart} -body { @@ -2111,24 +2113,24 @@ test string-24.15.$noComp {string reverse command - pure bytearray} { binary scan [run {tcl::string::reverse [binary format H* 010203]}] H* x set x } 030201 -test string-24.16.$noComp {string reverse command - surrogates} { +test string-24.16.$noComp {string reverse command - surrogates} ucs4 { run {string reverse \u0444bulb\uD83D\uDE02} -} \uD83D\uDE02blub\u0444 -test string-24.17.$noComp {string reverse command - surrogates} { +} \uDE02\uD83Dblub\u0444 +test string-24.17.$noComp {string reverse command - surrogates} ucs4 { run {string reverse \uD83D\uDE02hello\uD83D\uDE02} -} \uD83D\uDE02olleh\uD83D\uDE02 -test string-24.18.$noComp {string reverse command - surrogates} { +} \uDE02\uD83Dolleh\uDE02\uD83D +test string-24.18.$noComp {string reverse command - surrogates} ucs4 { set s \u0444bulb\uD83D\uDE02 # shim shimmery ... string index $s 0 run {string reverse $s} -} \uD83D\uDE02blub\u0444 -test string-24.19.$noComp {string reverse command - surrogates} { +} \uDE02\uD83Dblub\u0444 +test string-24.19.$noComp {string reverse command - surrogates} ucs4 { set s \uD83D\uDE02hello\uD83D\uDE02 # shim shimmery ... string index $s 0 run {string reverse $s} -} \uD83D\uDE02olleh\uD83D\uDE02 +} \uDE02\uD83Dolleh\uDE02\uD83D test string-25.1.$noComp {string is list} { run {string is list {a b c}} -- cgit v0.12 From bcedb2cdf604551b21205b0319c6876a108893e1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 3 Apr 2022 12:11:25 +0000 Subject: Add Ashok's example --- generic/tclTest.c | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 72a055e..8d2272c 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -30,6 +30,7 @@ #endif #include "tclOO.h" #include +#include /* * Required for Testregexp*Cmd @@ -5277,7 +5278,7 @@ TestsaveresultCmd( { Interp* iPtr = (Interp*) interp; int result, index; - short discard[3]; + bool b[3]; Tcl_SavedResult state; Tcl_Obj *objPtr; static const char *const optionStrings[] = { @@ -5299,7 +5300,7 @@ TestsaveresultCmd( &index) != TCL_OK) { return TCL_ERROR; } - if (Tcl_GetBooleanFromObj(interp, objv[3], &discard[1]) != TCL_OK) { + if (Tcl_GetBoolFromObj(interp, objv[3], 0, b+1) != TCL_OK) { return TCL_ERROR; } @@ -5336,7 +5337,7 @@ TestsaveresultCmd( result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), -1, 0); } - if (discard[1]) { + if (b[1]) { Tcl_DiscardResult(&state); } else { Tcl_RestoreResult(interp, &state); -- cgit v0.12 From 9b8a5d56d248638f34ad54292129773ed663c63a Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 4 Apr 2022 01:42:45 +0000 Subject: Panic if Testsaveresult call to Tcl_GetBoolFromObj overwrites memory. --- generic/tclTest.c | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 8d2272c..51d3764 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -5300,11 +5300,17 @@ TestsaveresultCmd( &index) != TCL_OK) { return TCL_ERROR; } - if (Tcl_GetBoolFromObj(interp, objv[3], 0, b+1) != TCL_OK) { - return TCL_ERROR; - } + b[0] = b[1] = b[2] = 100; + if (Tcl_GetBoolFromObj(interp, objv[3], 0, b + 1) != TCL_OK) + { + return TCL_ERROR; + } + if (b[0] != 100 || b[2] != 100) { + Tcl_Panic("MEMORY OVERWRITE IN Tcl_GetBoolFromObj"); + return TCL_ERROR; + } - freeCount = 0; + freeCount = 0; objPtr = NULL; /* Lint. */ switch ((enum options) index) { case RESULT_SMALL: -- cgit v0.12 From 706ec57375c74eee06320a7b6c722e464a10a9ae Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 15 Apr 2022 11:50:49 +0000 Subject: Use lower 5 bits of flags for sizeof(*(boolPtr)) --- generic/tclDecls.h | 8 ++++---- generic/tclObj.c | 16 +++++++--------- 2 files changed, 11 insertions(+), 13 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 4b8c09a..3cfbc42 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4285,9 +4285,9 @@ extern const TclStubs *tclStubsPtr; #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<8), (indexPtr))) #define Tcl_GetBoolFromObj(interp, objPtr, flags, boolPtr) \ - (tclStubsPtr->tcl_GetBoolFromObj((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))<<8), (boolPtr))) + (tclStubsPtr->tcl_GetBoolFromObj((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) #define Tcl_GetBool(interp, objPtr, flags, boolPtr) \ - (tclStubsPtr->tcl_GetBool((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))<<8), (boolPtr))) + (tclStubsPtr->tcl_GetBool((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) #define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ (sizeof(*(boolPtr)) == sizeof(int) ? tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : Tcl_GetBoolFromObj(interp, objPtr, 0, boolPtr)) #define Tcl_GetBoolean(interp, src, boolPtr) \ @@ -4306,9 +4306,9 @@ extern const TclStubs *tclStubsPtr; #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<8), (indexPtr))) #define Tcl_GetBoolFromObj(interp, objPtr, flags, boolPtr) \ - ((Tcl_GetBoolFromObj)((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))<<8), (boolPtr))) + ((Tcl_GetBoolFromObj)((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) #define Tcl_GetBool(interp, objPtr, flags, boolPtr) \ - ((Tcl_GetBool)((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))<<8), (boolPtr))) + ((Tcl_GetBool)((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) #define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ (sizeof(*(boolPtr)) == sizeof(int) ? (Tcl_GetBooleanFromObj)(interp, objPtr, (int *)(boolPtr)) : Tcl_GetBoolFromObj(interp, objPtr, 0, boolPtr)) #define Tcl_GetBoolean(interp, src, boolPtr) \ diff --git a/generic/tclObj.c b/generic/tclObj.c index ae20e16..439e854 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2206,22 +2206,20 @@ Tcl_GetBoolFromObj( result = 1; boolEnd: if (boolPtr != NULL) { - if ((flags>>8) & (int)~sizeof(int)) { - if ((flags>>8) == sizeof(int64_t)) { + flags &= (TCL_NULL_OK - 1); + if (flags & (int)~sizeof(int8_t)) { + if (flags == sizeof(int64_t)) { *(int64_t *)boolPtr = result; return TCL_OK; - } else if ((flags>>8) == sizeof(int32_t)) { + } else if (flags == sizeof(int32_t)) { *(int32_t *)boolPtr = result; return TCL_OK; - } else if ((flags>>8) == sizeof(int16_t)) { + } else if (flags == sizeof(int16_t)) { *(int16_t *)boolPtr = result; return TCL_OK; - } else if ((flags>>8) == sizeof(int8_t)) { - *(int8_t *)boolPtr = result; - return TCL_OK; - } + } } - *(int *)boolPtr = result; + *(int8_t *)boolPtr = result; } return TCL_OK; } -- cgit v0.12 From 42cd1c73d2440e5f4c6c5015bc740f13d0b8decd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 15 Apr 2022 12:20:31 +0000 Subject: Restore Tcl_GetBoolenanFromObj/Tcl_GetBoolenan signatures --- generic/tcl.decls | 4 ++-- generic/tclDecls.h | 16 ++++------------ generic/tclGet.c | 4 ++-- generic/tclObj.c | 4 ++-- generic/tclTest.c | 4 ++-- 5 files changed, 12 insertions(+), 20 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 883312e..a450130 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -136,11 +136,11 @@ declare 30 { void TclFreeObj(Tcl_Obj *objPtr) } declare 31 { - int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, void *boolPtr) + int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *boolPtr) } declare 32 { int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - void *boolPtr) + int *boolPtr) } declare 33 { unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *numBytesPtr) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 3cfbc42..ebaa279 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -146,10 +146,10 @@ EXTERN Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr); EXTERN void TclFreeObj(Tcl_Obj *objPtr); /* 31 */ EXTERN int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, - void *boolPtr); + int *boolPtr); /* 32 */ EXTERN int Tcl_GetBooleanFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, void *boolPtr); + Tcl_Obj *objPtr, int *boolPtr); /* 33 */ EXTERN unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *numBytesPtr); @@ -2032,8 +2032,8 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, int length, const char *file, int line); /* 28 */ Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */ void (*tclFreeObj) (Tcl_Obj *objPtr); /* 30 */ - int (*tcl_GetBoolean) (Tcl_Interp *interp, const char *src, void *boolPtr); /* 31 */ - int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void *boolPtr); /* 32 */ + int (*tcl_GetBoolean) (Tcl_Interp *interp, const char *src, int *boolPtr); /* 31 */ + int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *boolPtr); /* 32 */ unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *numBytesPtr); /* 33 */ int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */ int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */ @@ -4288,10 +4288,6 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetBoolFromObj((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) #define Tcl_GetBool(interp, objPtr, flags, boolPtr) \ (tclStubsPtr->tcl_GetBool((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) -#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ - (sizeof(*(boolPtr)) == sizeof(int) ? tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : Tcl_GetBoolFromObj(interp, objPtr, 0, boolPtr)) -#define Tcl_GetBoolean(interp, src, boolPtr) \ - (sizeof(*(boolPtr)) == sizeof(int) ? tclStubsPtr->tcl_GetBoolean(interp, src, (int *)(boolPtr)) : Tcl_GetBool(interp, src, 0, boolPtr)) #ifdef TCL_NO_DEPRECATED #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetStringFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tclGetStringFromObj(objPtr, (size_t *)(sizePtr))) @@ -4309,10 +4305,6 @@ extern const TclStubs *tclStubsPtr; ((Tcl_GetBoolFromObj)((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) #define Tcl_GetBool(interp, objPtr, flags, boolPtr) \ ((Tcl_GetBool)((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) -#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ - (sizeof(*(boolPtr)) == sizeof(int) ? (Tcl_GetBooleanFromObj)(interp, objPtr, (int *)(boolPtr)) : Tcl_GetBoolFromObj(interp, objPtr, 0, boolPtr)) -#define Tcl_GetBoolean(interp, src, boolPtr) \ - (sizeof(*(boolPtr)) == sizeof(int) ? (Tcl_GetBoolean)(interp, src, (int *)(boolPtr)) : Tcl_GetBool(interp, src, 0, boolPtr)) #ifdef TCL_NO_DEPRECATED #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? (Tcl_GetStringFromObj)(objPtr, (int *)(sizePtr)) : (TclGetStringFromObj)(objPtr, (size_t *)(sizePtr))) diff --git a/generic/tclGet.c b/generic/tclGet.c index 27f3235..9a1b3c0 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -158,10 +158,10 @@ Tcl_GetBoolean( Tcl_Interp *interp, /* Interpreter used for error reporting. */ const char *src, /* String containing one of the boolean values * 1, 0, true, false, yes, no, on, off. */ - void *boolPtr) /* Place to store converted result, which will + int *boolPtr) /* Place to store converted result, which will * be 0 or 1. */ { - return Tcl_GetBool(interp, src, 0, boolPtr); + return Tcl_GetBool(interp, src, sizeof(int), boolPtr); } /* diff --git a/generic/tclObj.c b/generic/tclObj.c index 439e854..89b576c 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2233,9 +2233,9 @@ int Tcl_GetBooleanFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* The object from which to get boolean. */ - void *boolPtr) /* Place to store resulting boolean. */ + int *boolPtr) /* Place to store resulting boolean. */ { - return Tcl_GetBoolFromObj(interp, objPtr, 0, boolPtr); + return Tcl_GetBoolFromObj(interp, objPtr, sizeof(int), boolPtr); } /* diff --git a/generic/tclTest.c b/generic/tclTest.c index 646987b..db25379 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -2270,8 +2270,8 @@ TesteventProc( Tcl_BackgroundException(interp, TCL_ERROR); return 1; /* Avoid looping on errors */ } - if (Tcl_GetBooleanFromObj(interp, Tcl_GetObjResult(interp), - &retval[1]) != TCL_OK) { + if (Tcl_GetBoolFromObj(interp, Tcl_GetObjResult(interp), + 0, &retval[1]) != TCL_OK) { Tcl_AddErrorInfo(interp, " (return value from \"testevent\" callback)"); Tcl_BackgroundException(interp, TCL_ERROR); -- cgit v0.12 From 757c9098818f6fa4cb48fa8e522e767d6c0dde4d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 15 Apr 2022 12:27:39 +0000 Subject: Remove macro's for Tcl_GetBoolFromObj/Tcl_GetBool --- generic/tclDecls.h | 12 ------------ generic/tclTest.c | 4 ++-- 2 files changed, 2 insertions(+), 14 deletions(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index ebaa279..790af99 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4270,10 +4270,6 @@ extern const TclStubs *tclStubsPtr; Tcl_GetUnicodeFromObj(objPtr, (int *)NULL) #undef Tcl_GetBytesFromObj #undef Tcl_GetIndexFromObjStruct -#undef Tcl_GetBoolFromObj -#undef Tcl_GetBool -#undef Tcl_GetBooleanFromObj -#undef Tcl_GetBoolean #ifdef TCL_NO_DEPRECATED #undef Tcl_GetStringFromObj #undef Tcl_GetUnicodeFromObj @@ -4284,10 +4280,6 @@ extern const TclStubs *tclStubsPtr; (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<8), (indexPtr))) -#define Tcl_GetBoolFromObj(interp, objPtr, flags, boolPtr) \ - (tclStubsPtr->tcl_GetBoolFromObj((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) -#define Tcl_GetBool(interp, objPtr, flags, boolPtr) \ - (tclStubsPtr->tcl_GetBool((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) #ifdef TCL_NO_DEPRECATED #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetStringFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tclGetStringFromObj(objPtr, (size_t *)(sizePtr))) @@ -4301,10 +4293,6 @@ extern const TclStubs *tclStubsPtr; (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetBytesFromObj)(interp, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<8), (indexPtr))) -#define Tcl_GetBoolFromObj(interp, objPtr, flags, boolPtr) \ - ((Tcl_GetBoolFromObj)((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) -#define Tcl_GetBool(interp, objPtr, flags, boolPtr) \ - ((Tcl_GetBool)((interp), (objPtr), (flags)|(int)(sizeof(*(boolPtr))), (boolPtr))) #ifdef TCL_NO_DEPRECATED #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? (Tcl_GetStringFromObj)(objPtr, (int *)(sizePtr)) : (TclGetStringFromObj)(objPtr, (size_t *)(sizePtr))) diff --git a/generic/tclTest.c b/generic/tclTest.c index db25379..4cd9bab 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -2271,7 +2271,7 @@ TesteventProc( return 1; /* Avoid looping on errors */ } if (Tcl_GetBoolFromObj(interp, Tcl_GetObjResult(interp), - 0, &retval[1]) != TCL_OK) { + sizeof(retval[1]), &retval[1]) != TCL_OK) { Tcl_AddErrorInfo(interp, " (return value from \"testevent\" callback)"); Tcl_BackgroundException(interp, TCL_ERROR); @@ -5300,7 +5300,7 @@ TestsaveresultCmd( return TCL_ERROR; } b[0] = b[1] = b[2] = 100; - if (Tcl_GetBoolFromObj(interp, objv[3], 0, b + 1) != TCL_OK) + if (Tcl_GetBoolFromObj(interp, objv[3], sizeof(b[1]), b + 1) != TCL_OK) { return TCL_ERROR; } -- cgit v0.12 From ad9c975e41ced7cdc2f156f683fa8845fb33735a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 15 Apr 2022 14:46:00 +0000 Subject: Update documentation --- doc/BoolObj.3 | 18 +++++++++++++----- doc/GetInt.3 | 21 ++++++++++++++++----- 2 files changed, 29 insertions(+), 10 deletions(-) diff --git a/doc/BoolObj.3 b/doc/BoolObj.3 index afbd1d1..c5bb05f 100644 --- a/doc/BoolObj.3 +++ b/doc/BoolObj.3 @@ -20,7 +20,7 @@ Tcl_Obj * \fBTcl_SetBooleanObj\fR(\fIobjPtr, boolValue\fR) .sp int -\fBTcl_GetBooleanFromObj\fR(\fIinterp, objPtr, boolPtr\fR) +\fBTcl_GetBooleanFromObj\fR(\fIinterp, objPtr, intPtr\fR) .sp int \fBTcl_GetBoolFromObj\fR(\fIinterp, objPtr, flags. boolPtr\fR) @@ -35,13 +35,16 @@ retrieve a boolean value. If a boolean value cannot be retrieved, an error message is left in the interpreter's result value unless \fIinterp\fR is NULL. +.AP int *intPtr out +Points to place where \fBTcl_GetBooleanFromObj\fR +stores the boolean value (0 or 1) obtained from \fIobjPtr\fR. .AP int | short | char *boolPtr out -Points to place where \fBTcl_GetBooleanFromObj\fR/\fBTcl_GetBoolFromObj\fR +Points to place where \fBTcl_GetBoolFromObj\fR stores the boolean value (0 or 1) obtained from \fIobjPtr\fR. .AP int flags in -Value 0 or TCL_NULL_OK. If TCL_NULL_OK, then the empty -string or NULL will result in \fBTcl_GetBoolFromObj\fR return -TCL_OK, the *boolPtr filled with the value -1; +sizeof(*(boolPtr)), possibly combined with TCL_NULL_OK. If TCL_NULL_OK +is used, then the empty string or NULL will result in \fBTcl_GetBoolFromObj\fR +return TCL_OK, the *boolPtr filled with the value -1; .BE .SH DESCRIPTION @@ -83,6 +86,11 @@ fields of \fI*objPtr\fR so that future calls to \fBTcl_GetBooleanFromObj\fR on the same \fIobjPtr\fR can be performed more efficiently. .PP +\fBTcl_GetBoolFromObj\fR functions almost the same as +\fBTcl_GetBooleanFromObj\fR, but it has an additional parameter +\fBflags\fR, which can be used to specify the size of the \fBboolPtr\fR +variable, and also whether the empty string or NULL is accepted as valid. +.PP Note that the routines \fBTcl_GetBooleanFromObj\fR and \fBTcl_GetBoolean\fR are not functional equivalents. The set of values for which \fBTcl_GetBooleanFromObj\fR diff --git a/doc/GetInt.3 b/doc/GetInt.3 index f9b91a2..edce6c1 100644 --- a/doc/GetInt.3 +++ b/doc/GetInt.3 @@ -21,7 +21,10 @@ int \fBTcl_GetDouble\fR(\fIinterp, src, doublePtr\fR) .sp int -\fBTcl_GetBoolean\fR(\fIinterp, src, boolPtr\fR) +\fBTcl_GetBoolean\fR(\fIinterp, src, intPtr\fR) +.sp +int +\fBTcl_GetBool\fR(\fIinterp, src, flags, boolPtr\fR) .SH ARGUMENTS .AS Tcl_Interp *doublePtr out .AP Tcl_Interp *interp in @@ -34,7 +37,11 @@ Points to place to store integer value converted from \fIsrc\fR. Points to place to store double-precision floating-point value converted from \fIsrc\fR. .AP int | short | char *boolPtr out -Points to place to store boolean value (0 or 1) converted from \fIsrc\fR. +Points to place to store boolean value (0 or 1) value converted from \fIsrc\fR. +.AP int flags in +sizeof(*(boolPtr)), possibly combined with TCL_NULL_OK. If TCL_NULL_OK +is used, then the empty string or NULL will result in \fBTcl_GetBool\fR +return TCL_OK, the *boolPtr filled with the value -1; .BE .SH DESCRIPTION @@ -94,11 +101,15 @@ inter-digit separator be present. \fBTcl_GetBoolean\fR expects \fIsrc\fR to specify a boolean value. If \fIsrc\fR is any of \fB0\fR, \fBfalse\fR, \fBno\fR, or \fBoff\fR, then \fBTcl_GetBoolean\fR stores a zero -value at \fI*boolPtr\fR. +value at \fI*intPtr\fR. If \fIsrc\fR is any of \fB1\fR, \fBtrue\fR, \fByes\fR, or \fBon\fR, -then 1 is stored at \fI*boolPtr\fR. +then 1 is stored at \fI*intPtr\fR. Any of these values may be abbreviated, and upper-case spellings are also acceptable. - +.PP +\fBTcl_GetBool\fR functions almost the same as \fBTcl_GetBoolean\fR, +but it has an additional parameter \fBflags\fR, which can be used +to specify the size of the \fBboolPtr\fR variable, and also whether +the empty string or NULL is accepted as valid. .SH KEYWORDS boolean, conversion, double, floating-point, integer -- cgit v0.12 From 43ea8e68e8f54392631b95557d6dc9c621afc667 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 20 Apr 2022 14:26:06 +0000 Subject: Simplify TclGetBoolFromObj() macro --- generic/tclCmdMZ.c | 2 +- generic/tclExecute.c | 8 ++++---- generic/tclInt.h | 8 ++++---- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 3eaf055..f394035 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1620,7 +1620,7 @@ StringIsCmd( result = length1 == 0; } } else if (index != STR_IS_BOOL) { - TclGetBoolFromObj(NULL, objPtr, sizeof(i), &i); + TclGetBooleanFromObj(NULL, objPtr, &i); if ((index == STR_IS_TRUE) ^ i) { result = 0; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 1e16da5..0ec2404 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4346,7 +4346,7 @@ TEBCresume( /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ - if (TclGetBoolFromObj(interp, valuePtr, sizeof(b), &b) != TCL_OK) { + if (TclGetBooleanFromObj(interp, valuePtr, &b) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -4414,7 +4414,7 @@ TEBCresume( value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; - if (TclGetBoolFromObj(NULL, valuePtr, sizeof(i1), &i1) != TCL_OK) { + if (TclGetBooleanFromObj(NULL, valuePtr, &i1) != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); @@ -4423,7 +4423,7 @@ TEBCresume( goto gotError; } - if (TclGetBoolFromObj(NULL, value2Ptr, sizeof(i2), &i2) != TCL_OK) { + if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) { TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); DECACHE_STACK_INFO(); @@ -6223,7 +6223,7 @@ TEBCresume( /* TODO - check claim that taking address of b harms performance */ /* TODO - consider optimization search for constants */ - if (TclGetBoolFromObj(NULL, valuePtr, sizeof(b), &b) != TCL_OK) { + if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) { TRACE(("\"%.20s\" => ERROR: illegal type %s\n", O2S(valuePtr), (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); diff --git a/generic/tclInt.h b/generic/tclInt.h index e3ebe57..c39a9f6 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2507,12 +2507,12 @@ typedef struct List { * WARNING: these macros eval their args more than once. */ -#define TclGetBoolFromObj(interp, objPtr, flags, boolPtr) \ +#define TclGetBooleanFromObj(interp, objPtr, intPtr) \ (((objPtr)->typePtr == &tclIntType) \ - ? (*(boolPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ + ? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ : ((objPtr)->typePtr == &tclBooleanType) \ - ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ - : Tcl_GetBoolFromObj((interp), (objPtr), (flags), (boolPtr))) + ? (*(intPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ + : (Tcl_GetBoolFromObj)((interp), (objPtr), (int)sizeof(int), (intPtr))) #ifdef TCL_WIDE_INT_IS_LONG #define TclGetLongFromObj(interp, objPtr, longPtr) \ -- cgit v0.12 From d3662a9dca03f16538eae7240e56fb57589bd9e5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 29 Apr 2022 20:09:48 +0000 Subject: re-structure, add more examples --- generic/tcl.decls | 4 ++-- generic/tclCompCmdsGR.c | 3 ++- generic/tclCompCmdsSZ.c | 4 +++- generic/tclCompExpr.c | 3 ++- generic/tclDecls.h | 26 ++++++++++++++++++++++---- generic/tclGet.c | 9 +++++++-- generic/tclInt.h | 2 +- generic/tclObj.c | 30 ++++++++++++------------------ generic/tclTest.c | 29 ++++++++++++----------------- 9 files changed, 63 insertions(+), 47 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 3d59139..2c19545 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2457,11 +2457,11 @@ declare 668 { declare 674 { int Tcl_GetBool(Tcl_Interp *interp, const char *src, int flags, - void *boolPtr) + char *boolPtr) } declare 675 { int Tcl_GetBoolFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - int flags, void *boolPtr) + int flags, char *boolPtr) } diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index da557a4..839fbde 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -17,6 +17,7 @@ #include "tclInt.h" #include "tclCompile.h" #include +#include /* * Prototypes for procedures defined later in this file: @@ -185,7 +186,7 @@ TclCompileIfCmd( const char *word; int realCond = 1; /* Set to 0 for static conditions: * "if 0 {..}" */ - int boolVal; /* Value of static condition. */ + bool boolVal; /* Value of static condition. */ int compileScripts = 1; /* diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index cd3bd37..fa490a1 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -18,6 +18,7 @@ #include "tclInt.h" #include "tclCompile.h" #include "tclStringTrim.h" +#include /* * Prototypes for procedures defined later in this file: @@ -3759,7 +3760,8 @@ TclCompileWhileCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *testTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; - int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal; + int testCodeOffset, bodyCodeOffset, jumpDist, range, code; + bool boolVal; int loopMayEnd = 1; /* This is set to 0 if it is recognized as an * infinite loop. */ Tcl_Obj *boolObj; diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 23d8711..c245b4e 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -13,6 +13,7 @@ #include "tclInt.h" #include "tclCompile.h" /* CompileEnv */ +#include /* * Expression parsing takes place in the routine ParseExpr(). It takes a @@ -708,7 +709,7 @@ ParseExpr( */ if ((NODE_TYPE & lexeme) == 0) { - int b; + bool b; switch (lexeme) { case COMMENT: diff --git a/generic/tclDecls.h b/generic/tclDecls.h index d75e605..04f8aa3 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1970,10 +1970,10 @@ EXTERN int Tcl_UniCharLen(const int *uniStr); /* Slot 673 is reserved */ /* 674 */ EXTERN int Tcl_GetBool(Tcl_Interp *interp, const char *src, - int flags, void *boolPtr); + int flags, char *boolPtr); /* 675 */ EXTERN int Tcl_GetBoolFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, int flags, void *boolPtr); + Tcl_Obj *objPtr, int flags, char *boolPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2683,8 +2683,8 @@ typedef struct TclStubs { void (*reserved671)(void); void (*reserved672)(void); void (*reserved673)(void); - int (*tcl_GetBool) (Tcl_Interp *interp, const char *src, int flags, void *boolPtr); /* 674 */ - int (*tcl_GetBoolFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, void *boolPtr); /* 675 */ + int (*tcl_GetBool) (Tcl_Interp *interp, const char *src, int flags, char *boolPtr); /* 674 */ + int (*tcl_GetBoolFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, char *boolPtr); /* 675 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4270,12 +4270,22 @@ extern const TclStubs *tclStubsPtr; Tcl_GetUnicodeFromObj(objPtr, (int *)NULL) #undef Tcl_GetBytesFromObj #undef Tcl_GetIndexFromObjStruct +#undef Tcl_GetBoolean +#undef Tcl_GetBooleanFromObj #ifdef TCL_NO_DEPRECATED #undef Tcl_GetStringFromObj #undef Tcl_GetUnicodeFromObj #undef Tcl_GetByteArrayFromObj #endif #if defined(USE_TCL_STUBS) +#define Tcl_GetBoolean(interp, objPtr, boolPtr) \ + (sizeof(*(boolPtr)) == sizeof(int) ? tclStubsPtr->tcl_GetBoolean(interp, objPtr, (int *)(boolPtr)) : \ + (sizeof(*(boolPtr)) == sizeof(char) ? tclStubsPtr->tcl_GetBool(interp, objPtr, 0, (char *)(boolPtr)) : \ + (Tcl_Panic("Invalid boolean variable: sizeof() must be 1 or 4"), TCL_ERROR))) +#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ + (sizeof(*(boolPtr)) == sizeof(int) ? tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \ + (sizeof(*(boolPtr)) == sizeof(char) ? tclStubsPtr->tcl_GetBoolFromObj(interp, objPtr, 0, (char *)(boolPtr)) : \ + (Tcl_Panic("Invalid boolean variable: sizeof() must be 1 or 4"), TCL_ERROR))) #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ @@ -4289,6 +4299,14 @@ extern const TclStubs *tclStubsPtr; (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tclGetUnicodeFromObj(objPtr, (size_t *)(sizePtr))) #endif #else +#define Tcl_GetBoolean(interp, objPtr, boolPtr) \ + (sizeof(*(boolPtr)) == sizeof(int) ? (Tcl_GetBoolean)(interp, objPtr, (int *)(boolPtr)) : \ + (sizeof(*(boolPtr)) == sizeof(char) ? (Tcl_GetBool)(interp, objPtr, 0, (char *)(boolPtr)) : \ + (Tcl_Panic("Invalid boolean variable: sizeof() must be 1 or 4"), TCL_ERROR))) +#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ + (sizeof(*(boolPtr)) == sizeof(int) ? (Tcl_GetBooleanFromObj)(interp, objPtr, (int *)(boolPtr)) : \ + (sizeof(*(boolPtr)) == sizeof(char) ? (Tcl_GetBoolFromObj)(interp, objPtr, 0, (char *)(boolPtr)) : \ + (Tcl_Panic("Invalid boolean variable: sizeof() must be 1 or 4"), TCL_ERROR))) #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetBytesFromObj)(interp, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ diff --git a/generic/tclGet.c b/generic/tclGet.c index 0e07da1..a60d3a6 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -128,7 +128,7 @@ Tcl_GetBool( const char *src, /* String containing one of the boolean values * 1, 0, true, false, yes, no, on, off. */ int flags, - void *boolPtr) /* Place to store converted result, which will + char *boolPtr) /* Place to store converted result, which will * be 0 or 1. */ { Tcl_Obj obj; @@ -161,7 +161,12 @@ Tcl_GetBoolean( int *intPtr) /* Place to store converted result, which will * be 0 or 1. */ { - return Tcl_GetBool(interp, src, sizeof(int), intPtr); + char boolValue; + int result = Tcl_GetBool(interp, src, 0, &boolValue); + if (intPtr) { + *intPtr = boolValue; + } + return result; } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 2ee22f3..61cc3b3 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2512,7 +2512,7 @@ typedef struct List { ? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ : ((objPtr)->typePtr == &tclBooleanType) \ ? (*(intPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ - : Tcl_GetBoolFromObj((interp), (objPtr), (int)sizeof(int), (intPtr))) + : Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr))) #ifdef TCL_WIDE_INT_IS_LONG #define TclGetLongFromObj(interp, objPtr, longPtr) \ diff --git a/generic/tclObj.c b/generic/tclObj.c index 40fc73b..7842d0d 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2161,7 +2161,7 @@ Tcl_GetBoolFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr, /* The object from which to get boolean. */ int flags, - void *boolPtr) /* Place to store resulting boolean. */ + char *boolPtr) /* Place to store resulting boolean. */ { int result; @@ -2171,7 +2171,8 @@ Tcl_GetBoolFromObj( } else if (objPtr == NULL) { if (interp) { TclNewObj(objPtr); - TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0); + TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK) + ? "boolean value or \"\"" : "boolean value", NULL, -1, NULL, 0); Tcl_DecrRefCount(objPtr); } return TCL_ERROR; @@ -2206,25 +2207,13 @@ Tcl_GetBoolFromObj( result = 1; boolEnd: if (boolPtr != NULL) { - flags &= (TCL_NULL_OK - 1); - if (flags & (int)~sizeof(int8_t)) { - if (flags == sizeof(int16_t)) { - *(int16_t *)boolPtr = result; - return TCL_OK; - } else if (flags == sizeof(int32_t)) { - *(int32_t *)boolPtr = result; - return TCL_OK; - } else if (flags == sizeof(int64_t)) { - *(int64_t *)boolPtr = result; - return TCL_OK; - } - } - *(int8_t *)boolPtr = result; + *boolPtr = result; } return TCL_OK; } } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == - TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0))); + TclParseNumber(interp, objPtr, (flags & TCL_NULL_OK) + ? "boolean value or \"\"" : "boolean value", NULL,-1,NULL,0))); return TCL_ERROR; } @@ -2235,7 +2224,12 @@ Tcl_GetBooleanFromObj( Tcl_Obj *objPtr, /* The object from which to get boolean. */ int *intPtr) /* Place to store resulting boolean. */ { - return Tcl_GetBoolFromObj(interp, objPtr, sizeof(int), intPtr); + char boolValue; + int result = Tcl_GetBoolFromObj(interp, objPtr, 0, &boolValue); + if (intPtr) { + *intPtr = boolValue; + } + return result; } /* diff --git a/generic/tclTest.c b/generic/tclTest.c index 4cd9bab..39364d6 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -30,6 +30,7 @@ #endif #include "tclOO.h" #include +#include /* * Required for Testregexp*Cmd @@ -2262,7 +2263,7 @@ TesteventProc( Tcl_Obj *command = ev->command; int result = Tcl_EvalObjEx(interp, command, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); - char retval[3]; + bool retval; if (result != TCL_OK) { Tcl_AddErrorInfo(interp, @@ -2270,19 +2271,19 @@ TesteventProc( Tcl_BackgroundException(interp, TCL_ERROR); return 1; /* Avoid looping on errors */ } - if (Tcl_GetBoolFromObj(interp, Tcl_GetObjResult(interp), - sizeof(retval[1]), &retval[1]) != TCL_OK) { + if (Tcl_GetBooleanFromObj(interp, Tcl_GetObjResult(interp), + &retval) != TCL_OK) { Tcl_AddErrorInfo(interp, " (return value from \"testevent\" callback)"); Tcl_BackgroundException(interp, TCL_ERROR); return 1; } - if (retval[1]) { + if (retval) { Tcl_DecrRefCount(ev->tag); Tcl_DecrRefCount(ev->command); } - return retval[1]; + return retval; } /* @@ -5277,7 +5278,7 @@ TestsaveresultCmd( { Interp* iPtr = (Interp*) interp; int result, index; - char b[3]; + bool discard; Tcl_SavedResult state; Tcl_Obj *objPtr; static const char *const optionStrings[] = { @@ -5299,17 +5300,11 @@ TestsaveresultCmd( &index) != TCL_OK) { return TCL_ERROR; } - b[0] = b[1] = b[2] = 100; - if (Tcl_GetBoolFromObj(interp, objv[3], sizeof(b[1]), b + 1) != TCL_OK) - { - return TCL_ERROR; - } - if (b[0] != 100 || b[2] != 100) { - Tcl_Panic("MEMORY OVERWRITE IN Tcl_GetBoolFromObj"); - return TCL_ERROR; - } + if (Tcl_GetBooleanFromObj(interp, objv[3], &discard) != TCL_OK) { + return TCL_ERROR; + } - freeCount = 0; + freeCount = 0; objPtr = NULL; /* Lint. */ switch ((enum options) index) { case RESULT_SMALL: @@ -5342,7 +5337,7 @@ TestsaveresultCmd( result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), -1, 0); } - if (b[1]) { + if (discard) { Tcl_DiscardResult(&state); } else { Tcl_RestoreResult(interp, &state); -- cgit v0.12 From a83edfe07c35a66fbcf357a99349c43e103e6d9e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 10 May 2022 10:18:44 +0000 Subject: Update doc --- doc/BoolObj.3 | 4 ++-- doc/GetInt.3 | 3 +-- generic/tclGet.c | 6 +++--- generic/tclObj.c | 30 +++++++++++++++--------------- 4 files changed, 21 insertions(+), 22 deletions(-) diff --git a/doc/BoolObj.3 b/doc/BoolObj.3 index cc8729e..47a2189 100644 --- a/doc/BoolObj.3 +++ b/doc/BoolObj.3 @@ -88,8 +88,8 @@ performed more efficiently. .PP \fBTcl_GetBoolFromObj\fR functions almost the same as \fBTcl_GetBooleanFromObj\fR, but it has an additional parameter -\fBflags\fR, which can be used to specify the size of the \fBbool\fR -variable, and also whether the empty string or NULL is accepted as valid. +\fBflags\fR, which can be used to specify whether the empty +string or NULL is accepted as valid. .PP Note that the routines \fBTcl_GetBooleanFromObj\fR and \fBTcl_GetBoolean\fR are not functional equivalents. diff --git a/doc/GetInt.3 b/doc/GetInt.3 index 62e8f51..f15c12d 100644 --- a/doc/GetInt.3 +++ b/doc/GetInt.3 @@ -109,8 +109,7 @@ are also acceptable. .PP \fBTcl_GetBool\fR functions almost the same as \fBTcl_GetBoolean\fR, but it has an additional parameter \fBflags\fR, which can be used -to specify the size of the \fBbool\fR variable, and also whether -the empty string or NULL is accepted as valid. +to specify whether the empty string or NULL is accepted as valid. .SH KEYWORDS boolean, conversion, double, floating-point, integer diff --git a/generic/tclGet.c b/generic/tclGet.c index 9670450..3c458dc 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -161,10 +161,10 @@ Tcl_GetBoolean( int *intPtr) /* Place to store converted result, which will * be 0 or 1. */ { - char boolValue; - int result = Tcl_GetBool(interp, src, 0, &boolValue); + char charValue; + int result = Tcl_GetBool(interp, src, 0, &charValue); if (intPtr) { - *intPtr = boolValue; + *intPtr = charValue; } return result; } diff --git a/generic/tclObj.c b/generic/tclObj.c index f7d9dfc..ce13638 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -2004,7 +2004,7 @@ Tcl_FreeInternalRep( * * This function is normally called when not debugging: i.e., when * TCL_MEM_DEBUG is not defined. It creates a new Tcl_Obj and - * initializes it from the argument boolean value. A nonzero "boolValue" + * initializes it from the argument boolean value. A nonzero "intValue" * is coerced to 1. * * When TCL_MEM_DEBUG is defined, this function just returns the result @@ -2025,20 +2025,20 @@ Tcl_FreeInternalRep( Tcl_Obj * Tcl_NewBooleanObj( - int boolValue) /* Boolean used to initialize new object. */ + int intValue) /* Boolean used to initialize new object. */ { - return Tcl_DbNewWideIntObj(boolValue!=0, "unknown", 0); + return Tcl_DbNewWideIntObj(intValue!=0, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewBooleanObj( - int boolValue) /* Boolean used to initialize new object. */ + int intValue) /* Boolean used to initialize new object. */ { Tcl_Obj *objPtr; - TclNewIntObj(objPtr, boolValue!=0); + TclNewIntObj(objPtr, intValue!=0); return objPtr; } #endif /* TCL_MEM_DEBUG */ @@ -2075,7 +2075,7 @@ Tcl_NewBooleanObj( Tcl_Obj * Tcl_DbNewBooleanObj( - int boolValue, /* Boolean used to initialize new object. */ + int intValue, /* Boolean used to initialize new object. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for @@ -2087,7 +2087,7 @@ Tcl_DbNewBooleanObj( /* Optimized TclInvalidateStringRep() */ objPtr->bytes = NULL; - objPtr->internalRep.wideValue = (boolValue != 0); + objPtr->internalRep.wideValue = (intValue != 0); objPtr->typePtr = &tclIntType; return objPtr; } @@ -2096,11 +2096,11 @@ Tcl_DbNewBooleanObj( Tcl_Obj * Tcl_DbNewBooleanObj( - int boolValue, /* Boolean used to initialize new object. */ + int intValue, /* Boolean used to initialize new object. */ TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) { - return Tcl_NewBooleanObj(boolValue); + return Tcl_NewBooleanObj(intValue); } #endif /* TCL_MEM_DEBUG */ @@ -2110,7 +2110,7 @@ Tcl_DbNewBooleanObj( * Tcl_SetBooleanObj -- * * Modify an object to be a boolean object and to have the specified - * boolean value. A nonzero "boolValue" is coerced to 1. + * boolean value. A nonzero "intValue" is coerced to 1. * * Results: * None. @@ -2126,13 +2126,13 @@ Tcl_DbNewBooleanObj( void Tcl_SetBooleanObj( Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - int boolValue) /* Boolean used to set object's value. */ + int intValue) /* Boolean used to set object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); } - TclSetIntObj(objPtr, boolValue!=0); + TclSetIntObj(objPtr, intValue!=0); } #endif /* TCL_NO_DEPRECATED */ @@ -2224,10 +2224,10 @@ Tcl_GetBooleanFromObj( Tcl_Obj *objPtr, /* The object from which to get boolean. */ int *intPtr) /* Place to store resulting boolean. */ { - char boolValue; - int result = Tcl_GetBoolFromObj(interp, objPtr, 0, &boolValue); + char charValue; + int result = Tcl_GetBoolFromObj(interp, objPtr, 0, &charValue); if (intPtr) { - *intPtr = boolValue; + *intPtr = charValue; } return result; } -- cgit v0.12 From 9b1a7da59be393b5b4695631cadf5423a3c87a7d Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 6 Jun 2022 16:51:24 +0000 Subject: Bump to 8.6.13 for release --- README.md | 2 +- generic/tcl.h | 4 ++-- library/init.tcl | 2 +- unix/configure | 3 +-- unix/configure.in | 2 +- unix/tcl.spec | 2 +- win/configure | 25 +++++++++++-------------- win/configure.in | 2 +- 8 files changed, 19 insertions(+), 23 deletions(-) diff --git a/README.md b/README.md index 045a287..1c5cd4b 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # README: Tcl -This is the **Tcl 8.6.12** source distribution. +This is the **Tcl 8.6.13** source distribution. You can get any source release of Tcl from [our distribution site](https://sourceforge.net/projects/tcl/files/Tcl/). diff --git a/generic/tcl.h b/generic/tcl.h index 41025e7..3a4622e 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -51,10 +51,10 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 6 #define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 12 +#define TCL_RELEASE_SERIAL 13 #define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6.12" +#define TCL_PATCH_LEVEL "8.6.13" /* *---------------------------------------------------------------------------- diff --git a/library/init.tcl b/library/init.tcl index edf6bd5..0655dc8 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -16,7 +16,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 8.6.12 +package require -exact Tcl 8.6.13 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/unix/configure b/unix/configure index 5dee873..57d5081 100755 --- a/unix/configure +++ b/unix/configure @@ -1335,7 +1335,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".12" +TCL_PATCH_LEVEL=".13" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} @@ -2823,7 +2823,6 @@ cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include -#include #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) diff --git a/unix/configure.in b/unix/configure.in index c73f368..62ab90e 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -26,7 +26,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".12" +TCL_PATCH_LEVEL=".13" VERSION=${TCL_VERSION} EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"} diff --git a/unix/tcl.spec b/unix/tcl.spec index 2e4a433..f4177a4 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -4,7 +4,7 @@ Name: tcl Summary: Tcl scripting language development environment -Version: 8.6.12 +Version: 8.6.13 Release: 2 License: BSD Group: Development/Languages diff --git a/win/configure b/win/configure index ab9771f..2765e6c 100755 --- a/win/configure +++ b/win/configure @@ -1325,7 +1325,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".12" +TCL_PATCH_LEVEL=".13" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 @@ -2729,7 +2729,6 @@ cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include -#include #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) @@ -3032,26 +3031,24 @@ fi echo "$as_me:$LINENO: checking whether ${MAKE-make} sets \$(MAKE)" >&5 echo $ECHO_N "checking whether ${MAKE-make} sets \$(MAKE)... $ECHO_C" >&6 -set x ${MAKE-make} -ac_make=`echo "" | sed 'y,:./+-,___p_,'` +set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y,:./+-,___p_,'` if eval "test \"\${ac_cv_prog_make_${ac_make}_set+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.make <<\_ACEOF -SHELL = /bin/sh all: - @echo '@@@%%%=$(MAKE)=@@@%%%' + @echo 'ac_maketemp="$(MAKE)"' _ACEOF -# GNU make sometimes prints "make[1]: Entering ...", which would confuse us. -case `${MAKE-make} -f conftest.make 2>/dev/null` in - *@@@%%%=?*=@@@%%%*) - eval ac_cv_prog_make_${ac_make}_set=yes;; - *) - eval ac_cv_prog_make_${ac_make}_set=no;; -esac +# GNU make sometimes prints "make[1]: Entering...", which would confuse us. +eval `${MAKE-make} -f conftest.make 2>/dev/null | grep temp=` +if test -n "$ac_maketemp"; then + eval ac_cv_prog_make_${ac_make}_set=yes +else + eval ac_cv_prog_make_${ac_make}_set=no +fi rm -f conftest.make fi -if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then +if eval "test \"`echo '$ac_cv_prog_make_'${ac_make}_set`\" = yes"; then echo "$as_me:$LINENO: result: yes" >&5 echo "${ECHO_T}yes" >&6 SET_MAKE= diff --git a/win/configure.in b/win/configure.in index 1f52c52..2538a92 100644 --- a/win/configure.in +++ b/win/configure.in @@ -15,7 +15,7 @@ SHELL=/bin/sh TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".12" +TCL_PATCH_LEVEL=".13" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 -- cgit v0.12 From e396c1dd368d128a020f50ded11b388ad9bd4b4b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 12 Jun 2022 15:13:33 +0000 Subject: Make the idea (finally) work --- generic/tcl.h | 13 ++++++++++--- generic/tclStubLib.c | 2 +- unix/configure | 8 ++------ unix/configure.ac | 8 ++------ unix/dltest/Makefile.in | 35 +++++++++++++++++++++++++++++++++-- 5 files changed, 48 insertions(+), 18 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 429054c..d6a59c6 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2215,7 +2215,12 @@ void * TclStubCall(void *arg); #endif #ifdef USE_TCL_STUBS -#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE +#if TCL_MAJOR_VERSION < 9 +# define Tcl_InitStubs(interp, version, exact) \ + (Tcl_InitStubs)(interp, version, \ + (exact)|(TCL_MAJOR_VERSION<<8)|(0xFF<<16), \ + TCL_STUB_MAGIC) +#elif TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE # define Tcl_InitStubs(interp, version, exact) \ (Tcl_InitStubs)(interp, version, \ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ @@ -2227,7 +2232,9 @@ void * TclStubCall(void *arg); TCL_STUB_MAGIC) #endif #else -#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE +#if TCL_MAJOR_VERSION < 9 +# error "Please define -DUSE_TCL_STUBS" +#elif TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE # define Tcl_InitStubs(interp, version, exact) \ Tcl_PkgInitStubsCheck(interp, version, \ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) @@ -2276,7 +2283,7 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); EXTERN TCL_NORETURN void Tcl_MainExW(size_t argc, wchar_t **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); #endif -#ifdef USE_TCL_STUBS +#if defined(USE_TCL_STUBS) && (TCL_MAJOR_VERSION > 8) #define Tcl_SetPanicProc(panicProc) \ TclInitStubTable(((const char *(*)(Tcl_PanicProc *))TclStubCall((void *)panicProc))(panicProc)) #define Tcl_InitSubsystems() \ diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index d09ab2b..74fcedd 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -68,7 +68,7 @@ Tcl_InitStubs( * times. [Bug 615304] */ - if (!stubsPtr || (stubsPtr->magic != (((exact&0xFF00) >= 0x900) ? magic : TCL_STUB_MAGIC))) { + if (!stubsPtr || (stubsPtr->magic != (((exact&0xFF00) >= 0x900) ? magic : -56378673))) { iPtr->legacyResult = "interpreter uses an incompatible stubs mechanism"; iPtr->legacyFreeProc = 0; /* TCL_STATIC */ return NULL; diff --git a/unix/configure b/unix/configure index 4e69ed6..ca94150 100755 --- a/unix/configure +++ b/unix/configure @@ -11237,15 +11237,11 @@ fi # Replace ${VERSION} with contents of ${TCL_VERSION} # double-eval to account for TCL_TRIM_DOTS. # -eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}" +eval "TCL_STUB_LIB_FILE=libtclstub.a" eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" eval "TCL_STUB_LIB_DIR=\"${libdir}\"" -if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then - TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}" -else - TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`" -fi +TCL_STUB_LIB_FLAG="-ltclstub" TCL_BUILD_STUB_LIB_SPEC="-L`pwd | sed -e 's/ /\\\\ /g'` ${TCL_STUB_LIB_FLAG}" TCL_STUB_LIB_SPEC="-L${TCL_STUB_LIB_DIR} ${TCL_STUB_LIB_FLAG}" diff --git a/unix/configure.ac b/unix/configure.ac index a1a6b17..29933bd 100644 --- a/unix/configure.ac +++ b/unix/configure.ac @@ -932,15 +932,11 @@ fi # Replace ${VERSION} with contents of ${TCL_VERSION} # double-eval to account for TCL_TRIM_DOTS. # -eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}" +eval "TCL_STUB_LIB_FILE=libtclstub.a" eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" eval "TCL_STUB_LIB_DIR=\"${libdir}\"" -if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then - TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}" -else - TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`" -fi +TCL_STUB_LIB_FLAG="-ltclstub" TCL_BUILD_STUB_LIB_SPEC="-L`pwd | sed -e 's/ /\\\\ /g'` ${TCL_STUB_LIB_FLAG}" TCL_STUB_LIB_SPEC="-L${TCL_STUB_LIB_DIR} ${TCL_STUB_LIB_FLAG}" diff --git a/unix/dltest/Makefile.in b/unix/dltest/Makefile.in index 7a872c5..19b7d84 100644 --- a/unix/dltest/Makefile.in +++ b/unix/dltest/Makefile.in @@ -25,11 +25,15 @@ LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \ ${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS} -all: embtest tcl9pkga${SHLIB_SUFFIX} tcl9pkgb${SHLIB_SUFFIX} tcl9pkgc${SHLIB_SUFFIX} tcl9pkgd${SHLIB_SUFFIX} tcl9pkge${SHLIB_SUFFIX} tcl9pkgua${SHLIB_SUFFIX} tcl9pkgooa${SHLIB_SUFFIX} +all: embtest tcl9pkga${SHLIB_SUFFIX} tcl9pkgb${SHLIB_SUFFIX} tcl9pkgc${SHLIB_SUFFIX} \ + tcl9pkgd${SHLIB_SUFFIX} tcl9pkge${SHLIB_SUFFIX} tcl9pkgua${SHLIB_SUFFIX} tcl9pkgooa${SHLIB_SUFFIX} \ + pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} @if test -n "$(DLTEST_SUFFIX)"; then $(MAKE) dltest_suffix; fi @touch ../dltest.marker -dltest_suffix: tcl9pkga${DLTEST_SUFFIX} tcl9pkgb${DLTEST_SUFFIX} tcl9pkgc${DLTEST_SUFFIX} tcl9pkgd${DLTEST_SUFFIX} tcl9pkge${DLTEST_SUFFIX} tcl9pkgua${DLTEST_SUFFIX} tcl9pkgooa${DLTEST_SUFFIX} +dltest_suffix: tcl9pkga${DLTEST_SUFFIX} tcl9pkgb${DLTEST_SUFFIX} tcl9pkgc${DLTEST_SUFFIX} \ + tcl9pkgd${DLTEST_SUFFIX} tcl9pkge${DLTEST_SUFFIX} tcl9pkgua${DLTEST_SUFFIX} tcl9pkgooa${DLTEST_SUFFIX} \ + pkga${DLTEST_SUFFIX} pkgb${DLTEST_SUFFIX} pkgc${DLTEST_SUFFIX} @touch ../dltest.marker embtest.o: $(SRC_DIR)/embtest.c @@ -47,6 +51,15 @@ pkgb.o: $(SRC_DIR)/pkgb.c pkgc.o: $(SRC_DIR)/pkgc.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgc.c +tcl8pkga.o: $(SRC_DIR)/pkga.c + $(CC) -o $@ -c $(CC_SWITCHES) -DTCL_MAJOR_VERSION=8 $(SRC_DIR)/pkga.c + +tcl8pkgb.o: $(SRC_DIR)/pkgb.c + $(CC) -o $@ -c $(CC_SWITCHES) -DTCL_MAJOR_VERSION=8 $(SRC_DIR)/pkgb.c + +tcl8pkgc.o: $(SRC_DIR)/pkgc.c + $(CC) -o $@ -c $(CC_SWITCHES) -DTCL_MAJOR_VERSION=8 $(SRC_DIR)/pkgc.c + pkgd.o: $(SRC_DIR)/pkgd.c $(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgd.c @@ -74,6 +87,15 @@ tcl9pkgb${SHLIB_SUFFIX}: pkgb.o tcl9pkgc${SHLIB_SUFFIX}: pkgc.o ${SHLIB_LD} -o $@ pkgc.o ${SHLIB_LD_LIBS} +pkga${SHLIB_SUFFIX}: tcl8pkga.o + ${SHLIB_LD} -o $@ tcl8pkga.o ${SHLIB_LD_LIBS} + +pkgb${SHLIB_SUFFIX}: tcl8pkgb.o + ${SHLIB_LD} -o $@ tcl8pkgb.o ${SHLIB_LD_LIBS} + +pkgc${SHLIB_SUFFIX}: tcl8pkgc.o + ${SHLIB_LD} -o $@ tcl8pkgc.o ${SHLIB_LD_LIBS} + tcl9pkgd${SHLIB_SUFFIX}: pkgd.o ${SHLIB_LD} -o $@ pkgd.o ${SHLIB_LD_LIBS} @@ -98,6 +120,15 @@ tcl9pkgb${DLTEST_SUFFIX}: pkgb.o tcl9pkgc${DLTEST_SUFFIX}: pkgc.o ${DLTEST_LD} -o $@ pkgc.o ${SHLIB_LD_LIBS} +pkga${DLTEST_SUFFIX}: tcl8pkga.o + ${DLTEST_LD} -o $@ tcl8pkga.o ${SHLIB_LD_LIBS} + +pkgb${DLTEST_SUFFIX}: tcl8pkgb.o + ${DLTEST_LD} -o $@ tcl8pkgb.o ${SHLIB_LD_LIBS} + +pkgc${DLTEST_SUFFIX}: tcl8pkgc.o + ${DLTEST_LD} -o $@ tcl8pkgc.o ${SHLIB_LD_LIBS} + tcl9pkgd${DLTEST_SUFFIX}: pkgd.o ${DLTEST_LD} -o $@ pkgd.o ${SHLIB_LD_LIBS} -- cgit v0.12 From 778ad9fdfa3acfdca6c6089137485eb69af19391 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 12 Jun 2022 16:54:04 +0000 Subject: Enhance for Windows --- win/Makefile.in | 20 +++++++++++++++++++- win/configure | 4 ++-- win/configure.ac | 4 ++-- win/rules.vc | 9 +++++++++ 4 files changed, 32 insertions(+), 5 deletions(-) diff --git a/win/Makefile.in b/win/Makefile.in index 23f7fe4..d0305c5 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -150,8 +150,10 @@ TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@ TCL_DLL_FILE = @TCL_DLL_FILE@ TCL_LIB_FILE = @TCL_LIB_FILE@ DDE_DLL_FILE = tcl9dde$(DDEVER)${DLLSUFFIX} +DDE_DLL_FILE8 = dde$(DDEVER)${DLLSUFFIX} DDE_LIB_FILE = @LIBPREFIX@tcldde$(DDEVER)${DLLSUFFIX}${LIBSUFFIX} REG_DLL_FILE = tcl9registry$(REGVER)${DLLSUFFIX} +REG_DLL_FILE8 = registry$(REGVER)${DLLSUFFIX} REG_LIB_FILE = @LIBPREFIX@tclregistry$(REGVER)${DLLSUFFIX}${LIBSUFFIX} TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX} TEST_EXE_FILE = tcltest${EXESUFFIX} @@ -514,7 +516,7 @@ tcltest: binaries $(TEST_EXE_FILE) $(TEST_DLL_FILE) $(CAT32) tcltest.cmd binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ winextensions ${TCL_ZIP_FILE} $(TCLSH) -winextensions: ${DDE_DLL_FILE} ${REG_DLL_FILE} +winextensions: ${DDE_DLL_FILE} ${REG_DLL_FILE} ${DDE_DLL_FILE8} ${REG_DLL_FILE8} libraries: @@ -588,6 +590,14 @@ ${REG_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${REG_OBJS} @MAKE_DLL@ ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) $(COPY) tclsh.exe.manifest ${REG_DLL_FILE}.manifest +${DDE_DLL_FILE8}: ${TCL_STUB_LIB_FILE} ${DDE_OBJS} + @MAKE_DLL@ -DTCL_MAJOR_VERSION=8 ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) + $(COPY) tclsh.exe.manifest ${DDE_DLL_FILE8}.manifest + +${REG_DLL_FILE8}: ${TCL_STUB_LIB_FILE} ${REG_OBJS} + @MAKE_DLL@ -DTCL_MAJOR_VERSION=8 ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) + $(COPY) tclsh.exe.manifest ${REG_DLL_FILE8}.manifest + ${TEST_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} @$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE} @MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) @@ -839,6 +849,10 @@ install-binaries: binaries $(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \ "$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \ fi + @if [ -f $(DDE_DLL_FILE8) ]; then \ + echo Installing $(DDE_DLL_FILE8); \ + $(COPY) $(DDE_DLL_FILE8) "$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \ + fi @if [ -f $(DDE_LIB_FILE) ]; then \ echo Installing $(DDE_LIB_FILE); \ $(COPY) $(DDE_LIB_FILE) "$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \ @@ -849,6 +863,10 @@ install-binaries: binaries $(COPY) $(ROOT_DIR)/library/registry/pkgIndex.tcl \ "$(LIB_INSTALL_DIR)/registry${REGDOTVER}"; \ fi + @if [ -f $(REG_DLL_FILE8) ]; then \ + echo Installing $(REG_DLL_FILE8); \ + $(COPY) $(REG_DLL_FILE8) "$(LIB_INSTALL_DIR)/registry${REGDOTVER}"; \ + fi @if [ -f $(REG_LIB_FILE) ]; then \ echo Installing $(REG_LIB_FILE); \ $(COPY) $(REG_LIB_FILE) "$(LIB_INSTALL_DIR)/registry${REGDOTVER}"; \ diff --git a/win/configure b/win/configure index 703125e..d47fc6cb 100755 --- a/win/configure +++ b/win/configure @@ -5804,8 +5804,8 @@ eval "TCL_SRC_DIR=\"`cd $srcdir/..; $CYGPATH $(pwd)`\"" eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}" -eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\"" -eval "TCL_STUB_LIB_FLAG=\"-ltclstub${VER}${LIBFLAGSUFFIX}\"" +eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${LIBSUFFIX}\"" +eval "TCL_STUB_LIB_FLAG=\"-ltclstub${LIBFLAGSUFFIX}\"" eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`$CYGPATH $(pwd)` ${TCL_STUB_LIB_FLAG}\"" eval "TCL_STUB_LIB_SPEC=\"-L${libdir} ${TCL_STUB_LIB_FLAG}\"" eval "TCL_BUILD_STUB_LIB_PATH=\"`$CYGPATH $(pwd)`/${TCL_STUB_LIB_FILE}\"" diff --git a/win/configure.ac b/win/configure.ac index dccc3b6..c6ff202 100644 --- a/win/configure.ac +++ b/win/configure.ac @@ -313,8 +313,8 @@ eval "TCL_SRC_DIR=\"`cd $srcdir/..; $CYGPATH $(pwd)`\"" eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}" -eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\"" -eval "TCL_STUB_LIB_FLAG=\"-ltclstub${VER}${LIBFLAGSUFFIX}\"" +eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${LIBSUFFIX}\"" +eval "TCL_STUB_LIB_FLAG=\"-ltclstub${LIBFLAGSUFFIX}\"" eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`$CYGPATH $(pwd)` ${TCL_STUB_LIB_FLAG}\"" eval "TCL_STUB_LIB_SPEC=\"-L${libdir} ${TCL_STUB_LIB_FLAG}\"" eval "TCL_BUILD_STUB_LIB_PATH=\"`$CYGPATH $(pwd)`/${TCL_STUB_LIB_FILE}\"" diff --git a/win/rules.vc b/win/rules.vc index 47c0742..1b8df9c 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1162,7 +1162,12 @@ TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX:t=).exe TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX:t=).exe !endif + +!if "$(TCL_MAJOR_VERSION)" == "8" TCLSTUBLIB = $(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib +!else +TCLSTUBLIB = $(_TCLDIR)\lib\tclstub.lib +!endif TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX:t=).lib # When building extensions, may be linking against Tcl that does not add # "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. @@ -1182,7 +1187,11 @@ TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX:t=).exe !if !exist($(TCLSH)) TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX:t=).exe !endif +!if "$(TCL_MAJOR_VERSION)" == "8" TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib +!else +TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub.lib +!endif TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX:t=).lib # When building extensions, may be linking against Tcl that does not add # "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. -- cgit v0.12 From 6187c67f3b8fae634b2be035c2e600b04120adf0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 12 Jun 2022 20:08:56 +0000 Subject: Handle list/dict compatibility better --- generic/tcl.decls | 1 + generic/tclDecls.h | 28 ++++++++++++++-------------- generic/tclStubInit.c | 12 ++++++------ 3 files changed, 21 insertions(+), 20 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 12a8cbe..1e16c5e 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -312,6 +312,7 @@ declare 79 { declare 80 { void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, void *clientData) } +# Only available in Tcl 8.x, NULL in Tcl 9.0 declare 81 { int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan) } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index d9115ed..20ba011 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4051,31 +4051,31 @@ extern const TclStubs *tclStubsPtr; ? (Tcl_Size (*)(wchar_t *))tclStubsPtr->tcl_UniCharLen \ : (Tcl_Size (*)(wchar_t *))Tcl_Char16Len) # undef Tcl_ListObjGetElements -# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) == sizeof(size_t) \ +# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) != sizeof(int) \ ? tclStubsPtr->tcl_ListObjGetElements((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr)) \ : tclStubsPtr->tclListObjGetElements((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr))) # undef Tcl_ListObjLength -# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) == sizeof(size_t) \ +# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) != sizeof(int) \ ? tclStubsPtr->tcl_ListObjLength((interp), (listPtr), (size_t *)(void *)(lengthPtr)) \ : tclStubsPtr->tclListObjLength((interp), (listPtr), (int *)(void *)(lengthPtr))) # undef Tcl_DictObjSize -# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) == sizeof(size_t) \ +# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) != sizeof(int) \ ? tclStubsPtr->tcl_DictObjSize((interp), (dictPtr), (size_t *)(void *)(sizePtr)) \ : tclStubsPtr->tclDictObjSize((interp), (dictPtr), (int *)(void *)(sizePtr))) # undef Tcl_SplitList -# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(size_t) \ +# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) != sizeof(int) \ ? tclStubsPtr->tcl_SplitList((interp), (listStr), (size_t *)(void *)(argcPtr), (argvPtr)) \ : tclStubsPtr->tclSplitList((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr))) # undef Tcl_SplitPath -# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(size_t) \ +# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) != sizeof(int) \ ? tclStubsPtr->tcl_SplitPath((path), (size_t *)(void *)(argcPtr), (argvPtr)) \ : tclStubsPtr->tclSplitPath((path), (int *)(void *)(argcPtr), (argvPtr))) # undef Tcl_FSSplitPath -# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) == sizeof(size_t) \ +# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) != sizeof(int) \ ? tclStubsPtr->tcl_FSSplitPath((pathPtr), (size_t *)(void *)(lenPtr)) \ : tclStubsPtr->tclFSSplitPath((pathPtr), (int *)(void *)(lenPtr))) # undef Tcl_ParseArgsObjv -# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) == sizeof(size_t) \ +# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) != sizeof(int) \ ? tclStubsPtr->tcl_ParseArgsObjv((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv)) \ : tclStubsPtr->tclParseArgsObjv((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv))) #else @@ -4091,25 +4091,25 @@ extern const TclStubs *tclStubsPtr; # define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ ? (Tcl_Size (*)(wchar_t *))Tcl_UniCharLen \ : (Tcl_Size (*)(wchar_t *))Tcl_Char16Len) -# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) == sizeof(size_t) \ +# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) != sizeof(int) \ ? (Tcl_ListObjGetElements)((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr)) \ : TclListObjGetElements((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr))) -# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) == sizeof(size_t) \ +# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) != sizeof(int) \ ? (Tcl_ListObjLength)((interp), (listPtr), (size_t *)(void *)(lengthPtr)) \ : TclListObjLength((interp), (listPtr), (int *)(void *)(lengthPtr))) -# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) == sizeof(size_t) \ +# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) != sizeof(int) \ ? (Tcl_DictObjSize)((interp), (dictPtr), (size_t *)(void *)(sizePtr)) \ : TclDictObjSize((interp), (dictPtr), (int *)(void *)(sizePtr))) -# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(size_t) \ +# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) != sizeof(int) \ ? (Tcl_SplitList)((interp), (listStr), (size_t *)(void *)(argcPtr), (argvPtr)) \ : TclSplitList((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr))) -# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(size_t) \ +# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) != sizeof(int) \ ? (Tcl_SplitPath)((path), (size_t *)(void *)(argcPtr), (argvPtr)) \ : TclSplitPath((path), (int *)(void *)(argcPtr), (argvPtr))) -# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) == sizeof(size_t) \ +# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) != sizeof(int) \ ? (Tcl_FSSplitPath)((pathPtr), (size_t *)(void *)(lenPtr)) \ : TclFSSplitPath((pathPtr), (int *)(void *)(lenPtr))) -# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) == sizeof(size_t) \ +# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) != sizeof(int) \ ? (Tcl_ParseArgsObjv)((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv)) \ : TclParseArgsObjv((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv))) #endif diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 721c8ea..030fd0a 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -95,7 +95,7 @@ int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t n = TCL_INDEX_NONE; int result = Tcl_ListObjGetElements(interp, listPtr, &n, objvPtr); if (objcPtr) { - if ((result == TCL_OK) && (n > INT_MAX)) { + if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) { if (interp) { Tcl_AppendResult(interp, "List too large to be processed", NULL); } @@ -110,7 +110,7 @@ int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, size_t n = TCL_INDEX_NONE; int result = Tcl_ListObjLength(interp, listPtr, &n); if (lengthPtr) { - if ((result == TCL_OK) && (n > INT_MAX)) { + if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) { if (interp) { Tcl_AppendResult(interp, "List too large to be processed", NULL); } @@ -125,7 +125,7 @@ int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, size_t n = TCL_INDEX_NONE; int result = Tcl_DictObjSize(interp, dictPtr, &n); if (sizePtr) { - if ((result == TCL_OK) && (n > INT_MAX)) { + if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) { if (interp) { Tcl_AppendResult(interp, "Dict too large to be processed", NULL); } @@ -140,7 +140,7 @@ int TclSplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr, size_t n = TCL_INDEX_NONE; int result = Tcl_SplitList(interp, listStr, &n, argvPtr); if (argcPtr) { - if ((result == TCL_OK) && (n > INT_MAX)) { + if ((sizeof(int) != sizeof(size_t)) && (result == TCL_OK) && (n > INT_MAX)) { if (interp) { Tcl_AppendResult(interp, "List too large to be processed", NULL); } @@ -155,7 +155,7 @@ void TclSplitPath(const char *path, int *argcPtr, const char ***argvPtr) { size_t n = TCL_INDEX_NONE; Tcl_SplitPath(path, &n, argvPtr); if (argcPtr) { - if (n > INT_MAX) { + if ((sizeof(int) != sizeof(size_t)) && (n > INT_MAX)) { n = TCL_INDEX_NONE; /* No other way to return an error-situation */ Tcl_Free((void *)*argvPtr); *argvPtr = NULL; @@ -167,7 +167,7 @@ Tcl_Obj *TclFSSplitPath(Tcl_Obj *pathPtr, int *lenPtr) { size_t n = TCL_INDEX_NONE; Tcl_Obj *result = Tcl_FSSplitPath(pathPtr, &n); if (lenPtr) { - if (result && (n > INT_MAX)) { + if ((sizeof(int) != sizeof(size_t)) && result && (n > INT_MAX)) { Tcl_DecrRefCount(result); return NULL; } -- cgit v0.12 From 21b41010750dbec0d33b56bb9ad2e39ba55eaf1b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 12 Jun 2022 21:23:17 +0000 Subject: Handle Tcl_GetByteArrayFromObj() better --- generic/tcl.decls | 2 + generic/tclBinary.c | 37 --------------- generic/tclDecls.h | 125 ++++++++++++++++++++++++++------------------------ generic/tclStubInit.c | 4 ++ 4 files changed, 72 insertions(+), 96 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 1e16c5e..683863b 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -144,6 +144,7 @@ declare 32 { int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr) } +# Only available in Tcl 8.x, NULL in Tcl 9.0 declare 33 { unsigned char *TclGetByteArrayFromObj(Tcl_Obj *objPtr, int *numBytesPtr) } @@ -2480,6 +2481,7 @@ declare 651 { declare 652 { Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, size_t *lengthPtr) } +# Only available in Tcl 8.x, NULL in Tcl 9.0 declare 653 { unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, size_t *numBytesPtr) } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index a45e4b2..90efc9f 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -408,43 +408,6 @@ TclGetBytesFromObj( /* *---------------------------------------------------------------------- * - * Tcl_GetByteArrayFromObj -- - * - * Attempt to get the array of bytes from the Tcl object. If the object - * is not already a ByteArray object, an attempt will be made to convert - * it to one. - * - * Results: - * Pointer to array of bytes representing the ByteArray object. - * - * Side effects: - * Frees old internal rep. Allocates memory for new internal rep. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_GetByteArrayFromObj -unsigned char * -TclGetByteArrayFromObj( - Tcl_Obj *objPtr, /* The ByteArray object. */ - int *numBytesPtr) /* If non-NULL, write the number of bytes - * in the array here */ -{ - return TclGetBytesFromObj(NULL, objPtr, numBytesPtr); -} - -unsigned char * -Tcl_GetByteArrayFromObj( - Tcl_Obj *objPtr, /* The ByteArray object. */ - size_t *numBytesPtr) /* If non-NULL, write the number of bytes - * in the array here */ -{ - return Tcl_GetBytesFromObj(NULL, objPtr, numBytesPtr); -} - -/* - *---------------------------------------------------------------------- - * * Tcl_SetByteArrayLength -- * * This procedure changes the length of the byte array for this object. diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 20ba011..ae8e90c 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3948,45 +3948,52 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_GetUnicodeFromObj #undef Tcl_GetByteArrayFromObj #if defined(USE_TCL_STUBS) -#define Tcl_GetStringFromObj(objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? \ - tclStubsPtr->tclGetStringFromObj(objPtr, (int *)(void *)(sizePtr)) : \ - tclStubsPtr->tcl_GetStringFromObj(objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? \ tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(void *)(sizePtr)) : \ tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(void *)(sizePtr))) +#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ + (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), \ + (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) +#define Tcl_GetStringFromObj(objPtr, sizePtr) \ + (sizeof(*(sizePtr)) <= sizeof(int) ? \ + tclStubsPtr->tclGetStringFromObj(objPtr, (int *)(void *)(sizePtr)) : \ + tclStubsPtr->tcl_GetStringFromObj(objPtr, (size_t *)(void *)(sizePtr))) +#if TCL_MAJOR_VERSION > 8 #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? \ tclStubsPtr->tclGetBytesFromObj(NULL, objPtr, (int *)(void *)(sizePtr)) : \ tclStubsPtr->tcl_GetBytesFromObj(NULL, objPtr, (size_t *)(void *)(sizePtr))) +#else +#define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ + (sizeof(*(sizePtr)) <= sizeof(int) ? \ + tclStubsPtr->tclGetByteArrayFromObj(objPtr, (int *)(void *)(sizePtr)) : \ + tclStubsPtr->tcl_GetByteArrayFromObj(objPtr, (size_t *)(void *)(sizePtr))) +#endif #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? \ tclStubsPtr->tclGetUnicodeFromObj(objPtr, (int *)(void *)(sizePtr)) : \ tclStubsPtr->tcl_GetUnicodeFromObj(objPtr, (size_t *)(void *)(sizePtr))) +#else +#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ + (sizeof(*(sizePtr)) <= sizeof(int) ? \ + TclGetBytesFromObj(interp, objPtr, (int *)(void *)(sizePtr)) : \ + (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ - (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), \ + ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), \ (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) -#else #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? \ - (TclGetStringFromObj)(objPtr, (int *)(void *)(sizePtr)) : \ + TclGetStringFromObj(objPtr, (int *)(void *)(sizePtr)) : \ (Tcl_GetStringFromObj)(objPtr, (size_t *)(void *)(sizePtr))) -#define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - (sizeof(*(sizePtr)) <= sizeof(int) ? \ - (TclGetBytesFromObj)(interp, objPtr, (int *)(void *)(sizePtr)) : \ - (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? \ - (TclGetBytesFromObj)(NULL, objPtr, (int *)(void *)(sizePtr)) : \ + TclGetBytesFromObj(NULL, objPtr, (int *)(void *)(sizePtr)) : \ (Tcl_GetBytesFromObj)(NULL, objPtr, (size_t *)(void *)(sizePtr))) #define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? \ - (TclGetUnicodeFromObj)(objPtr, (int *)(void *)(sizePtr)) : \ - Tcl_GetUnicodeFromObj(objPtr, (size_t *)(void *)(sizePtr))) -#define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ - ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), \ - (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) + TclGetUnicodeFromObj(objPtr, (int *)(void *)(sizePtr)) : \ + (Tcl_GetUnicodeFromObj)(objPtr, (size_t *)(void *)(sizePtr))) #endif #ifdef TCL_MEM_DEBUG @@ -4051,33 +4058,33 @@ extern const TclStubs *tclStubsPtr; ? (Tcl_Size (*)(wchar_t *))tclStubsPtr->tcl_UniCharLen \ : (Tcl_Size (*)(wchar_t *))Tcl_Char16Len) # undef Tcl_ListObjGetElements -# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) != sizeof(int) \ - ? tclStubsPtr->tcl_ListObjGetElements((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr)) \ - : tclStubsPtr->tclListObjGetElements((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr))) +# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) == sizeof(int) \ + ? tclStubsPtr->tclListObjGetElements((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr)) \ + : tclStubsPtr->tcl_ListObjGetElements((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr))) # undef Tcl_ListObjLength -# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) != sizeof(int) \ - ? tclStubsPtr->tcl_ListObjLength((interp), (listPtr), (size_t *)(void *)(lengthPtr)) \ - : tclStubsPtr->tclListObjLength((interp), (listPtr), (int *)(void *)(lengthPtr))) +# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) == sizeof(int) \ + ? tclStubsPtr->tclListObjLength((interp), (listPtr), (int *)(void *)(lengthPtr)) \ + : tclStubsPtr->tcl_ListObjLength((interp), (listPtr), (size_t *)(void *)(lengthPtr))) # undef Tcl_DictObjSize -# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) != sizeof(int) \ - ? tclStubsPtr->tcl_DictObjSize((interp), (dictPtr), (size_t *)(void *)(sizePtr)) \ - : tclStubsPtr->tclDictObjSize((interp), (dictPtr), (int *)(void *)(sizePtr))) +# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) == sizeof(int) \ + ? tclStubsPtr->tclDictObjSize((interp), (dictPtr), (int *)(void *)(sizePtr)) \ + : tclStubsPtr->tcl_DictObjSize((interp), (dictPtr), (size_t *)(void *)(sizePtr))) # undef Tcl_SplitList -# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) != sizeof(int) \ - ? tclStubsPtr->tcl_SplitList((interp), (listStr), (size_t *)(void *)(argcPtr), (argvPtr)) \ - : tclStubsPtr->tclSplitList((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr))) +# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \ + ? tclStubsPtr->tclSplitList((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr)) \ + : tclStubsPtr->tcl_SplitList((interp), (listStr), (size_t *)(void *)(argcPtr), (argvPtr))) # undef Tcl_SplitPath -# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) != sizeof(int) \ - ? tclStubsPtr->tcl_SplitPath((path), (size_t *)(void *)(argcPtr), (argvPtr)) \ - : tclStubsPtr->tclSplitPath((path), (int *)(void *)(argcPtr), (argvPtr))) +# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \ + ? tclStubsPtr->tclSplitPath((path), (int *)(void *)(argcPtr), (argvPtr)) \ + : tclStubsPtr->tcl_SplitPath((path), (size_t *)(void *)(argcPtr), (argvPtr))) # undef Tcl_FSSplitPath -# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) != sizeof(int) \ - ? tclStubsPtr->tcl_FSSplitPath((pathPtr), (size_t *)(void *)(lenPtr)) \ - : tclStubsPtr->tclFSSplitPath((pathPtr), (int *)(void *)(lenPtr))) +# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) == sizeof(int) \ + ? tclStubsPtr->tclFSSplitPath((pathPtr), (int *)(void *)(lenPtr)) \ + : tclStubsPtr->tcl_FSSplitPath((pathPtr), (size_t *)(void *)(lenPtr))) # undef Tcl_ParseArgsObjv -# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) != sizeof(int) \ - ? tclStubsPtr->tcl_ParseArgsObjv((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv)) \ - : tclStubsPtr->tclParseArgsObjv((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv))) +# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) == sizeof(int) \ + ? tclStubsPtr->tclParseArgsObjv((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv)) \ + : tclStubsPtr->tcl_ParseArgsObjv((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv))) #else # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ ? (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_UniCharToUtfDString \ @@ -4091,27 +4098,27 @@ extern const TclStubs *tclStubsPtr; # define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ ? (Tcl_Size (*)(wchar_t *))Tcl_UniCharLen \ : (Tcl_Size (*)(wchar_t *))Tcl_Char16Len) -# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) != sizeof(int) \ - ? (Tcl_ListObjGetElements)((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr)) \ - : TclListObjGetElements((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr))) -# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) != sizeof(int) \ - ? (Tcl_ListObjLength)((interp), (listPtr), (size_t *)(void *)(lengthPtr)) \ - : TclListObjLength((interp), (listPtr), (int *)(void *)(lengthPtr))) -# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) != sizeof(int) \ - ? (Tcl_DictObjSize)((interp), (dictPtr), (size_t *)(void *)(sizePtr)) \ - : TclDictObjSize((interp), (dictPtr), (int *)(void *)(sizePtr))) -# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) != sizeof(int) \ - ? (Tcl_SplitList)((interp), (listStr), (size_t *)(void *)(argcPtr), (argvPtr)) \ - : TclSplitList((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr))) -# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) != sizeof(int) \ - ? (Tcl_SplitPath)((path), (size_t *)(void *)(argcPtr), (argvPtr)) \ - : TclSplitPath((path), (int *)(void *)(argcPtr), (argvPtr))) -# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) != sizeof(int) \ - ? (Tcl_FSSplitPath)((pathPtr), (size_t *)(void *)(lenPtr)) \ - : TclFSSplitPath((pathPtr), (int *)(void *)(lenPtr))) -# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) != sizeof(int) \ - ? (Tcl_ParseArgsObjv)((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv)) \ - : TclParseArgsObjv((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv))) +# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) == sizeof(int) \ + ? TclListObjGetElements((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr)) \ + : (Tcl_ListObjGetElements)((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr))) +# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) == sizeof(int) \ + ? TclListObjLength((interp), (listPtr), (int *)(void *)(lengthPtr)) \ + : (Tcl_ListObjLength)((interp), (listPtr), (size_t *)(void *)(lengthPtr))) +# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) == sizeof(int) \ + ? TclDictObjSize((interp), (dictPtr), (int *)(void *)(sizePtr)) \ + : (Tcl_DictObjSize)((interp), (dictPtr), (size_t *)(void *)(sizePtr))) +# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \ + ? TclSplitList((interp), (listStr), (int *)(void *)(argcPtr), (argvPtr)) \ + : (Tcl_SplitList)((interp), (listStr), (size_t *)(void *)(argcPtr), (argvPtr))) +# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) == sizeof(int) \ + ? TclSplitPath((path), (int *)(void *)(argcPtr), (argvPtr)) \ + : (Tcl_SplitPath)((path), (size_t *)(void *)(argcPtr), (argvPtr))) +# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) == sizeof(int) \ + ? TclFSSplitPath((pathPtr), (int *)(void *)(lenPtr)) \ + : (Tcl_FSSplitPath)((pathPtr), (size_t *)(void *)(lenPtr))) +# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) == sizeof(int) \ + ? TclParseArgsObjv((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv)) \ + : (Tcl_ParseArgsObjv)((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv))) #endif /* diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 030fd0a..0bbf756 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -73,6 +73,10 @@ #endif #undef Tcl_Close #define Tcl_Close 0 +#undef TclGetByteArrayFromObj +#define TclGetByteArrayFromObj 0 +#undef Tcl_GetByteArrayFromObj +#define Tcl_GetByteArrayFromObj 0 #if TCL_UTF_MAX < 4 -- cgit v0.12 From 887f84bb457ee952ff10f6d891037fbe2e1e739c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Jun 2022 07:32:21 +0000 Subject: Use TCL_8_COMPAT to change Tcl_Size to ptrdiff_t --- generic/tcl.h | 11 ++++++++--- generic/tclBasic.c | 2 +- generic/tclCompile.c | 2 +- 3 files changed, 10 insertions(+), 5 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 4e5fc31..f81aad9 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -671,10 +671,15 @@ typedef union Tcl_ObjInternalRep { /* The internal representation: */ * An object stores a value as either a string, some internal representation, * or both. */ -#if TCL_MAJOR_VERSION > 8 -# define Tcl_Size size_t -#else +#if TCL_MAJOR_VERSION < 9 # define Tcl_Size int +#elif defined(TCL_8_COMPAT) +# ifdef BUILD_tcl +# error "TCL_8_COMPAT not supported when building Tcl" +# endif +# define Tcl_Size ptrdiff_t +#else +# define Tcl_Size size_t #endif diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 422445c..1d4b686 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -5197,7 +5197,7 @@ TclEvalEx( wordStart = tokenPtr->start; lines[objectsUsed] = TclWordKnownAtCompileTime(tokenPtr, NULL) - ? wordLine : -1; + ? wordLine : TCL_INDEX_NONE; if (eeFramePtr->type == TCL_LOCATION_SOURCE) { iPtr->evalFlags |= TCL_EVAL_FILE; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 77181ed..f60459b 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -3330,7 +3330,7 @@ EnterCmdWordData( /* See Ticket 4b61afd660 */ wwlines[wordIdx] = ((wordIdx == 0) || TclWordKnownAtCompileTime(tokenPtr, NULL)) - ? wordLine : -1; + ? wordLine : TCL_INDEX_NONE; ePtr->line[wordIdx] = wordLine; ePtr->next[wordIdx] = wordNext; last = tokenPtr->start; -- cgit v0.12 From 94394a076d75649ea7a6d3d9890d15131d6d04b0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 13 Jun 2022 13:46:45 +0000 Subject: Use Tcl_Size in dde/registry --- win/tclWinDde.c | 60 +++++++++++++++------------------------------------------ win/tclWinReg.c | 38 +++++++++--------------------------- 2 files changed, 25 insertions(+), 73 deletions(-) diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 2570954..696f273 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -125,27 +125,9 @@ static int DdeObjCmd(void *clientData, # define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString # define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString # endif +# define Tcl_Size int #endif -static unsigned char * -getByteArrayFromObj( - Tcl_Obj *objPtr, - size_t *lengthPtr -) { - int length; - - unsigned char *result = Tcl_GetByteArrayFromObj(objPtr, &length); -#if TCL_MAJOR_VERSION > 8 - if (sizeof(TCL_HASH_TYPE) > sizeof(int)) { - /* 64-bit and TIP #494 situation: */ - *lengthPtr = *(TCL_HASH_TYPE *) objPtr->internalRep.twoPtrValue.ptr1; - } else -#endif - /* 32-bit or without TIP #494 */ - *lengthPtr = (size_t) (unsigned) length; - return result; -} - #ifdef __cplusplus extern "C" { #endif @@ -647,7 +629,7 @@ DdeServerProc( /* Transaction-dependent data. */ { Tcl_DString dString; - size_t len; + Tcl_Size len; DWORD dlen; WCHAR *utilString; Tcl_Obj *ddeObjectPtr; @@ -767,8 +749,7 @@ DdeServerProc( CP_WINUNICODE); if (_wcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) { returnString = - Tcl_GetString(convPtr->returnPackagePtr); - len = convPtr->returnPackagePtr->length; + Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len); if (uFmt != CF_TEXT) { Tcl_DStringInit(&dsBuf); Tcl_UtfToWCharDString(returnString, len, &dsBuf); @@ -790,8 +771,7 @@ DdeServerProc( convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, TCL_GLOBAL_ONLY); if (variableObjPtr != NULL) { - returnString = Tcl_GetString(variableObjPtr); - len = variableObjPtr->length; + returnString = Tcl_GetStringFromObj(variableObjPtr, &len); if (uFmt != CF_TEXT) { Tcl_DStringInit(&dsBuf); Tcl_UtfToWCharDString(returnString, len, &dsBuf); @@ -939,8 +919,7 @@ DdeServerProc( */ HSZPAIR *returnPtr; - int i; - int numItems; + Tcl_Size i, numItems; for (i = 0, riPtr = tsdPtr->interpListPtr; riPtr != NULL; i++, riPtr = riPtr->nextPtr) { @@ -1325,7 +1304,7 @@ DdeObjCmd( }; int index, i, argIndex; - size_t length; + Tcl_Size length; int flags = 0, result = TCL_OK, firstArg = 0; HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL; HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn; @@ -1488,9 +1467,8 @@ DdeObjCmd( Initialize(); if (firstArg != 1) { - const char *src = Tcl_GetString(objv[firstArg]); + const char *src = Tcl_GetStringFromObj(objv[firstArg], &length); - length = objv[firstArg]->length; Tcl_DStringInit(&serviceBuf); Tcl_UtfToWCharDString(src, length, &serviceBuf); serviceName = (WCHAR *) Tcl_DStringValue(&serviceBuf); @@ -1507,9 +1485,8 @@ DdeObjCmd( } if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) { - const char *src = Tcl_GetString(objv[firstArg + 1]); + const char *src = Tcl_GetStringFromObj(objv[firstArg + 1], &length); - length = objv[firstArg + 1]->length; Tcl_DStringInit(&topicBuf); topicName = Tcl_UtfToWCharDString(src, length, &topicBuf); length = Tcl_DStringLength(&topicBuf) / sizeof(WCHAR); @@ -1539,19 +1516,18 @@ DdeObjCmd( break; case DDE_EXECUTE: { - size_t dataLength; + Tcl_Size dataLength; const void *dataString; Tcl_DString dsBuf; Tcl_DStringInit(&dsBuf); if (flags & DDE_FLAG_BINARY) { dataString = - getByteArrayFromObj(objv[firstArg + 2], &dataLength); + Tcl_GetByteArrayFromObj(objv[firstArg + 2], &dataLength); } else { const char *src; - src = Tcl_GetString(objv[firstArg + 2]); - dataLength = objv[firstArg + 2]->length; + src = Tcl_GetStringFromObj(objv[firstArg + 2], &dataLength); Tcl_DStringInit(&dsBuf); dataString = Tcl_UtfToWCharDString(src, dataLength, &dsBuf); @@ -1604,8 +1580,7 @@ DdeObjCmd( const WCHAR *itemString; const char *src; - src = Tcl_GetString(objv[firstArg + 2]); - length = objv[firstArg + 2]->length; + src = Tcl_GetStringFromObj(objv[firstArg + 2], &length); Tcl_DStringInit(&itemBuf); itemString = Tcl_UtfToWCharDString(src, length, &itemBuf); length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR); @@ -1672,8 +1647,7 @@ DdeObjCmd( BYTE *dataString; const char *src; - src = Tcl_GetString(objv[firstArg + 2]); - length = objv[firstArg + 2]->length; + src = Tcl_GetStringFromObj(objv[firstArg + 2], &length); Tcl_DStringInit(&itemBuf); itemString = Tcl_UtfToWCharDString(src, length, &itemBuf); length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR); @@ -1687,11 +1661,10 @@ DdeObjCmd( Tcl_DStringInit(&dsBuf); if (flags & DDE_FLAG_BINARY) { dataString = (BYTE *) - getByteArrayFromObj(objv[firstArg + 3], &length); + Tcl_GetByteArrayFromObj(objv[firstArg + 3], &length); } else { const char *data = - Tcl_GetString(objv[firstArg + 3]); - length = objv[firstArg + 3]->length; + Tcl_GetStringFromObj(objv[firstArg + 3], &length); Tcl_DStringInit(&dsBuf); dataString = (BYTE *) Tcl_UtfToWCharDString(data, length, &dsBuf); @@ -1855,8 +1828,7 @@ DdeObjCmd( } objPtr = Tcl_ConcatObj(objc, objv); - string = Tcl_GetString(objPtr); - length = objPtr->length; + string = Tcl_GetStringFromObj(objPtr, &length); Tcl_DStringInit(&dsBuf); Tcl_UtfToWCharDString(string, length, &dsBuf); string = Tcl_DStringValue(&dsBuf); diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 998521c..57cf0c6 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -134,25 +134,6 @@ static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, # endif #endif -static unsigned char * -getByteArrayFromObj( - Tcl_Obj *objPtr, - size_t *lengthPtr -) { - int length; - - unsigned char *result = Tcl_GetByteArrayFromObj(objPtr, &length); -#if TCL_MAJOR_VERSION > 8 - if (sizeof(TCL_HASH_TYPE) > sizeof(int)) { - /* 64-bit and TIP #494 situation: */ - *lengthPtr = *(TCL_HASH_TYPE *) objPtr->internalRep.twoPtrValue.ptr1; - } else -#endif - /* 32-bit or without TIP #494 */ - *lengthPtr = (size_t) (unsigned) length; - return result; -} - #ifdef __cplusplus extern "C" { #endif @@ -1289,8 +1270,8 @@ SetValue( if (typeObj == NULL) { type = REG_SZ; } else if (Tcl_GetIndexFromObj(interp, typeObj, typeNames, "type", - 0, (int *) &type) != TCL_OK) { - if (Tcl_GetIntFromObj(NULL, typeObj, (int *) &type) != TCL_OK) { + 0, &type) != TCL_OK) { + if (Tcl_GetIntFromObj(NULL, typeObj, &type) != TCL_OK) { return TCL_ERROR; } Tcl_ResetResult(interp); @@ -1318,7 +1299,7 @@ SetValue( (DWORD) type, (BYTE *) &value, sizeof(DWORD)); } else if (type == REG_MULTI_SZ) { Tcl_DString data, buf; - int objc, i; + Tcl_Size objc, i; Tcl_Obj **objv; if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) { @@ -1372,13 +1353,13 @@ SetValue( Tcl_DStringFree(&buf); } else { BYTE *data; - size_t bytelength; + Tcl_Size bytelength; /* * Store binary data in the registry. */ - data = (BYTE *) getByteArrayFromObj(dataObj, &bytelength); + data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &bytelength); result = RegSetValueExW(key, (WCHAR *) valueName, 0, (DWORD) type, data, (DWORD) bytelength); } @@ -1421,15 +1402,14 @@ BroadcastValue( LRESULT result; DWORD_PTR sendResult; int timeout = 3000; - size_t len; + Tcl_Size len; const char *str; Tcl_Obj *objPtr; WCHAR *wstr; Tcl_DString ds; if (objc == 3) { - str = Tcl_GetString(objv[1]); - len = objv[1]->length; + str = Tcl_GetStringFromObj(objv[1], &len); if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", len)) { return TCL_BREAK; } @@ -1438,9 +1418,9 @@ BroadcastValue( } } - str = Tcl_GetString(objv[0]); + str = Tcl_GetStringFromObj(objv[0], &len); Tcl_DStringInit(&ds); - wstr = Tcl_UtfToWCharDString(str, objv[0]->length, &ds); + wstr = Tcl_UtfToWCharDString(str, len, &ds); if (Tcl_DStringLength(&ds) == 0) { wstr = NULL; } -- cgit v0.12 From 573a1e921995ebff38426b73818fc32d234c9efa Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Jun 2022 15:13:48 +0000 Subject: More Tcl_Size --- generic/tclInt.decls | 52 ++++++++++++++--------------- generic/tclIntDecls.h | 90 +++++++++++++++++++++++++-------------------------- generic/tclProc.c | 2 +- 3 files changed, 72 insertions(+), 72 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 9a92888..7e73d58 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -28,18 +28,18 @@ declare 3 { void TclAllocateFreeObjects(void) } declare 5 { - int TclCleanupChildren(Tcl_Interp *interp, size_t numPids, Tcl_Pid *pidPtr, + int TclCleanupChildren(Tcl_Interp *interp, Tcl_Size numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan) } declare 6 { void TclCleanupCommand(Command *cmdPtr) } declare 7 { - size_t TclCopyAndCollapse(size_t count, const char *src, char *dst) + Tcl_Size TclCopyAndCollapse(Tcl_Size count, const char *src, char *dst) } # TclCreatePipeline unofficially exported for use by BLT. declare 9 { - size_t TclCreatePipeline(Tcl_Interp *interp, size_t argc, const char **argv, + Tcl_Size TclCreatePipeline(Tcl_Interp *interp, Tcl_Size argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr) } @@ -63,7 +63,7 @@ declare 16 { declare 22 { int TclFindElement(Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, - size_t *sizePtr, int *bracePtr) + Tcl_Size *sizePtr, int *bracePtr) } declare 23 { Proc *TclFindProc(Interp *iPtr, const char *procName) @@ -146,7 +146,7 @@ declare 64 { int flags) } declare 69 { - void *TclpAlloc(size_t size) + void *TclpAlloc(TCL_HASH_TYPE size) } declare 74 { void TclpFree(void *ptr) @@ -158,7 +158,7 @@ declare 76 { unsigned long long TclpGetSeconds(void) } declare 81 { - void *TclpRealloc(void *ptr, size_t size) + void *TclpRealloc(void *ptr, TCL_HASH_TYPE size) } declare 89 { int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, @@ -203,7 +203,7 @@ declare 109 { int TclUpdateReturnInfo(Interp *iPtr) } declare 110 { - int TclSockMinimumBuffers(void *sock, size_t size) + int TclSockMinimumBuffers(void *sock, Tcl_Size size) } # Removed in 8.1: # declare 110 { @@ -264,7 +264,7 @@ declare 142 { CompileHookProc *hookProc, void *clientData) } declare 143 { - size_t TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, + Tcl_Size TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr) } declare 144 { @@ -290,8 +290,8 @@ declare 150 { int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re) } declare 151 { - void TclRegExpRangeUniChar(Tcl_RegExp re, size_t index, size_t *startPtr, - size_t *endPtr) + void TclRegExpRangeUniChar(Tcl_RegExp re, Tcl_Size index, Tcl_Size *startPtr, + Tcl_Size *endPtr) } declare 152 { void TclSetLibraryPath(Tcl_Obj *pathPtr) @@ -339,7 +339,7 @@ declare 165 { # New function due to TIP #33 declare 166 { int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, - size_t index, Tcl_Obj *valuePtr) + Tcl_Size index, Tcl_Obj *valuePtr) } # variant of Tcl_UtfNCmp that takes n as bytes, not chars @@ -348,20 +348,20 @@ declare 169 { } declare 170 { int TclCheckInterpTraces(Tcl_Interp *interp, const char *command, - size_t numChars, Command *cmdPtr, int result, int traceFlags, - size_t objc, Tcl_Obj *const objv[]) + Tcl_Size numChars, Command *cmdPtr, int result, int traceFlags, + Tcl_Size objc, Tcl_Obj *const objv[]) } declare 171 { int TclCheckExecutionTraces(Tcl_Interp *interp, const char *command, - size_t numChars, Command *cmdPtr, int result, int traceFlags, - size_t objc, Tcl_Obj *const objv[]) + Tcl_Size numChars, Command *cmdPtr, int result, int traceFlags, + Tcl_Size objc, Tcl_Obj *const objv[]) } declare 172 { int TclInThreadExit(void) } declare 173 { - int TclUniCharMatch(const Tcl_UniChar *string, size_t strLen, - const Tcl_UniChar *pattern, size_t ptnLen, int flags) + int TclUniCharMatch(const Tcl_UniChar *string, Tcl_Size strLen, + const Tcl_UniChar *pattern, Tcl_Size ptnLen, int flags) } declare 175 { int TclCallVarTraces(Interp *iPtr, Var *arrayPtr, Var *varPtr, @@ -419,7 +419,7 @@ declare 214 { void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding) } declare 215 { - void *TclStackAlloc(Tcl_Interp *interp, size_t numBytes) + void *TclStackAlloc(Tcl_Interp *interp, Tcl_Size numBytes) } declare 216 { void TclStackFree(Tcl_Interp *interp, void *freePtr) @@ -438,13 +438,13 @@ declare 224 { } declare 225 { Tcl_Obj *TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr, - size_t keyc, Tcl_Obj *const keyv[], int flags) + Tcl_Size keyc, Tcl_Obj *const keyv[], int flags) } declare 226 { int TclObjBeingDeleted(Tcl_Obj *objPtr) } declare 227 { - void TclSetNsPath(Namespace *nsPtr, size_t pathLength, + void TclSetNsPath(Namespace *nsPtr, Tcl_Size pathLength, Tcl_Namespace *pathAry[]) } declare 229 { @@ -492,7 +492,7 @@ declare 238 { } declare 239 { int TclNRInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj, - size_t skip, ProcErrorProc *errorProc) + Tcl_Size skip, ProcErrorProc *errorProc) } declare 240 { int TclNRRunCallbacks(Tcl_Interp *interp, int result, @@ -503,7 +503,7 @@ declare 241 { const CmdFrame *invoker, int word) } declare 242 { - int TclNREvalObjv(Tcl_Interp *interp, size_t objc, + int TclNREvalObjv(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr) } @@ -520,8 +520,8 @@ declare 245 { Tcl_HashTable *TclGetNamespaceCommandTable(Tcl_Namespace *nsPtr) } declare 246 { - int TclInitRewriteEnsemble(Tcl_Interp *interp, size_t numRemoved, - size_t numInserted, Tcl_Obj *const *objv) + int TclInitRewriteEnsemble(Tcl_Interp *interp, Tcl_Size numRemoved, + Tcl_Size numInserted, Tcl_Obj *const *objv) } declare 247 { void TclResetRewriteEnsemble(Tcl_Interp *interp, int isRootEnsemble) @@ -543,8 +543,8 @@ declare 250 { # Allow extensions for optimization declare 251 { - size_t TclRegisterLiteral(void *envPtr, - const char *bytes, size_t length, int flags) + Tcl_Size TclRegisterLiteral(void *envPtr, + const char *bytes, Tcl_Size length, int flags) } # Exporting of the internal API to variables. diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index d3c05d5..d71f355 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -51,16 +51,16 @@ EXTERN void TclAllocateFreeObjects(void); /* Slot 4 is reserved */ /* 5 */ EXTERN int TclCleanupChildren(Tcl_Interp *interp, - size_t numPids, Tcl_Pid *pidPtr, + Tcl_Size numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 6 */ EXTERN void TclCleanupCommand(Command *cmdPtr); /* 7 */ -EXTERN size_t TclCopyAndCollapse(size_t count, const char *src, +EXTERN Tcl_Size TclCopyAndCollapse(Tcl_Size count, const char *src, char *dst); /* Slot 8 is reserved */ /* 9 */ -EXTERN size_t TclCreatePipeline(Tcl_Interp *interp, size_t argc, +EXTERN Tcl_Size TclCreatePipeline(Tcl_Interp *interp, Tcl_Size argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); @@ -89,7 +89,7 @@ EXTERN void TclExprFloatError(Tcl_Interp *interp, double value); EXTERN int TclFindElement(Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, - const char **nextPtr, size_t *sizePtr, + const char **nextPtr, Tcl_Size *sizePtr, int *bracePtr); /* 23 */ EXTERN Proc * TclFindProc(Interp *iPtr, const char *procName); @@ -179,7 +179,7 @@ EXTERN int TclObjInvoke(Tcl_Interp *interp, int objc, /* Slot 67 is reserved */ /* Slot 68 is reserved */ /* 69 */ -EXTERN void * TclpAlloc(size_t size); +EXTERN void * TclpAlloc(TCL_HASH_TYPE size); /* Slot 70 is reserved */ /* Slot 71 is reserved */ /* Slot 72 is reserved */ @@ -195,7 +195,7 @@ EXTERN unsigned long long TclpGetSeconds(void); /* Slot 79 is reserved */ /* Slot 80 is reserved */ /* 81 */ -EXTERN void * TclpRealloc(void *ptr, size_t size); +EXTERN void * TclpRealloc(void *ptr, TCL_HASH_TYPE size); /* Slot 82 is reserved */ /* Slot 83 is reserved */ /* Slot 84 is reserved */ @@ -243,7 +243,7 @@ EXTERN void TclTeardownNamespace(Namespace *nsPtr); /* 109 */ EXTERN int TclUpdateReturnInfo(Interp *iPtr); /* 110 */ -EXTERN int TclSockMinimumBuffers(void *sock, size_t size); +EXTERN int TclSockMinimumBuffers(void *sock, Tcl_Size size); /* 111 */ EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp, const char *name, @@ -309,7 +309,7 @@ EXTERN int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, void *clientData); /* 143 */ -EXTERN size_t TclAddLiteralObj(struct CompileEnv *envPtr, +EXTERN Tcl_Size TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 144 */ EXTERN void TclHideLiteral(Tcl_Interp *interp, @@ -327,8 +327,8 @@ EXTERN void TclHandleRelease(TclHandle handle); /* 150 */ EXTERN int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re); /* 151 */ -EXTERN void TclRegExpRangeUniChar(Tcl_RegExp re, size_t index, - size_t *startPtr, size_t *endPtr); +EXTERN void TclRegExpRangeUniChar(Tcl_RegExp re, Tcl_Size index, + Tcl_Size *startPtr, Tcl_Size *endPtr); /* 152 */ EXTERN void TclSetLibraryPath(Tcl_Obj *pathPtr); /* 153 */ @@ -358,7 +358,7 @@ EXTERN void TclExpandCodeArray(void *envPtr); EXTERN void TclpSetInitialEncodings(void); /* 166 */ EXTERN int TclListObjSetElement(Tcl_Interp *interp, - Tcl_Obj *listPtr, size_t index, + Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj *valuePtr); /* Slot 167 is reserved */ /* Slot 168 is reserved */ @@ -367,20 +367,20 @@ EXTERN int TclpUtfNcmp2(const char *s1, const char *s2, size_t n); /* 170 */ EXTERN int TclCheckInterpTraces(Tcl_Interp *interp, - const char *command, size_t numChars, + const char *command, Tcl_Size numChars, Command *cmdPtr, int result, int traceFlags, - size_t objc, Tcl_Obj *const objv[]); + Tcl_Size objc, Tcl_Obj *const objv[]); /* 171 */ EXTERN int TclCheckExecutionTraces(Tcl_Interp *interp, - const char *command, size_t numChars, + const char *command, Tcl_Size numChars, Command *cmdPtr, int result, int traceFlags, - size_t objc, Tcl_Obj *const objv[]); + Tcl_Size objc, Tcl_Obj *const objv[]); /* 172 */ EXTERN int TclInThreadExit(void); /* 173 */ EXTERN int TclUniCharMatch(const Tcl_UniChar *string, - size_t strLen, const Tcl_UniChar *pattern, - size_t ptnLen, int flags); + Tcl_Size strLen, const Tcl_UniChar *pattern, + Tcl_Size ptnLen, int flags); /* Slot 174 is reserved */ /* 175 */ EXTERN int TclCallVarTraces(Interp *iPtr, Var *arrayPtr, @@ -451,7 +451,7 @@ EXTERN Tcl_Obj * TclGetObjNameOfExecutable(void); EXTERN void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding); /* 215 */ -EXTERN void * TclStackAlloc(Tcl_Interp *interp, size_t numBytes); +EXTERN void * TclStackAlloc(Tcl_Interp *interp, Tcl_Size numBytes); /* 216 */ EXTERN void TclStackFree(Tcl_Interp *interp, void *freePtr); /* 217 */ @@ -470,12 +470,12 @@ EXTERN void TclPopStackFrame(Tcl_Interp *interp); EXTERN TclPlatformType * TclGetPlatform(void); /* 225 */ EXTERN Tcl_Obj * TclTraceDictPath(Tcl_Interp *interp, - Tcl_Obj *rootPtr, size_t keyc, + Tcl_Obj *rootPtr, Tcl_Size keyc, Tcl_Obj *const keyv[], int flags); /* 226 */ EXTERN int TclObjBeingDeleted(Tcl_Obj *objPtr); /* 227 */ -EXTERN void TclSetNsPath(Namespace *nsPtr, size_t pathLength, +EXTERN void TclSetNsPath(Namespace *nsPtr, Tcl_Size pathLength, Tcl_Namespace *pathAry[]); /* Slot 228 is reserved */ /* 229 */ @@ -508,7 +508,7 @@ EXTERN int TclNRInterpProc(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 239 */ EXTERN int TclNRInterpProcCore(Tcl_Interp *interp, - Tcl_Obj *procNameObj, size_t skip, + Tcl_Obj *procNameObj, Tcl_Size skip, ProcErrorProc *errorProc); /* 240 */ EXTERN int TclNRRunCallbacks(Tcl_Interp *interp, int result, @@ -517,7 +517,7 @@ EXTERN int TclNRRunCallbacks(Tcl_Interp *interp, int result, EXTERN int TclNREvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 242 */ -EXTERN int TclNREvalObjv(Tcl_Interp *interp, size_t objc, +EXTERN int TclNREvalObjv(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 243 */ @@ -528,7 +528,7 @@ EXTERN Tcl_HashTable * TclGetNamespaceChildTable(Tcl_Namespace *nsPtr); EXTERN Tcl_HashTable * TclGetNamespaceCommandTable(Tcl_Namespace *nsPtr); /* 246 */ EXTERN int TclInitRewriteEnsemble(Tcl_Interp *interp, - size_t numRemoved, size_t numInserted, + Tcl_Size numRemoved, Tcl_Size numInserted, Tcl_Obj *const *objv); /* 247 */ EXTERN void TclResetRewriteEnsemble(Tcl_Interp *interp, @@ -544,8 +544,8 @@ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, EXTERN void TclSetChildCancelFlags(Tcl_Interp *interp, int flags, int force); /* 251 */ -EXTERN size_t TclRegisterLiteral(void *envPtr, const char *bytes, - size_t length, int flags); +EXTERN Tcl_Size TclRegisterLiteral(void *envPtr, const char *bytes, + Tcl_Size length, int flags); /* 252 */ EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, @@ -586,11 +586,11 @@ typedef struct TclIntStubs { void (*reserved2)(void); void (*tclAllocateFreeObjects) (void); /* 3 */ void (*reserved4)(void); - int (*tclCleanupChildren) (Tcl_Interp *interp, size_t numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ + int (*tclCleanupChildren) (Tcl_Interp *interp, Tcl_Size numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */ - size_t (*tclCopyAndCollapse) (size_t count, const char *src, char *dst); /* 7 */ + Tcl_Size (*tclCopyAndCollapse) (Tcl_Size count, const char *src, char *dst); /* 7 */ void (*reserved8)(void); - size_t (*tclCreatePipeline) (Tcl_Interp *interp, size_t argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */ + Tcl_Size (*tclCreatePipeline) (Tcl_Interp *interp, Tcl_Size argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */ int (*tclCreateProc) (Tcl_Interp *interp, Namespace *nsPtr, const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); /* 10 */ void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */ void (*tclDeleteVars) (Interp *iPtr, TclVarHashTable *tablePtr); /* 12 */ @@ -603,7 +603,7 @@ typedef struct TclIntStubs { void (*reserved19)(void); void (*reserved20)(void); void (*reserved21)(void); - int (*tclFindElement) (Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, size_t *sizePtr, int *bracePtr); /* 22 */ + int (*tclFindElement) (Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, Tcl_Size *sizePtr, int *bracePtr); /* 22 */ Proc * (*tclFindProc) (Interp *iPtr, const char *procName); /* 23 */ size_t (*tclFormatInt) (char *buffer, Tcl_WideInt n); /* 24 */ void (*tclFreePackageInfo) (Interp *iPtr); /* 25 */ @@ -650,7 +650,7 @@ typedef struct TclIntStubs { void (*reserved66)(void); void (*reserved67)(void); void (*reserved68)(void); - void * (*tclpAlloc) (size_t size); /* 69 */ + void * (*tclpAlloc) (TCL_HASH_TYPE size); /* 69 */ void (*reserved70)(void); void (*reserved71)(void); void (*reserved72)(void); @@ -662,7 +662,7 @@ typedef struct TclIntStubs { void (*reserved78)(void); void (*reserved79)(void); void (*reserved80)(void); - void * (*tclpRealloc) (void *ptr, size_t size); /* 81 */ + void * (*tclpRealloc) (void *ptr, TCL_HASH_TYPE size); /* 81 */ void (*reserved82)(void); void (*reserved83)(void); void (*reserved84)(void); @@ -691,7 +691,7 @@ typedef struct TclIntStubs { void (*reserved107)(void); void (*tclTeardownNamespace) (Namespace *nsPtr); /* 108 */ int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */ - int (*tclSockMinimumBuffers) (void *sock, size_t size); /* 110 */ + int (*tclSockMinimumBuffers) (void *sock, Tcl_Size size); /* 110 */ void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */ void (*reserved112)(void); void (*reserved113)(void); @@ -724,7 +724,7 @@ typedef struct TclIntStubs { void (*reserved140)(void); const char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */ int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, void *clientData); /* 142 */ - size_t (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */ + Tcl_Size (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */ void (*tclHideLiteral) (Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 144 */ const struct AuxDataType * (*tclGetAuxDataType) (const char *typeName); /* 145 */ TclHandle (*tclHandleCreate) (void *ptr); /* 146 */ @@ -732,7 +732,7 @@ typedef struct TclIntStubs { TclHandle (*tclHandlePreserve) (TclHandle handle); /* 148 */ void (*tclHandleRelease) (TclHandle handle); /* 149 */ int (*tclRegAbout) (Tcl_Interp *interp, Tcl_RegExp re); /* 150 */ - void (*tclRegExpRangeUniChar) (Tcl_RegExp re, size_t index, size_t *startPtr, size_t *endPtr); /* 151 */ + void (*tclRegExpRangeUniChar) (Tcl_RegExp re, Tcl_Size index, Tcl_Size *startPtr, Tcl_Size *endPtr); /* 151 */ void (*tclSetLibraryPath) (Tcl_Obj *pathPtr); /* 152 */ Tcl_Obj * (*tclGetLibraryPath) (void); /* 153 */ void (*reserved154)(void); @@ -747,14 +747,14 @@ typedef struct TclIntStubs { const void * (*tclGetInstructionTable) (void); /* 163 */ void (*tclExpandCodeArray) (void *envPtr); /* 164 */ void (*tclpSetInitialEncodings) (void); /* 165 */ - int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t index, Tcl_Obj *valuePtr); /* 166 */ + int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj *valuePtr); /* 166 */ void (*reserved167)(void); void (*reserved168)(void); int (*tclpUtfNcmp2) (const char *s1, const char *s2, size_t n); /* 169 */ - int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, size_t objc, Tcl_Obj *const objv[]); /* 170 */ - int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, size_t numChars, Command *cmdPtr, int result, int traceFlags, size_t objc, Tcl_Obj *const objv[]); /* 171 */ + int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, Tcl_Size numChars, Command *cmdPtr, int result, int traceFlags, Tcl_Size objc, Tcl_Obj *const objv[]); /* 170 */ + int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, Tcl_Size numChars, Command *cmdPtr, int result, int traceFlags, Tcl_Size objc, Tcl_Obj *const objv[]); /* 171 */ int (*tclInThreadExit) (void); /* 172 */ - int (*tclUniCharMatch) (const Tcl_UniChar *string, size_t strLen, const Tcl_UniChar *pattern, size_t ptnLen, int flags); /* 173 */ + int (*tclUniCharMatch) (const Tcl_UniChar *string, Tcl_Size strLen, const Tcl_UniChar *pattern, Tcl_Size ptnLen, int flags); /* 173 */ void (*reserved174)(void); int (*tclCallVarTraces) (Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg); /* 175 */ void (*tclCleanupVar) (Var *varPtr, Var *arrayPtr); /* 176 */ @@ -796,7 +796,7 @@ typedef struct TclIntStubs { void (*tclpFindExecutable) (const char *argv0); /* 212 */ Tcl_Obj * (*tclGetObjNameOfExecutable) (void); /* 213 */ void (*tclSetObjNameOfExecutable) (Tcl_Obj *name, Tcl_Encoding encoding); /* 214 */ - void * (*tclStackAlloc) (Tcl_Interp *interp, size_t numBytes); /* 215 */ + void * (*tclStackAlloc) (Tcl_Interp *interp, Tcl_Size numBytes); /* 215 */ void (*tclStackFree) (Tcl_Interp *interp, void *freePtr); /* 216 */ int (*tclPushStackFrame) (Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, Tcl_Namespace *namespacePtr, int isProcCallFrame); /* 217 */ void (*tclPopStackFrame) (Tcl_Interp *interp); /* 218 */ @@ -806,9 +806,9 @@ typedef struct TclIntStubs { void (*reserved222)(void); void (*reserved223)(void); TclPlatformType * (*tclGetPlatform) (void); /* 224 */ - Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp *interp, Tcl_Obj *rootPtr, size_t keyc, Tcl_Obj *const keyv[], int flags); /* 225 */ + Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp *interp, Tcl_Obj *rootPtr, Tcl_Size keyc, Tcl_Obj *const keyv[], int flags); /* 225 */ int (*tclObjBeingDeleted) (Tcl_Obj *objPtr); /* 226 */ - void (*tclSetNsPath) (Namespace *nsPtr, size_t pathLength, Tcl_Namespace *pathAry[]); /* 227 */ + void (*tclSetNsPath) (Namespace *nsPtr, Tcl_Size pathLength, Tcl_Namespace *pathAry[]); /* 227 */ void (*reserved228)(void); int (*tclPtrMakeUpvar) (Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); /* 229 */ Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, int createPart1, int createPart2, Var **arrayPtrPtr); /* 230 */ @@ -820,19 +820,19 @@ typedef struct TclIntStubs { void (*reserved236)(void); int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ int (*tclNRInterpProc) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */ - int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, size_t skip, ProcErrorProc *errorProc); /* 239 */ + int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, Tcl_Size skip, ProcErrorProc *errorProc); /* 239 */ int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result, struct NRE_callback *rootPtr); /* 240 */ int (*tclNREvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 241 */ - int (*tclNREvalObjv) (Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 242 */ + int (*tclNREvalObjv) (Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 242 */ void (*tclDbDumpActiveObjects) (FILE *outFile); /* 243 */ Tcl_HashTable * (*tclGetNamespaceChildTable) (Tcl_Namespace *nsPtr); /* 244 */ Tcl_HashTable * (*tclGetNamespaceCommandTable) (Tcl_Namespace *nsPtr); /* 245 */ - int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, size_t numRemoved, size_t numInserted, Tcl_Obj *const *objv); /* 246 */ + int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, Tcl_Size numRemoved, Tcl_Size numInserted, Tcl_Obj *const *objv); /* 246 */ void (*tclResetRewriteEnsemble) (Tcl_Interp *interp, int isRootEnsemble); /* 247 */ int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, long long toRead, Tcl_Obj *cmdPtr); /* 248 */ char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ void (*tclSetChildCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ - size_t (*tclRegisterLiteral) (void *envPtr, const char *bytes, size_t length, int flags); /* 251 */ + Tcl_Size (*tclRegisterLiteral) (void *envPtr, const char *bytes, Tcl_Size length, int flags); /* 251 */ Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 252 */ Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 253 */ Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); /* 254 */ diff --git a/generic/tclProc.c b/generic/tclProc.c index 5c7702f..e8f379d 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -2228,7 +2228,7 @@ TclUpdateReturnInfo( Tcl_ObjCmdProc * TclGetObjInterpProc(void) { - return (Tcl_ObjCmdProc *) TclObjInterpProc; + return TclObjInterpProc; } /* -- cgit v0.12 From 105bdf44be38516b1fdc48557cfb55d9e440a94c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Jun 2022 21:26:54 +0000 Subject: More Tcl_Size , --- generic/tclInt.decls | 4 +- generic/tclInt.h | 269 +++++++++++++++++++++++++++----------------------- generic/tclIntDecls.h | 8 +- generic/tclUtil.c | 2 +- 4 files changed, 154 insertions(+), 129 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 7e73d58..8a4a0ca 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -62,7 +62,7 @@ declare 16 { } declare 22 { int TclFindElement(Tcl_Interp *interp, const char *listStr, - int listLength, const char **elementPtr, const char **nextPtr, + Tcl_Size listLength, const char **elementPtr, const char **nextPtr, Tcl_Size *sizePtr, int *bracePtr) } declare 23 { @@ -70,7 +70,7 @@ declare 23 { } # Replaced with macro (see tclInt.h) in Tcl 8.5.0, restored in 8.5.10 declare 24 { - size_t TclFormatInt(char *buffer, Tcl_WideInt n) + Tcl_Size TclFormatInt(char *buffer, Tcl_WideInt n) } declare 25 { void TclFreePackageInfo(Interp *iPtr) diff --git a/generic/tclInt.h b/generic/tclInt.h index 9caef63..8b09c0f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -171,7 +171,7 @@ typedef struct Tcl_ResolvedVarInfo { } Tcl_ResolvedVarInfo; typedef int (Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp, - const char *name, size_t length, Tcl_Namespace *context, + const char *name, Tcl_Size length, Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr); typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, const char *name, @@ -273,16 +273,20 @@ typedef struct Namespace { * strings; values have type (Namespace *). If * NULL, there are no children. */ #endif +#if TCL_MAJOR_VERSION > 8 size_t nsId; /* Unique id for the namespace. */ +#else + unsigned long nsId; +#endif Tcl_Interp *interp; /* The interpreter containing this * namespace. */ int flags; /* OR-ed combination of the namespace status * flags NS_DYING and NS_DEAD listed below. */ - size_t activationCount; /* Number of "activations" or active call + Tcl_Size activationCount; /* Number of "activations" or active call * frames for this namespace that are on the * Tcl call stack. The namespace won't be * freed until activationCount becomes zero. */ - size_t refCount; /* Count of references by namespaceName + TCL_HASH_TYPE refCount; /* Count of references by namespaceName * objects. The namespace can't be freed until * refCount becomes zero. */ Tcl_HashTable cmdTable; /* Contains all the commands currently @@ -303,16 +307,16 @@ typedef struct Namespace { * commands; however, no namespace qualifiers * are allowed. NULL if no export patterns are * registered. */ - size_t numExportPatterns; /* Number of export patterns currently + Tcl_Size numExportPatterns; /* Number of export patterns currently * registered using "namespace export". */ - size_t maxExportPatterns; /* Number of export patterns for which space + Tcl_Size maxExportPatterns; /* Number of export patterns for which space * is currently allocated. */ - size_t cmdRefEpoch; /* Incremented if a newly added command + TCL_HASH_TYPE cmdRefEpoch; /* Incremented if a newly added command * shadows a command for which this namespace * has already cached a Command* pointer; this * causes all its cached Command* pointers to * be invalidated. */ - size_t resolverEpoch; /* Incremented whenever (a) the name + TCL_HASH_TYPE resolverEpoch; /* Incremented whenever (a) the name * resolution rules change for this namespace * or (b) a newly added command shadows a * command that is compiled to bytecodes. This @@ -339,7 +343,7 @@ typedef struct Namespace { * LookupCompiledLocal to resolve variable * references within the namespace at compile * time. */ - size_t exportLookupEpoch; /* Incremented whenever a command is added to + TCL_HASH_TYPE exportLookupEpoch; /* Incremented whenever a command is added to * a namespace, removed from a namespace or * the exports of a namespace are changed. * Allows TIP#112-driven command lists to be @@ -350,7 +354,7 @@ typedef struct Namespace { Tcl_Obj *unknownHandlerPtr; /* A script fragment to be used when command * resolution in this namespace fails. TIP * 181. */ - size_t commandPathLength; /* The length of the explicit path. */ + Tcl_Size commandPathLength; /* The length of the explicit path. */ NamespacePathEntry *commandPathArray; /* The explicit path of the namespace as an * array. */ @@ -438,7 +442,7 @@ typedef struct EnsembleConfig { * if the command has been deleted (or never * existed; the global namespace never has an * ensemble command.) */ - size_t epoch; /* The epoch at which this ensemble's table of + TCL_HASH_TYPE epoch; /* The epoch at which this ensemble's table of * exported commands is valid. */ char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all * consistent points, this will have the same @@ -495,7 +499,7 @@ typedef struct EnsembleConfig { * core, presumably because the ensemble * itself has been updated. */ Tcl_Obj *parameterList; /* List of ensemble parameter names. */ - size_t numParameters; /* Cached number of parameters. This is either + Tcl_Size numParameters; /* Cached number of parameters. This is either * 0 (if the parameterList field is NULL) or * the length of the list in the parameterList * field. */ @@ -551,7 +555,7 @@ typedef struct CommandTrace { struct CommandTrace *nextPtr; /* Next in list of traces associated with a * particular command. */ - size_t refCount; /* Used to ensure this structure is not + TCL_HASH_TYPE refCount; /* Used to ensure this structure is not * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ @@ -624,7 +628,7 @@ typedef struct Var { typedef struct VarInHash { Var var; - size_t refCount; /* Counts number of active uses of this + TCL_HASH_TYPE refCount; /* Counts number of active uses of this * variable: 1 for the entry in the hash * table, 1 for each additional variable whose * linkPtr points here, 1 for each nested @@ -927,9 +931,9 @@ typedef struct CompiledLocal { /* Next compiler-recognized local variable for * this procedure, or NULL if this is the last * local. */ - size_t nameLength; /* The number of bytes in local variable's name. + Tcl_Size nameLength; /* The number of bytes in local variable's name. * Among others used to speed up var lookups. */ - size_t frameIndex; /* Index in the array of compiler-assigned + Tcl_Size frameIndex; /* Index in the array of compiler-assigned * variables in the procedure call frame. */ #if TCL_UTF_MAX < 9 int flags; @@ -966,7 +970,7 @@ typedef struct CompiledLocal { typedef struct Proc { struct Interp *iPtr; /* Interpreter for which this command is * defined. */ - size_t refCount; /* Reference count: 1 if still present in + TCL_HASH_TYPE refCount; /* Reference count: 1 if still present in * command table plus 1 for each call to the * procedure that is currently active. This * structure can be freed when refCount @@ -977,8 +981,8 @@ typedef struct Proc { * procedure. */ Tcl_Obj *bodyPtr; /* Points to the ByteCode object for * procedure's body command. */ - size_t numArgs; /* Number of formal parameters. */ - size_t numCompiledLocals; /* Count of local variables recognized by the + Tcl_Size numArgs; /* Number of formal parameters. */ + Tcl_Size numCompiledLocals; /* Count of local variables recognized by the * compiler including arguments and * temporaries. */ CompiledLocal *firstLocalPtr; @@ -1083,8 +1087,8 @@ typedef struct AssocData { */ typedef struct LocalCache { - size_t refCount; - size_t numVars; + TCL_HASH_TYPE refCount; + Tcl_Size numVars; Tcl_Obj *varName0; } LocalCache; @@ -1104,7 +1108,7 @@ typedef struct CallFrame { * If FRAME_IS_PROC is set, the frame was * pushed to execute a Tcl procedure and may * have local vars. */ - size_t objc; /* This and objv below describe the arguments + Tcl_Size objc; /* This and objv below describe the arguments * for this procedure call. */ Tcl_Obj *const *objv; /* Array of argument objects. */ struct CallFrame *callerPtr; @@ -1118,7 +1122,7 @@ typedef struct CallFrame { * callerPtr unless an "uplevel" command or * something equivalent was active in the * caller). */ - size_t level; /* Level of this procedure, for "uplevel" + Tcl_Size level; /* Level of this procedure, for "uplevel" * purposes (i.e. corresponds to nesting of * callerVarPtr's, not callerPtr's). 1 for * outermost procedure, 0 for top-level. */ @@ -1132,7 +1136,7 @@ typedef struct CallFrame { * recognized by the compiler, or created at * execution time through, e.g., upvar. * Initially NULL and created if needed. */ - size_t numCompiledLocals; /* Count of local variables recognized + Tcl_Size numCompiledLocals; /* Count of local variables recognized * by the compiler including arguments. */ Var *compiledLocals; /* Points to the array of local variables * recognized by the compiler. The compiler @@ -1194,7 +1198,7 @@ typedef struct CmdFrame { int level; /* Number of frames in stack, prevent O(n) * scan of list. */ int *line; /* Lines the words of the command start on. */ - size_t nline; + Tcl_Size nline; CallFrame *framePtr; /* Procedure activation record, may be * NULL. */ struct CmdFrame *nextPtr; /* Link to calling frame. */ @@ -1238,7 +1242,7 @@ typedef struct CmdFrame { } data; Tcl_Obj *cmdObj; const char *cmd; /* The executed command, if possible... */ - size_t len; /* ... and its length. */ + Tcl_Size len; /* ... and its length. */ const struct CFWordBC *litarg; /* Link to set of literal arguments which have * ben pushed on the lineLABCPtr stack by @@ -1248,16 +1252,16 @@ typedef struct CmdFrame { typedef struct CFWord { CmdFrame *framePtr; /* CmdFrame to access. */ - size_t word; /* Index of the word in the command. */ - size_t refCount; /* Number of times the word is on the + Tcl_Size word; /* Index of the word in the command. */ + TCL_HASH_TYPE refCount; /* Number of times the word is on the * stack. */ } CFWord; typedef struct CFWordBC { CmdFrame *framePtr; /* CmdFrame to access. */ - size_t pc; /* Instruction pointer of a command in + Tcl_Size pc; /* Instruction pointer of a command in * ExtCmdLoc.loc[.] */ - size_t word; /* Index of word in + Tcl_Size word; /* Index of word in * ExtCmdLoc.loc[cmd]->line[.] */ struct CFWordBC *prevPtr; /* Previous entry in stack for same Tcl_Obj. */ struct CFWordBC *nextPtr; /* Next entry for same command call. See @@ -1286,7 +1290,7 @@ typedef struct CFWordBC { #define CLL_END (-1) typedef struct ContLineLoc { - size_t num; /* Number of entries in loc, not counting the + Tcl_Size num; /* Number of entries in loc, not counting the * final -1 marker entry. */ int loc[TCLFLEXARRAY];/* Table of locations, as character offsets. * The table is allocated as part of the @@ -1336,7 +1340,7 @@ typedef struct { * proc field is NULL. */ } ExtraFrameInfoField; typedef struct { - size_t length; /* Length of array. */ + Tcl_Size length; /* Length of array. */ ExtraFrameInfoField fields[2]; /* Really as long as necessary, but this is * long enough for nearly anything. */ @@ -1467,11 +1471,11 @@ typedef struct CoroutineData { CorContext running; Tcl_HashTable *lineLABCPtr; /* See Interp.lineLABCPtr */ void *stackLevel; - size_t auxNumLevels; /* While the coroutine is running the + Tcl_Size auxNumLevels; /* While the coroutine is running the * numLevels of the create/resume command is * stored here; for suspended coroutines it * holds the nesting numLevels at yield. */ - size_t nargs; /* Number of args required for resuming this + Tcl_Size nargs; /* Number of args required for resuming this * coroutine; COROUTINE_ARGUMENTS_SINGLE_OPTIONAL means "0 or 1" * (default), COROUTINE_ARGUMENTS_ARBITRARY means "any" */ Tcl_Obj *yieldPtr; /* The command to yield to. Stored here in @@ -1517,7 +1521,7 @@ typedef struct LiteralEntry { * NULL if end of chain. */ Tcl_Obj *objPtr; /* Points to Tcl object that holds the * literal's bytes and length. */ - size_t refCount; /* If in an interpreter's global literal + TCL_HASH_TYPE refCount; /* If in an interpreter's global literal * table, the number of ByteCode structures * that share the literal object; the literal * entry can be freed when refCount drops to @@ -1535,13 +1539,13 @@ typedef struct LiteralTable { LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; /* Bucket array used for small tables to avoid * mallocs and frees. */ - size_t numBuckets; /* Total number of buckets allocated at + TCL_HASH_TYPE numBuckets; /* Total number of buckets allocated at * **buckets. */ - size_t numEntries; /* Total number of entries present in + TCL_HASH_TYPE numEntries; /* Total number of entries present in * table. */ - size_t rebuildSize; /* Enlarge table when numEntries gets to be + TCL_HASH_TYPE rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ - size_t mask; /* Mask value used in hashing function. */ + TCL_HASH_TYPE mask; /* Mask value used in hashing function. */ } LiteralTable; /* @@ -1659,12 +1663,12 @@ typedef struct Command { * recreated). */ Namespace *nsPtr; /* Points to the namespace containing this * command. */ - size_t refCount; /* 1 if in command hashtable plus 1 for each + TCL_HASH_TYPE refCount; /* 1 if in command hashtable plus 1 for each * reference from a CmdName Tcl object * representing a command's name in a ByteCode * instruction sequence. This structure can be * freed when refCount becomes zero. */ - size_t cmdEpoch; /* Incremented to invalidate any references + TCL_HASH_TYPE cmdEpoch; /* Incremented to invalidate any references * that point to this command when it is * renamed, deleted, hidden, or exposed. */ CompileProc *compileProc; /* Procedure called to compile command. NULL @@ -1836,18 +1840,22 @@ typedef struct Interp { void *interpInfo; /* Information used by tclInterp.c to keep * track of parent/child interps on a * per-interp basis. */ +#if TCL_MAJOR_VERSION > 8 void (*optimizer)(void *envPtr); +#else + Tcl_HashTable unused2; /* No longer used */ +#endif /* * Information related to procedures and variables. See tclProc.c and * tclVar.c for usage. */ - size_t numLevels; /* Keeps track of how many nested calls to + Tcl_Size numLevels; /* Keeps track of how many nested calls to * Tcl_Eval are in progress for this * interpreter. It's used to delay deletion of * the table until all Tcl_Eval invocations * are completed. */ - size_t maxNestingDepth; /* If numLevels exceeds this value then Tcl + Tcl_Size maxNestingDepth; /* If numLevels exceeds this value then Tcl * assumes that infinite recursion has * occurred and it generates an error. */ CallFrame *framePtr; /* Points to top-most in stack of all nested @@ -1866,6 +1874,17 @@ typedef struct Interp { * TCL_EVAL_INVOKE call to Tcl_EvalObjv. */ /* + * Information used by Tcl_AppendResult to keep track of partial results. + * See Tcl_AppendResult code for details. + */ + +#if TCL_MAJOR_VERSION < 9 + char *appendResultDontUse; + int appendAvlDontUse; + int appendUsedDontUse; +#endif + + /* * Information about packages. Used only in tclPkg.c. */ @@ -1881,18 +1900,21 @@ typedef struct Interp { * Miscellaneous information: */ - size_t cmdCount; /* Total number of times a command procedure + Tcl_Size cmdCount; /* Total number of times a command procedure * has been called for this interpreter. */ int evalFlags; /* Flags to control next call to Tcl_Eval. * Normally zero, but may be set before * calling Tcl_Eval. See below for valid * values. */ +#if TCL_MAJOR_VERSION < 9 + int unused1; /* No longer used (was termOffset) */ +#endif LiteralTable literalTable; /* Contains LiteralEntry's describing all Tcl * objects holding literals of scripts * compiled by the interpreter. Indexed by the * string representations of literals. Used to * avoid creating duplicate objects. */ - size_t compileEpoch; /* Holds the current "compilation epoch" for + TCL_HASH_TYPE compileEpoch; /* Holds the current "compilation epoch" for * this interpreter. This is incremented to * invalidate existing ByteCodes when, e.g., a * command with a compile procedure is @@ -1924,6 +1946,9 @@ typedef struct Interp { * string. Returned by Tcl_ObjSetVar2 when * variable traces change a variable in a * gross way. */ +#if TCL_MAJOR_VERSION < 9 + char resultSpaceDontUse[TCL_DSTRING_STATIC_SIZE+1]; +#endif Tcl_Obj *objResultPtr; /* If the last command returned an object * result, this points to it. Should not be * accessed directly; see comment above. */ @@ -1936,7 +1961,7 @@ typedef struct Interp { /* First in list of active traces for interp, * or NULL if no active traces. */ - size_t tracesForbiddingInline; /* Count of traces (in the list headed by + Tcl_Size tracesForbiddingInline; /* Count of traces (in the list headed by * tracePtr) that forbid inline bytecode * compilation. */ @@ -1966,7 +1991,7 @@ typedef struct Interp { * as flag values the same as the 'active' * field. */ - size_t cmdCount; /* Limit for how many commands to execute in + Tcl_Size cmdCount; /* Limit for how many commands to execute in * the interpreter. */ LimitHandler *cmdHandlers; /* Handlers to execute when the limit is @@ -2002,9 +2027,9 @@ typedef struct Interp { * *root* ensemble command? (Nested ensembles * don't rewrite this.) NULL if we're not * processing an ensemble. */ - size_t numRemovedObjs; /* How many arguments have been stripped off + Tcl_Size numRemovedObjs; /* How many arguments have been stripped off * because of ensemble processing. */ - size_t numInsertedObjs; /* How many of the current arguments were + Tcl_Size numInsertedObjs; /* How many of the current arguments were * inserted by an ensemble. */ } ensembleRewrite; @@ -2374,9 +2399,9 @@ typedef enum TclEolTranslation { */ typedef struct List { - size_t refCount; - size_t maxElemCount; /* Total number of element array slots. */ - size_t elemCount; /* Current number of list elements. */ + TCL_HASH_TYPE refCount; + Tcl_Size maxElemCount; /* Total number of element array slots. */ + Tcl_Size elemCount; /* Current number of list elements. */ int canonicalFlag; /* Set if the string representation was * derived from the list representation. May * be ignored if there is no string rep at @@ -2464,8 +2489,8 @@ typedef struct List { : Tcl_GetIntFromObj((interp), (objPtr), (intPtr))) #define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \ ((((objPtr)->typePtr == &tclIntType) && ((objPtr)->internalRep.wideValue >= 0) \ - && ((Tcl_WideUInt)(objPtr)->internalRep.wideValue <= (size_t)(endValue) + 1)) \ - ? ((*(idxPtr) = (size_t)(objPtr)->internalRep.wideValue), TCL_OK) \ + && ((Tcl_WideUInt)(objPtr)->internalRep.wideValue <= (Tcl_WideUInt)(endValue + 1))) \ + ? ((*(idxPtr) = (Tcl_Size)(objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) /* @@ -2586,7 +2611,7 @@ typedef Tcl_Channel (TclOpenFileChannelProc_)(Tcl_Interp *interp, *---------------------------------------------------------------- */ -typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, size_t *lengthPtr, +typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr); /* @@ -2598,9 +2623,9 @@ typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, size_t *lengthPtr, */ typedef struct ProcessGlobalValue { - size_t epoch; /* Epoch counter to detect changes in the + TCL_HASH_TYPE epoch; /* Epoch counter to detect changes in the * global value. */ - size_t numBytes; /* Length of the global string. */ + TCL_HASH_TYPE numBytes; /* Length of the global string. */ char *value; /* The global string value. */ Tcl_Encoding encoding; /* system encoding when global string was * initialized. */ @@ -2780,7 +2805,7 @@ typedef struct ForIterData { Tcl_Obj *body; /* Loop body. */ Tcl_Obj *next; /* Loop step script, NULL for 'while'. */ const char *msg; /* Error message part. */ - size_t word; /* Index of the body script in the command */ + Tcl_Size word; /* Index of the body script in the command */ } ForIterData; /* TIP #357 - Structure doing the bookkeeping of handles for Tcl_LoadFile @@ -2825,12 +2850,12 @@ struct Tcl_LoadHandle_ { */ MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, - const unsigned char *bytes, size_t len); + const unsigned char *bytes, Tcl_Size len); MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); -MODULE_SCOPE void TclAdvanceContinuations(size_t *line, int **next, +MODULE_SCOPE void TclAdvanceContinuations(Tcl_Size *line, int **next, int loc); -MODULE_SCOPE void TclAdvanceLines(size_t *line, const char *start, +MODULE_SCOPE void TclAdvanceLines(Tcl_Size *line, const char *start, const char *end); MODULE_SCOPE void TclArgumentEnter(Tcl_Interp *interp, Tcl_Obj *objv[], int objc, CmdFrame *cf); @@ -2838,18 +2863,18 @@ MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp, Tcl_Obj *objv[], int objc); MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp, Tcl_Obj *objv[], int objc, - void *codePtr, CmdFrame *cfPtr, int cmd, size_t pc); + void *codePtr, CmdFrame *cfPtr, int cmd, Tcl_Size pc); MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, CmdFrame *cfPtr); MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, CmdFrame **cfPtrPtr, int *wordPtr); MODULE_SCOPE int TclAsyncNotifier(int sigNumber, Tcl_ThreadId threadId, - ClientData clientData, int *flagPtr, int value); + void *clientData, int *flagPtr, int value); MODULE_SCOPE void TclAsyncMarkFromNotifier(void); MODULE_SCOPE double TclBignumToDouble(const void *bignum); MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, - size_t strLen, const unsigned char *pattern, - size_t ptnLen, int flags); + Tcl_Size strLen, const unsigned char *pattern, + Tcl_Size ptnLen, int flags); MODULE_SCOPE double TclCeil(const void *a); MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan); MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan); @@ -2862,14 +2887,14 @@ MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); -MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, size_t num, +MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, Tcl_Size num, int *loc); MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, int start, int *clNext); MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr); MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr, Tcl_Obj *originObjPtr); -MODULE_SCOPE size_t TclConvertElement(const char *src, size_t length, +MODULE_SCOPE Tcl_Size TclConvertElement(const char *src, Tcl_Size length, char *dst, int flags); MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs(Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *nsPtr, @@ -2881,12 +2906,12 @@ MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp, MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE void TclDeleteNamespaceChildren(Namespace *nsPtr); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, - const char *dict, size_t dictLength, + const char *dict, Tcl_Size dictLength, const char **elementPtr, const char **nextPtr, - size_t *sizePtr, int *literalPtr); + Tcl_Size *sizePtr, int *literalPtr); /* TIP #280 - Modified token based evaluation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, - size_t numBytes, int flags, size_t line, + Tcl_Size numBytes, int flags, Tcl_Size line, int *clNextOuter, const char *outerScript); MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd; @@ -2907,7 +2932,7 @@ MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, Tcl_DString *toAppendPtr); MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp, - Tcl_Obj *const *objv, size_t objc, size_t *objcPtr); + Tcl_Obj *const *objv, Tcl_Size objc, Tcl_Size *objcPtr); MODULE_SCOPE Tcl_Obj *const *TclEnsembleGetRewriteValues(Tcl_Interp *interp); MODULE_SCOPE Tcl_Namespace *TclEnsureNamespace(Tcl_Interp *interp, Tcl_Namespace *namespacePtr); @@ -2965,7 +2990,7 @@ MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, - size_t *sizePtr); + TCL_HASH_TYPE *sizePtr); MODULE_SCOPE int TclGetLoadedLibraries(Tcl_Interp *interp, const char *targetName, const char *packageName); @@ -3003,28 +3028,28 @@ MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); MODULE_SCOPE int TclIsDigitProc(int byte); MODULE_SCOPE int TclIsBareword(int byte); -MODULE_SCOPE Tcl_Obj * TclJoinPath(size_t elements, Tcl_Obj * const objv[], +MODULE_SCOPE Tcl_Obj * TclJoinPath(Tcl_Size elements, Tcl_Obj * const objv[], int forceRelative); MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *argPtr); MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, - size_t indexCount, Tcl_Obj *const indexArray[]); + Tcl_Size indexCount, Tcl_Obj *const indexArray[]); /* TIP #280 */ -MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, size_t line, int n, +MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, Tcl_Size line, int n, int *lines, Tcl_Obj *const *elems); MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); -MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Obj *listPtr, size_t fromIdx, - size_t toIdx); +MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Obj *listPtr, Tcl_Size fromIdx, + Tcl_Size toIdx); MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *indexPtr, Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, - size_t indexCount, Tcl_Obj *const indexArray[], + Tcl_Size indexCount, Tcl_Obj *const indexArray[], Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name, const EnsembleImplMap map[]); -MODULE_SCOPE int TclMaxListLength(const char *bytes, size_t numBytes, +MODULE_SCOPE int TclMaxListLength(const char *bytes, Tcl_Size numBytes, const char **endPtr); MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, @@ -3043,15 +3068,15 @@ MODULE_SCOPE int TclObjInvokeNamespace(Tcl_Interp *interp, MODULE_SCOPE int TclObjUnsetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); MODULE_SCOPE int TclParseBackslash(const char *src, - size_t numBytes, size_t *readPtr, char *dst); -MODULE_SCOPE int TclParseHex(const char *src, size_t numBytes, + Tcl_Size numBytes, Tcl_Size *readPtr, char *dst); +MODULE_SCOPE int TclParseHex(const char *src, Tcl_Size numBytes, int *resultPtr); MODULE_SCOPE int TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *expected, const char *bytes, - size_t numBytes, const char **endPtrPtr, int flags); + Tcl_Size numBytes, const char **endPtrPtr, int flags); MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string, - size_t numBytes, Tcl_Parse *parsePtr); -MODULE_SCOPE size_t TclParseAllWhiteSpace(const char *src, size_t numBytes); + Tcl_Size numBytes, Tcl_Parse *parsePtr); +MODULE_SCOPE Tcl_Size TclParseAllWhiteSpace(const char *src, Tcl_Size numBytes); MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); @@ -3059,19 +3084,19 @@ MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, - size_t len); -MODULE_SCOPE void TclpAlertNotifier(ClientData clientData); + Tcl_Size len); +MODULE_SCOPE void TclpAlertNotifier(void *clientData); MODULE_SCOPE ClientData TclpNotifierData(void); MODULE_SCOPE void TclpServiceModeHook(int mode); MODULE_SCOPE void TclpSetTimer(const Tcl_Time *timePtr); MODULE_SCOPE int TclpWaitForEvent(const Tcl_Time *timePtr); MODULE_SCOPE void TclpCreateFileHandler(int fd, int mask, - Tcl_FileProc *proc, ClientData clientData); + Tcl_FileProc *proc, void *clientData); MODULE_SCOPE int TclpDeleteFile(const void *path); MODULE_SCOPE void TclpDeleteFileHandler(int fd); MODULE_SCOPE void TclpFinalizeCondition(Tcl_Condition *condPtr); MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); -MODULE_SCOPE void TclpFinalizeNotifier(ClientData clientData); +MODULE_SCOPE void TclpFinalizeNotifier(void *clientData); MODULE_SCOPE void TclpFinalizePipes(void); MODULE_SCOPE void TclpFinalizeSockets(void); MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, @@ -3080,10 +3105,10 @@ MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, const char **errorMsgPtr); MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, - size_t stackSize, int flags); -MODULE_SCOPE size_t TclpFindVariable(const char *name, size_t *lengthPtr); + Tcl_Size stackSize, int flags); +MODULE_SCOPE Tcl_Size TclpFindVariable(const char *name, Tcl_Size *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, - size_t *lengthPtr, Tcl_Encoding *encodingPtr); + TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE ClientData TclpInitNotifier(void); MODULE_SCOPE void TclpInitPlatform(void); @@ -3096,9 +3121,9 @@ MODULE_SCOPE int TclpMatchFiles(Tcl_Interp *interp, char *separators, MODULE_SCOPE int TclpObjNormalizePath(Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint); MODULE_SCOPE void TclpNativeJoinPath(Tcl_Obj *prefix, const char *joining); -MODULE_SCOPE Tcl_Obj * TclpNativeSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr); +MODULE_SCOPE Tcl_Obj * TclpNativeSplitPath(Tcl_Obj *pathPtr, Tcl_Size *lenPtr); MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr, - size_t *driveNameLengthPtr, Tcl_Obj **driveNameRef); + Tcl_Size *driveNameLengthPtr, Tcl_Obj **driveNameRef); MODULE_SCOPE int TclCrossFilesystemCopy(Tcl_Interp *interp, Tcl_Obj *source, Tcl_Obj *target); MODULE_SCOPE int TclpMatchInDirectory(Tcl_Interp *interp, @@ -3129,9 +3154,9 @@ MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id); MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex); MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, - size_t reStrLen, Tcl_DString *dsPtr, int *flagsPtr, + Tcl_Size reStrLen, Tcl_DString *dsPtr, int *flagsPtr, int *quantifiersFoundPtr); -MODULE_SCOPE size_t TclScanElement(const char *string, size_t length, +MODULE_SCOPE Tcl_Size TclScanElement(const char *string, Tcl_Size length, char *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); @@ -3146,44 +3171,44 @@ MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue, Tcl_Encoding encoding); MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, - Tcl_Obj *const *objv, size_t objc, size_t subIdx, + Tcl_Obj *const *objv, Tcl_Size objc, Tcl_Size subIdx, Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, - size_t numBytes); + Tcl_Size numBytes); typedef int (*memCmpFn_t)(const void*, const void*, size_t); MODULE_SCOPE int TclStringCmp(Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr, - int checkEq, int nocase, size_t reqlength); + int checkEq, int nocase, Tcl_Size reqlength); MODULE_SCOPE int TclStringCmpOpts(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int *nocase, int *reqlength); -MODULE_SCOPE int TclStringMatch(const char *str, size_t strLen, +MODULE_SCOPE int TclStringMatch(const char *str, Tcl_Size strLen, const char *pattern, int ptnLen, int flags); MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, Tcl_Obj *patternObj, int flags); MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes, - size_t numBytes, int flags, size_t line, + Tcl_Size numBytes, int flags, Tcl_Size line, struct CompileEnv *envPtr); -MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, size_t numOpts, +MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, Tcl_Size numOpts, Tcl_Obj *const opts[], int *flagPtr); MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes, - size_t numBytes, int flags, Tcl_Parse *parsePtr, + Tcl_Size numBytes, int flags, Tcl_Parse *parsePtr, Tcl_InterpState *statePtr); MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, - size_t count, int *tokensLeftPtr, size_t line, + Tcl_Size count, int *tokensLeftPtr, Tcl_Size line, int *clNextOuter, const char *outerScript); -MODULE_SCOPE size_t TclTrim(const char *bytes, size_t numBytes, - const char *trim, size_t numTrim, size_t *trimRight); -MODULE_SCOPE size_t TclTrimLeft(const char *bytes, size_t numBytes, - const char *trim, size_t numTrim); -MODULE_SCOPE size_t TclTrimRight(const char *bytes, size_t numBytes, - const char *trim, size_t numTrim); +MODULE_SCOPE Tcl_Size TclTrim(const char *bytes, Tcl_Size numBytes, + const char *trim, Tcl_Size numTrim, Tcl_Size *trimRight); +MODULE_SCOPE Tcl_Size TclTrimLeft(const char *bytes, Tcl_Size numBytes, + const char *trim, Tcl_Size numTrim); +MODULE_SCOPE Tcl_Size TclTrimRight(const char *bytes, Tcl_Size numBytes, + const char *trim, Tcl_Size numTrim); MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command); MODULE_SCOPE void TclRegisterCommandTypeName( Tcl_ObjCmdProc *implementationProc, const char *nameStr); MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); -MODULE_SCOPE size_t TclUtfCount(int ch); +MODULE_SCOPE Tcl_Size TclUtfCount(int ch); #if TCL_UTF_MAX > 3 # define TclUtfToUCS4 Tcl_UtfToUniChar # define TclUniCharToUCS4(src, ptr) (*ptr = *(src),1) @@ -3230,7 +3255,7 @@ MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); MODULE_SCOPE void TclpThreadSetGlobalTSD(void *tsdKeyPtr, void *ptr); MODULE_SCOPE void * TclpThreadGetGlobalTSD(void *tsdKeyPtr); MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, - const char *msg, size_t length); + const char *msg, Tcl_Size length); /* Tip 430 */ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); @@ -3307,7 +3332,7 @@ MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, Tcl_Obj *part2Ptr, int index, int pathc, Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, - size_t pathc, Tcl_Obj *const pathv[]); + Tcl_Size pathc, Tcl_Obj *const pathv[]); MODULE_SCOPE int Tcl_DisassembleObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -4014,13 +4039,13 @@ MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, MODULE_SCOPE Tcl_Obj * TclStringCat(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); MODULE_SCOPE Tcl_Obj * TclStringFirst(Tcl_Obj *needle, Tcl_Obj *haystack, - size_t start); + Tcl_Size start); MODULE_SCOPE Tcl_Obj * TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack, - size_t last); + Tcl_Size last); MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr, - size_t count, int flags); + Tcl_Size count, int flags); MODULE_SCOPE Tcl_Obj * TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr, - size_t first, size_t count, Tcl_Obj *insertPtr, + Tcl_Size first, Tcl_Size count, Tcl_Obj *insertPtr, int flags); MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr, int flags); @@ -4147,12 +4172,12 @@ MODULE_SCOPE Tcl_Obj * TclGetArrayDefault(Var *arrayPtr); */ MODULE_SCOPE int TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr, - size_t before, size_t after, int *indexPtr); -MODULE_SCOPE size_t TclIndexDecode(int encoded, size_t endValue); + Tcl_Size before, Tcl_Size after, int *indexPtr); +MODULE_SCOPE Tcl_Size TclIndexDecode(int encoded, Tcl_Size endValue); /* Constants used in index value encoding routines. */ -#define TCL_INDEX_END ((size_t)-2) -#define TCL_INDEX_START ((size_t)0) +#define TCL_INDEX_END ((Tcl_Size)-2) +#define TCL_INDEX_START ((Tcl_Size)0) /* *---------------------------------------------------------------------- @@ -4625,8 +4650,8 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; : Tcl_UtfToUniChar(str, chPtr)) #else #define TclUtfToUniChar(str, chPtr) \ - ((((unsigned char) *(str)) < 0x80) ? \ - ((*(chPtr) = (unsigned char) *(str)), 1) \ + (((UCHAR(*(str))) < 0x80) ? \ + ((*(chPtr) = UCHAR(*(str))), 1) \ : Tcl_UtfToChar16(str, chPtr)) #endif @@ -4785,7 +4810,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; * * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d); - * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, size_t len); + * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, Tcl_Size len); * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral); * *---------------------------------------------------------------- diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index d71f355..425a03c 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -87,14 +87,14 @@ EXTERN void TclExprFloatError(Tcl_Interp *interp, double value); /* Slot 21 is reserved */ /* 22 */ EXTERN int TclFindElement(Tcl_Interp *interp, - const char *listStr, int listLength, + const char *listStr, Tcl_Size listLength, const char **elementPtr, const char **nextPtr, Tcl_Size *sizePtr, int *bracePtr); /* 23 */ EXTERN Proc * TclFindProc(Interp *iPtr, const char *procName); /* 24 */ -EXTERN size_t TclFormatInt(char *buffer, Tcl_WideInt n); +EXTERN Tcl_Size TclFormatInt(char *buffer, Tcl_WideInt n); /* 25 */ EXTERN void TclFreePackageInfo(Interp *iPtr); /* Slot 26 is reserved */ @@ -603,9 +603,9 @@ typedef struct TclIntStubs { void (*reserved19)(void); void (*reserved20)(void); void (*reserved21)(void); - int (*tclFindElement) (Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, Tcl_Size *sizePtr, int *bracePtr); /* 22 */ + int (*tclFindElement) (Tcl_Interp *interp, const char *listStr, Tcl_Size listLength, const char **elementPtr, const char **nextPtr, Tcl_Size *sizePtr, int *bracePtr); /* 22 */ Proc * (*tclFindProc) (Interp *iPtr, const char *procName); /* 23 */ - size_t (*tclFormatInt) (char *buffer, Tcl_WideInt n); /* 24 */ + Tcl_Size (*tclFormatInt) (char *buffer, Tcl_WideInt n); /* 24 */ void (*tclFreePackageInfo) (Interp *iPtr); /* 25 */ void (*reserved26)(void); void (*reserved27)(void); diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 17a9dfe..4593057 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -493,7 +493,7 @@ TclFindElement( const char *list, /* Points to the first byte of a string * containing a Tcl list with zero or more * elements (possibly in braces). */ - int listLength, /* Number of bytes in the list's string. */ + size_t listLength, /* Number of bytes in the list's string. */ const char **elementPtr, /* Where to put address of first significant * character in first element of list. */ const char **nextPtr, /* Fill in with location of character just -- cgit v0.12 From 26e99bad85be55cb8f27649867fdcebfd92d424b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Jun 2022 21:47:26 +0000 Subject: Fix (internal) TclFindElement() signature (int -> size_t) --- generic/tclInt.decls | 2 +- generic/tclIntDecls.h | 4 ++-- generic/tclUtil.c | 18 ++++++++---------- 3 files changed, 11 insertions(+), 13 deletions(-) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 9a92888..4c05de8 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -62,7 +62,7 @@ declare 16 { } declare 22 { int TclFindElement(Tcl_Interp *interp, const char *listStr, - int listLength, const char **elementPtr, const char **nextPtr, + size_t listLength, const char **elementPtr, const char **nextPtr, size_t *sizePtr, int *bracePtr) } declare 23 { diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index d3c05d5..9393c96 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -87,7 +87,7 @@ EXTERN void TclExprFloatError(Tcl_Interp *interp, double value); /* Slot 21 is reserved */ /* 22 */ EXTERN int TclFindElement(Tcl_Interp *interp, - const char *listStr, int listLength, + const char *listStr, size_t listLength, const char **elementPtr, const char **nextPtr, size_t *sizePtr, int *bracePtr); @@ -603,7 +603,7 @@ typedef struct TclIntStubs { void (*reserved19)(void); void (*reserved20)(void); void (*reserved21)(void); - int (*tclFindElement) (Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, size_t *sizePtr, int *bracePtr); /* 22 */ + int (*tclFindElement) (Tcl_Interp *interp, const char *listStr, size_t listLength, const char **elementPtr, const char **nextPtr, size_t *sizePtr, int *bracePtr); /* 22 */ Proc * (*tclFindProc) (Interp *iPtr, const char *procName); /* 23 */ size_t (*tclFormatInt) (char *buffer, Tcl_WideInt n); /* 24 */ void (*tclFreePackageInfo) (Interp *iPtr); /* 25 */ diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 17a9dfe..43a24f7 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -493,7 +493,7 @@ TclFindElement( const char *list, /* Points to the first byte of a string * containing a Tcl list with zero or more * elements (possibly in braces). */ - int listLength, /* Number of bytes in the list's string. */ + size_t listLength, /* Number of bytes in the list's string. */ const char **elementPtr, /* Where to put address of first significant * character in first element of list. */ const char **nextPtr, /* Fill in with location of character just @@ -550,7 +550,7 @@ FindElement( * containing a Tcl list or dictionary with * zero or more elements (possibly in * braces). */ - size_t stringLength1, /* Number of bytes in the string. */ + size_t stringLength, /* Number of bytes in the string. */ const char *typeStr, /* The name of the type of thing we are * parsing, for error messages. */ const char *typeCode, /* The type code for thing we are parsing, for @@ -572,13 +572,12 @@ FindElement( const char *p = string; const char *elemStart; /* Points to first byte of first element. */ const char *limit; /* Points just after list/dict's last byte. */ - int openBraces = 0; /* Brace nesting level during parse. */ + size_t openBraces = 0; /* Brace nesting level during parse. */ int inQuotes = 0; - int size = 0; + size_t size = 0; size_t numChars; int literal = 1; const char *p2; - int stringLength = stringLength1; /* * Skim off leading white space and check for an opening brace or quote. @@ -976,7 +975,7 @@ Tcl_ScanCountedElement( * Tcl_ConvertElement. */ { char flags = CONVERT_ANY; - int numBytes = TclScanElement(src, length, &flags); + size_t numBytes = TclScanElement(src, length, &flags); *flagPtr = flags; return numBytes; @@ -1020,7 +1019,7 @@ TclScanElement( * Tcl_ConvertElement. */ { const char *p = src; - int nestingLevel = 0; /* Brace nesting count */ + size_t nestingLevel = 0; /* Brace nesting count */ int forbidNone = 0; /* Do not permit CONVERT_NONE mode. Something * needs protection or escape. */ int requireEscape = 0; /* Force use of CONVERT_ESCAPE mode. For some @@ -1089,8 +1088,7 @@ TclScanElement( braceCount++; #endif /* COMPAT */ extra++; /* Escape '}' => '\}' */ - nestingLevel--; - if (nestingLevel < 0) { + if (nestingLevel-- < 1) { /* * Unbalanced braces! Cannot format with brace quoting. */ @@ -1171,7 +1169,7 @@ TclScanElement( } endOfString: - if (nestingLevel != 0) { + if (nestingLevel > 0) { /* * Unbalanced braces! Cannot format with brace quoting. */ -- cgit v0.12 From daf02b80ddf417691daacbfc8e1c926b16ea8b18 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 22 Jun 2022 14:24:51 +0000 Subject: No quotes when testing for TCL_MAJOR_VERSION --- win/rules.vc | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/win/rules.vc b/win/rules.vc index 1b8df9c..16551d5 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1162,8 +1162,7 @@ TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX:t=).exe TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX:t=).exe !endif - -!if "$(TCL_MAJOR_VERSION)" == "8" +!if $(TCL_MAJOR_VERSION) == 8 TCLSTUBLIB = $(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib !else TCLSTUBLIB = $(_TCLDIR)\lib\tclstub.lib @@ -1187,7 +1186,7 @@ TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX:t=).exe !if !exist($(TCLSH)) TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX:t=).exe !endif -!if "$(TCL_MAJOR_VERSION)" == "8" +!if $(TCL_MAJOR_VERSION) == 8 TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib !else TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub.lib @@ -1427,7 +1426,7 @@ OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1 !endif -!if "$(TCL_MAJOR_VERSION)" == "8" +!if $(TCL_MAJOR_VERSION) == 8 !if "$(_USE_64BIT_TIME_T)" == "1" OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T=1 !endif -- cgit v0.12 From 5ea6733979199c89c9ad45cd247fdf1874a529c0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 22 Jun 2022 22:25:44 +0000 Subject: Forget about TCL_8_COMPAT --- generic/tcl.h | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 6c1ebf4..26ebe90 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -50,7 +50,7 @@ extern "C" { #if !defined(TCL_MAJOR_VERSION) # define TCL_MAJOR_VERSION 9 #endif -#if (TCL_MAJOR_VERSION == 9) +#if TCL_MAJOR_VERSION == 9 # define TCL_MINOR_VERSION 0 # define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE # define TCL_RELEASE_SERIAL 4 @@ -673,15 +673,10 @@ typedef union Tcl_ObjInternalRep { /* The internal representation: */ * An object stores a value as either a string, some internal representation, * or both. */ -#if TCL_MAJOR_VERSION < 9 -# define Tcl_Size int -#elif defined(TCL_8_COMPAT) -# ifdef BUILD_tcl -# error "TCL_8_COMPAT not supported when building Tcl" -# endif -# define Tcl_Size ptrdiff_t -#else +#if TCL_MAJOR_VERSION > 8 # define Tcl_Size size_t +#else +# define Tcl_Size int #endif -- cgit v0.12 From 6ebde0d07536315b422d5dbad8d2dd66d8500ead Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 Jun 2022 13:07:16 +0000 Subject: Better tcl8 compatibility for tclInt.h --- generic/tclInt.h | 27 +++++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 3f5f57c..af61507 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1844,7 +1844,14 @@ typedef struct Interp { #if TCL_MAJOR_VERSION > 8 void (*optimizer)(void *envPtr); #else - Tcl_HashTable unused2; /* No longer used */ + union { + void (*optimizer)(void *envPtr); + Tcl_HashTable unused2; /* No longer used (was mathFuncTable). The + * unused space in interp was repurposed for + * pluggable bytecode optimizers. The core + * contains one optimizer, which can be + * selectively overridden by extensions. */ + } extra; #endif /* * Information related to procedures and variables. See tclProc.c and @@ -2462,11 +2469,20 @@ typedef struct List { * WARNING: these macros eval their args more than once. */ +#if TCL_MAJOR_VERSION > 8 #define TclGetBooleanFromObj(interp, objPtr, intPtr) \ (((objPtr)->typePtr == &tclIntType \ || (objPtr)->typePtr == &tclBooleanType) \ ? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ : Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr))) +#else +#define TclGetBooleanFromObj(interp, objPtr, intPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ + : ((objPtr)->typePtr == &tclBooleanType) \ + ? (*(intPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ + : Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr))) +#endif #ifdef TCL_WIDE_INT_IS_LONG #define TclGetLongFromObj(interp, objPtr, longPtr) \ @@ -2491,7 +2507,7 @@ typedef struct List { #define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \ ((((objPtr)->typePtr == &tclIntType) && ((objPtr)->internalRep.wideValue >= 0) \ && ((Tcl_WideUInt)(objPtr)->internalRep.wideValue <= (Tcl_WideUInt)(endValue + 1))) \ - ? ((*(idxPtr) = (Tcl_Size)(objPtr)->internalRep.wideValue), TCL_OK) \ + ? ((*(idxPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) /* @@ -2966,8 +2982,7 @@ MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs(Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *nsPtr, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, - void *clientData, - Tcl_CmdDeleteProc *deleteProc); + void *clientData, Tcl_CmdDeleteProc *deleteProc); MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *encodingName); MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle); @@ -4663,7 +4678,7 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; * of counting along a string of all one-byte characters. The ANSI C * "prototype" for this macro is: * - * MODULE_SCOPE void TclNumUtfCharsM(size_t numChars, const char *bytes, + * MODULE_SCOPE void TclNumUtfCharsM(int | size_t numChars, const char *bytes, * size_t numBytes); *---------------------------------------------------------------- */ @@ -4836,7 +4851,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ (objPtr)->bytes = NULL; \ - (objPtr)->internalRep.wideValue = ((_w) == TCL_INDEX_NONE) ? -1 : (Tcl_WideInt)(_w); \ + (objPtr)->internalRep.wideValue = ((size_t)(_w) == (size_t)TCL_INDEX_NONE) ? -1 : (Tcl_WideInt)(_w); \ (objPtr)->typePtr = &tclIntType; \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) -- cgit v0.12 From 5ad300bf4aa456914215c358584488170220f8d5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 Jun 2022 13:30:14 +0000 Subject: Use TCL_MAJOR_VERSION to document (kind of) what's the difference between Tcl8 and Tcl9 --- generic/tclInt.h | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 3ac2240..8d8c764 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -932,7 +932,7 @@ typedef struct CompiledLocal { * Among others used to speed up var lookups. */ size_t frameIndex; /* Index in the array of compiler-assigned * variables in the procedure call frame. */ -#if TCL_UTF_MAX < 9 +#if TCL_MAJOR_VERSION < 9 int flags; #endif Tcl_Obj *defValuePtr; /* Pointer to the default value of an @@ -945,7 +945,7 @@ typedef struct CompiledLocal { * is marked by a unique tag during * compilation, and that same tag is used to * find the variable at runtime. */ -#if TCL_UTF_MAX > 8 +#if TCL_MAJOR_VERSION > 8 int flags; /* Flag bits for the local variable. Same as * the flags for the Var structure above, * although only VAR_ARGUMENT, VAR_TEMPORARY, @@ -1866,6 +1866,12 @@ typedef struct Interp { Namespace *lookupNsPtr; /* Namespace to use ONLY on the next * TCL_EVAL_INVOKE call to Tcl_EvalObjv. */ +#if TCL_MAJOR_VERSION < 9 + char *appendResultDontUse; + int appendAvlDontUse; + int appendUsedDontUse; +#endif + /* * Information about packages. Used only in tclPkg.c. */ @@ -1888,6 +1894,9 @@ typedef struct Interp { * Normally zero, but may be set before * calling Tcl_Eval. See below for valid * values. */ +#if TCL_MAJOR_VERSION < 9 + int unused1; /* No longer used (was termOffset) */ +#endif LiteralTable literalTable; /* Contains LiteralEntry's describing all Tcl * objects holding literals of scripts * compiled by the interpreter. Indexed by the @@ -1925,6 +1934,9 @@ typedef struct Interp { * string. Returned by Tcl_ObjSetVar2 when * variable traces change a variable in a * gross way. */ +#if TCL_MAJOR_VERSION < 9 + char resultSpaceDontUse[TCL_DSTRING_STATIC_SIZE+1]; +#endif Tcl_Obj *objResultPtr; /* If the last command returned an object * result, this points to it. Should not be * accessed directly; see comment above. */ -- cgit v0.12 From b456ce6d74e9d801a105f103e737b9c4c523e0f7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 Jun 2022 14:44:08 +0000 Subject: Complete removal of version from stub library --- win/rules.vc | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/win/rules.vc b/win/rules.vc index 0067b25..4280b9b 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1146,7 +1146,11 @@ TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) TCLSCRIPTZIP = $(OUT_DIR)\$(TCLSCRIPTZIPNAME) +!if $(TCL_MAJOR_VERSION) == 8 TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib +!else +TCLSTUBLIBNAME = $(STUBPREFIX).lib +!endif TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) TCL_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" @@ -1290,7 +1294,11 @@ PRJLIBNAME = $(PRJLIBNAME9) !endif PRJLIB = $(OUT_DIR)\$(PRJLIBNAME) +!if $(TCL_MAJOR_VERSION) == 8 PRJSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib +!else +PRJSTUBLIBNAME = $(STUBPREFIX).lib +!endif PRJSTUBLIB = $(OUT_DIR)\$(PRJSTUBLIBNAME) # If extension parent makefile has not defined a resource definition file, -- cgit v0.12 From 9b6113c6b13629e4d525a98f201289c0ed42d143 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 26 Jun 2022 21:23:55 +0000 Subject: Better Tcl8 compatibility for tclPlatDecls.h and tclInt.h --- generic/tclInt.h | 4 +- generic/tclIntPlatDecls.h | 5 +++ generic/tclPlatDecls.h | 102 +++++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 109 insertions(+), 2 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 0c07e97..87f10f0 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -5115,7 +5115,9 @@ typedef struct NRE_callback { #endif #include "tclIntDecls.h" -#include "tclIntPlatDecls.h" +#if TCL_MAJOR_VERSION > 8 +# include "tclIntPlatDecls.h" +#endif #if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG) #define Tcl_AttemptAlloc TclpAlloc diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 0e51eef..2e032a3 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -13,6 +13,11 @@ #ifndef _TCLINTPLATDECLS #define _TCLINTPLATDECLS + +#if TCL_MAJOR_VERSION < 9 +#error "This header-file only works for Tcl 9" +#endif + #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl # define TCL_STORAGE_CLASS DLLEXPORT diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index bcaff5e..1c60bf8 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -48,6 +48,94 @@ # endif #endif +#if TCL_MAJOR_VERSION < 9 + +#ifdef __cplusplus +extern "C" { +#endif + +/* + * Exported function declarations: + */ + +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ +/* 0 */ +EXTERN TCHAR * Tcl_WinUtfToTChar(const char *str, int len, + Tcl_DString *dsPtr); +/* 1 */ +EXTERN char * Tcl_WinTCharToUtf(const TCHAR *str, int len, + Tcl_DString *dsPtr); +/* Slot 2 is reserved */ +/* 3 */ +EXTERN void Tcl_WinConvertError(unsigned errCode); +#endif /* WIN */ +#ifdef MAC_OSX_TCL /* MACOSX */ +/* 0 */ +EXTERN int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp, + const char *bundleName, int hasResourceFile, + int maxPathLen, char *libraryPath); +/* 1 */ +EXTERN int Tcl_MacOSXOpenVersionedBundleResources( + Tcl_Interp *interp, const char *bundleName, + const char *bundleVersion, + int hasResourceFile, int maxPathLen, + char *libraryPath); +/* 2 */ +EXTERN void Tcl_MacOSXNotifierAddRunLoopMode( + const void *runLoopMode); +#endif /* MACOSX */ + +typedef struct TclPlatStubs { + int magic; + void *hooks; + +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ + TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */ + char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */ + void (*reserved2)(void); + void (*tcl_WinConvertError) (unsigned errCode); /* 3 */ +#endif /* WIN */ +#ifdef MAC_OSX_TCL /* MACOSX */ + int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath); /* 0 */ + int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath); /* 1 */ + void (*tcl_MacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 2 */ +#endif /* MACOSX */ +} TclPlatStubs; + +extern const TclPlatStubs *tclPlatStubsPtr; + +#ifdef __cplusplus +} +#endif + +#if defined(USE_TCL_STUBS) + +/* + * Inline function declarations: + */ + +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ +#define Tcl_WinUtfToTChar \ + (tclPlatStubsPtr->tcl_WinUtfToTChar) /* 0 */ +#define Tcl_WinTCharToUtf \ + (tclPlatStubsPtr->tcl_WinTCharToUtf) /* 1 */ +/* Slot 2 is reserved */ +#define Tcl_WinConvertError \ + (tclPlatStubsPtr->tcl_WinConvertError) /* 3 */ +#endif /* WIN */ +#ifdef MAC_OSX_TCL /* MACOSX */ +#define Tcl_MacOSXOpenBundleResources \ + (tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */ +#define Tcl_MacOSXOpenVersionedBundleResources \ + (tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */ +#define Tcl_MacOSXNotifierAddRunLoopMode \ + (tclPlatStubsPtr->tcl_MacOSXNotifierAddRunLoopMode) /* 2 */ +#endif /* MACOSX */ + +#endif /* defined(USE_TCL_STUBS) */ + +#else /* TCL_MAJOR_VERSION > 8 */ + /* !BEGIN!: Do not edit below this line. */ #ifdef __cplusplus @@ -105,6 +193,13 @@ extern const TclPlatStubs *tclPlatStubsPtr; /* !END!: Do not edit above this line. */ +#endif /* TCL_MAJOR_VERSION */ + +#ifdef MAC_OSX_TCL /* MACOSX */ +#undef Tcl_MacOSXOpenBundleResources +#define Tcl_MacOSXOpenBundleResources(a,b,c,d,e) Tcl_MacOSXOpenVersionedBundleResources(a,b,NULL,c,d,e) +#endif + #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT @@ -118,11 +213,16 @@ extern const TclPlatStubs *tclPlatStubsPtr; # undef Tcl_MacOSXNotifierAddRunLoopMode #endif -#if defined(USE_TCL_STUBS) && defined(_WIN32) && !defined(TCL_NO_DEPRECATED) +#if defined(USE_TCL_STUBS) && (defined(_WIN32) || defined(__CYGWIN__))\ + && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8) +#undef Tcl_WinUtfToTChar +#undef Tcl_WinTCharToUtf +#ifdef _WIN32 #define Tcl_WinUtfToTChar(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \ (TCHAR *)Tcl_UtfToChar16DString((string), (len), (dsPtr))) #define Tcl_WinTCharToUtf(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \ (char *)Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr))) #endif +#endif #endif /* _TCLPLATDECLS */ -- cgit v0.12 From 7974d5f010f2cda4ccd9dcfb0186af3940b3750a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 26 Jun 2022 21:59:53 +0000 Subject: Fix TclpGetClicks/TclpGetSeconds's Tcl 8 compabitility --- generic/tclIntDecls.h | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 425a03c..1566890 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -1265,6 +1265,15 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclStaticLibrary) #endif /* defined(USE_TCL_STUBS) */ +#if (TCL_MAJOR_VERSION < 9) && defined(USE_TCL_STUBS) +#undef TclpGetClicks +#define TclpGetClicks() \ + ((unsigned long)tclIntStubsPtr->tclpGetClicks()) +#undef TclpGetSeconds +#define TclpGetSeconds() \ + ((unsigned long)tclIntStubsPtr->tclpGetSeconds()) +#endif + #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT -- cgit v0.12 From 2f8db2f9267772834f968133202224d8279fa6fe Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 26 Jun 2022 22:49:16 +0000 Subject: Add OPTS=tcl8 --- win/rules.vc | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/win/rules.vc b/win/rules.vc index 4280b9b..a5b868a 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -877,6 +877,12 @@ TCL_THREADS = 0 USE_THREAD_ALLOC= 0 !endif +!if [nmakehlp -f $(OPTS) "tcl8"] +!message *** Build for Tcl8 +TCL_MAJOR_VERSION = 8 +!endif +!endif + !if $(TCL_MAJOR_VERSION) == 8 !if [nmakehlp -f $(OPTS) "time64bit"] !message *** Force 64-bit time_t @@ -1445,6 +1451,9 @@ COMPILERFLAGS = /D_ATL_XP_TARGETING !if "$(TCL_UTF_MAX)" == "3" OPTDEFINES = $(OPTDEFINES) /DTCL_UTF_MAX=3 !endif +!if "$(TCL_MAJOR_VERSION)" == "8" +OPTDEFINES = $(OPTDEFINES) /DTCL_MAJOR_VERSION=8 +!endif # Like the TEA system only set this non empty for non-Tk extensions # Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME -- cgit v0.12 From 1ff4bd27f45558a18705f3a0750f232c01b2d0d7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 27 Jun 2022 10:07:13 +0000 Subject: Fix superflous !endif --- win/rules.vc | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/win/rules.vc b/win/rules.vc index a5b868a..6e06943 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -881,7 +881,6 @@ USE_THREAD_ALLOC= 0 !message *** Build for Tcl8 TCL_MAJOR_VERSION = 8 !endif -!endif !if $(TCL_MAJOR_VERSION) == 8 !if [nmakehlp -f $(OPTS) "time64bit"] @@ -1451,7 +1450,7 @@ COMPILERFLAGS = /D_ATL_XP_TARGETING !if "$(TCL_UTF_MAX)" == "3" OPTDEFINES = $(OPTDEFINES) /DTCL_UTF_MAX=3 !endif -!if "$(TCL_MAJOR_VERSION)" == "8" +!if $(TCL_MAJOR_VERSION) == 8 OPTDEFINES = $(OPTDEFINES) /DTCL_MAJOR_VERSION=8 !endif -- cgit v0.12 From 3df7fe883ed9238895ce61465294b40360d5b9df Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 28 Jun 2022 08:02:08 +0000 Subject: Handle tclIntPlatDecls.h --- generic/tclInt.h | 4 +- generic/tclIntPlatDecls.h | 596 ++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 572 insertions(+), 28 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 87f10f0..0c07e97 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -5115,9 +5115,7 @@ typedef struct NRE_callback { #endif #include "tclIntDecls.h" -#if TCL_MAJOR_VERSION > 8 -# include "tclIntPlatDecls.h" -#endif +#include "tclIntPlatDecls.h" #if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG) #define Tcl_AttemptAlloc TclpAlloc diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 2e032a3..3eb7baa 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -13,11 +13,6 @@ #ifndef _TCLINTPLATDECLS #define _TCLINTPLATDECLS - -#if TCL_MAJOR_VERSION < 9 -#error "This header-file only works for Tcl 9" -#endif - #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl # define TCL_STORAGE_CLASS DLLEXPORT @@ -35,6 +30,539 @@ * in the generic/tclInt.decls script. */ +#if TCL_MAJOR_VERSION < 9 + +#ifdef __cplusplus +extern "C" { +#endif + +/* + * Exported function declarations: + */ + +#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +/* 0 */ +EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, + Tcl_Channel chan); +/* 1 */ +EXTERN int TclpCloseFile(TclFile file); +/* 2 */ +EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, + TclFile writeFile, TclFile errorFile, + int numPids, Tcl_Pid *pidPtr); +/* 3 */ +EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); +/* 4 */ +EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, + const char **argv, TclFile inputFile, + TclFile outputFile, TclFile errorFile, + Tcl_Pid *pidPtr); +/* 5 */ +EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); +/* 6 */ +EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); +/* 7 */ +EXTERN TclFile TclpOpenFile(const char *fname, int mode); +/* 8 */ +EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); +/* 9 */ +EXTERN TclFile TclpCreateTempFile(const char *contents); +/* 10 */ +EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); +/* 11 */ +EXTERN struct tm * TclpLocaltime_unix(const time_t *clock); +/* 12 */ +EXTERN struct tm * TclpGmtime_unix(const time_t *clock); +/* 13 */ +EXTERN char * TclpInetNtoa(struct in_addr addr); +/* 14 */ +EXTERN int TclUnixCopyFile(const char *src, const char *dst, + const Tcl_StatBuf *statBufPtr, + int dontCopyAtts); +/* 15 */ +EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp, + int objIndex, Tcl_Obj *fileName, + Tcl_Obj **attributePtrPtr); +/* 16 */ +EXTERN int TclMacOSXSetFileAttribute(Tcl_Interp *interp, + int objIndex, Tcl_Obj *fileName, + Tcl_Obj *attributePtr); +/* 17 */ +EXTERN int TclMacOSXCopyFileAttributes(const char *src, + const char *dst, + const Tcl_StatBuf *statBufPtr); +/* 18 */ +EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, + const char *pathName, const char *fileName, + Tcl_StatBuf *statBufPtr, + Tcl_GlobTypeData *types); +/* 19 */ +EXTERN void TclMacOSXNotifierAddRunLoopMode( + const void *runLoopMode); +/* Slot 20 is reserved */ +/* Slot 21 is reserved */ +/* 22 */ +EXTERN TclFile TclpCreateTempFile_(const char *contents); +/* Slot 23 is reserved */ +/* Slot 24 is reserved */ +/* Slot 25 is reserved */ +/* Slot 26 is reserved */ +/* Slot 27 is reserved */ +/* Slot 28 is reserved */ +/* 29 */ +EXTERN int TclWinCPUID(int index, int *regs); +/* 30 */ +EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, + Tcl_Obj *resultingNameObj); +#endif /* UNIX */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ +/* 0 */ +EXTERN void TclWinConvertError(DWORD errCode); +/* 1 */ +EXTERN void TclWinConvertWSAError(DWORD errCode); +/* 2 */ +EXTERN struct servent * TclWinGetServByName(const char *nm, + const char *proto); +/* 3 */ +EXTERN int TclWinGetSockOpt(SOCKET s, int level, int optname, + char *optval, int *optlen); +/* 4 */ +EXTERN HINSTANCE TclWinGetTclInstance(void); +/* 5 */ +EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); +/* 6 */ +EXTERN unsigned short TclWinNToHS(unsigned short ns); +/* 7 */ +EXTERN int TclWinSetSockOpt(SOCKET s, int level, int optname, + const char *optval, int optlen); +/* 8 */ +EXTERN int TclpGetPid(Tcl_Pid pid); +/* 9 */ +EXTERN int TclWinGetPlatformId(void); +/* 10 */ +EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); +/* 11 */ +EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, + Tcl_Channel chan); +/* 12 */ +EXTERN int TclpCloseFile(TclFile file); +/* 13 */ +EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, + TclFile writeFile, TclFile errorFile, + int numPids, Tcl_Pid *pidPtr); +/* 14 */ +EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); +/* 15 */ +EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, + const char **argv, TclFile inputFile, + TclFile outputFile, TclFile errorFile, + Tcl_Pid *pidPtr); +/* 16 */ +EXTERN int TclpIsAtty(int fd); +/* 17 */ +EXTERN int TclUnixCopyFile(const char *src, const char *dst, + const Tcl_StatBuf *statBufPtr, + int dontCopyAtts); +/* 18 */ +EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); +/* 19 */ +EXTERN TclFile TclpOpenFile(const char *fname, int mode); +/* 20 */ +EXTERN void TclWinAddProcess(HANDLE hProcess, DWORD id); +/* 21 */ +EXTERN char * TclpInetNtoa(struct in_addr addr); +/* 22 */ +EXTERN TclFile TclpCreateTempFile(const char *contents); +/* Slot 23 is reserved */ +/* 24 */ +EXTERN char * TclWinNoBackslash(char *path); +/* Slot 25 is reserved */ +/* 26 */ +EXTERN void TclWinSetInterfaces(int wide); +/* 27 */ +EXTERN void TclWinFlushDirtyChannels(void); +/* 28 */ +EXTERN void TclWinResetInterfaces(void); +/* 29 */ +EXTERN int TclWinCPUID(int index, int *regs); +/* 30 */ +EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, + Tcl_Obj *resultingNameObj); +#endif /* WIN */ +#ifdef MAC_OSX_TCL /* MACOSX */ +/* 0 */ +EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, + Tcl_Channel chan); +/* 1 */ +EXTERN int TclpCloseFile(TclFile file); +/* 2 */ +EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, + TclFile writeFile, TclFile errorFile, + int numPids, Tcl_Pid *pidPtr); +/* 3 */ +EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); +/* 4 */ +EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, + const char **argv, TclFile inputFile, + TclFile outputFile, TclFile errorFile, + Tcl_Pid *pidPtr); +/* 5 */ +EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); +/* 6 */ +EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); +/* 7 */ +EXTERN TclFile TclpOpenFile(const char *fname, int mode); +/* 8 */ +EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); +/* 9 */ +EXTERN TclFile TclpCreateTempFile(const char *contents); +/* 10 */ +EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); +/* 11 */ +EXTERN struct tm * TclpLocaltime_unix(const time_t *clock); +/* 12 */ +EXTERN struct tm * TclpGmtime_unix(const time_t *clock); +/* 13 */ +EXTERN char * TclpInetNtoa(struct in_addr addr); +/* 14 */ +EXTERN int TclUnixCopyFile(const char *src, const char *dst, + const Tcl_StatBuf *statBufPtr, + int dontCopyAtts); +/* 15 */ +EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp, + int objIndex, Tcl_Obj *fileName, + Tcl_Obj **attributePtrPtr); +/* 16 */ +EXTERN int TclMacOSXSetFileAttribute(Tcl_Interp *interp, + int objIndex, Tcl_Obj *fileName, + Tcl_Obj *attributePtr); +/* 17 */ +EXTERN int TclMacOSXCopyFileAttributes(const char *src, + const char *dst, + const Tcl_StatBuf *statBufPtr); +/* 18 */ +EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, + const char *pathName, const char *fileName, + Tcl_StatBuf *statBufPtr, + Tcl_GlobTypeData *types); +/* 19 */ +EXTERN void TclMacOSXNotifierAddRunLoopMode( + const void *runLoopMode); +/* Slot 20 is reserved */ +/* Slot 21 is reserved */ +/* 22 */ +EXTERN TclFile TclpCreateTempFile_(const char *contents); +/* Slot 23 is reserved */ +/* Slot 24 is reserved */ +/* Slot 25 is reserved */ +/* Slot 26 is reserved */ +/* Slot 27 is reserved */ +/* Slot 28 is reserved */ +/* 29 */ +EXTERN int TclWinCPUID(int index, int *regs); +/* 30 */ +EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, + Tcl_Obj *resultingNameObj); +#endif /* MACOSX */ + +typedef struct TclIntPlatStubs { + int magic; + void *hooks; + +#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ + void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ + int (*tclpCloseFile) (TclFile file); /* 1 */ + Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ + int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ + int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ + int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 5 */ + TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ + TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ + int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ + TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ + Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ + struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */ + struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */ + char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */ + int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ + int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */ + int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ + int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ + int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ + void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ + void (*reserved20)(void); + void (*reserved21)(void); + TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ + void (*reserved23)(void); + void (*reserved24)(void); + void (*reserved25)(void); + void (*reserved26)(void); + void (*reserved27)(void); + void (*reserved28)(void); + int (*tclWinCPUID) (int index, int *regs); /* 29 */ + int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ +#endif /* UNIX */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ + void (*tclWinConvertError) (DWORD errCode); /* 0 */ + void (*tclWinConvertWSAError) (DWORD errCode); /* 1 */ + struct servent * (*tclWinGetServByName) (const char *nm, const char *proto); /* 2 */ + int (*tclWinGetSockOpt) (SOCKET s, int level, int optname, char *optval, int *optlen); /* 3 */ + HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */ + int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ + unsigned short (*tclWinNToHS) (unsigned short ns); /* 6 */ + int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, const char *optval, int optlen); /* 7 */ + int (*tclpGetPid) (Tcl_Pid pid); /* 8 */ + int (*tclWinGetPlatformId) (void); /* 9 */ + Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ + void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ + int (*tclpCloseFile) (TclFile file); /* 12 */ + Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ + int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 14 */ + int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ + int (*tclpIsAtty) (int fd); /* 16 */ + int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */ + TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */ + TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */ + void (*tclWinAddProcess) (HANDLE hProcess, DWORD id); /* 20 */ + char * (*tclpInetNtoa) (struct in_addr addr); /* 21 */ + TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ + void (*reserved23)(void); + char * (*tclWinNoBackslash) (char *path); /* 24 */ + void (*reserved25)(void); + void (*tclWinSetInterfaces) (int wide); /* 26 */ + void (*tclWinFlushDirtyChannels) (void); /* 27 */ + void (*tclWinResetInterfaces) (void); /* 28 */ + int (*tclWinCPUID) (int index, int *regs); /* 29 */ + int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ +#endif /* WIN */ +#ifdef MAC_OSX_TCL /* MACOSX */ + void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ + int (*tclpCloseFile) (TclFile file); /* 1 */ + Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ + int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ + int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */ + int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 5 */ + TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ + TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ + int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ + TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ + Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ + struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */ + struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */ + char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */ + int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ + int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */ + int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ + int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */ + int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */ + void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */ + void (*reserved20)(void); + void (*reserved21)(void); + TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */ + void (*reserved23)(void); + void (*reserved24)(void); + void (*reserved25)(void); + void (*reserved26)(void); + void (*reserved27)(void); + void (*reserved28)(void); + int (*tclWinCPUID) (int index, int *regs); /* 29 */ + int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ +#endif /* MACOSX */ +} TclIntPlatStubs; + +extern const TclIntPlatStubs *tclIntPlatStubsPtr; + +#ifdef __cplusplus +} +#endif + +#if defined(USE_TCL_STUBS) + +/* + * Inline function declarations: + */ + +#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ +#define TclGetAndDetachPids \ + (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ +#define TclpCloseFile \ + (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ +#define TclpCreateCommandChannel \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ +#define TclpCreatePipe \ + (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ +#define TclpCreateProcess \ + (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ +#define TclUnixWaitForFile_ \ + (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */ +#define TclpMakeFile \ + (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ +#define TclpOpenFile \ + (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ +#define TclUnixWaitForFile \ + (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ +#define TclpCreateTempFile \ + (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ +#define TclpReaddir \ + (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ +#define TclpLocaltime_unix \ + (tclIntPlatStubsPtr->tclpLocaltime_unix) /* 11 */ +#define TclpGmtime_unix \ + (tclIntPlatStubsPtr->tclpGmtime_unix) /* 12 */ +#define TclpInetNtoa \ + (tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */ +#define TclUnixCopyFile \ + (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ +#define TclMacOSXGetFileAttribute \ + (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */ +#define TclMacOSXSetFileAttribute \ + (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */ +#define TclMacOSXCopyFileAttributes \ + (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ +#define TclMacOSXMatchType \ + (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ +#define TclMacOSXNotifierAddRunLoopMode \ + (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ +/* Slot 20 is reserved */ +/* Slot 21 is reserved */ +#define TclpCreateTempFile_ \ + (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ +/* Slot 23 is reserved */ +/* Slot 24 is reserved */ +/* Slot 25 is reserved */ +/* Slot 26 is reserved */ +/* Slot 27 is reserved */ +/* Slot 28 is reserved */ +#define TclWinCPUID \ + (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ +#define TclUnixOpenTemporaryFile \ + (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ +#endif /* UNIX */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ +#define TclWinConvertError \ + (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ +#define TclWinConvertWSAError \ + (tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */ +#define TclWinGetServByName \ + (tclIntPlatStubsPtr->tclWinGetServByName) /* 2 */ +#define TclWinGetSockOpt \ + (tclIntPlatStubsPtr->tclWinGetSockOpt) /* 3 */ +#define TclWinGetTclInstance \ + (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ +#define TclUnixWaitForFile \ + (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ +#define TclWinNToHS \ + (tclIntPlatStubsPtr->tclWinNToHS) /* 6 */ +#define TclWinSetSockOpt \ + (tclIntPlatStubsPtr->tclWinSetSockOpt) /* 7 */ +#define TclpGetPid \ + (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ +#define TclWinGetPlatformId \ + (tclIntPlatStubsPtr->tclWinGetPlatformId) /* 9 */ +#define TclpReaddir \ + (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ +#define TclGetAndDetachPids \ + (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ +#define TclpCloseFile \ + (tclIntPlatStubsPtr->tclpCloseFile) /* 12 */ +#define TclpCreateCommandChannel \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */ +#define TclpCreatePipe \ + (tclIntPlatStubsPtr->tclpCreatePipe) /* 14 */ +#define TclpCreateProcess \ + (tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */ +#define TclpIsAtty \ + (tclIntPlatStubsPtr->tclpIsAtty) /* 16 */ +#define TclUnixCopyFile \ + (tclIntPlatStubsPtr->tclUnixCopyFile) /* 17 */ +#define TclpMakeFile \ + (tclIntPlatStubsPtr->tclpMakeFile) /* 18 */ +#define TclpOpenFile \ + (tclIntPlatStubsPtr->tclpOpenFile) /* 19 */ +#define TclWinAddProcess \ + (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */ +#define TclpInetNtoa \ + (tclIntPlatStubsPtr->tclpInetNtoa) /* 21 */ +#define TclpCreateTempFile \ + (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ +/* Slot 23 is reserved */ +#define TclWinNoBackslash \ + (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ +/* Slot 25 is reserved */ +#define TclWinSetInterfaces \ + (tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */ +#define TclWinFlushDirtyChannels \ + (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */ +#define TclWinResetInterfaces \ + (tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */ +#define TclWinCPUID \ + (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ +#define TclUnixOpenTemporaryFile \ + (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ +#endif /* WIN */ +#ifdef MAC_OSX_TCL /* MACOSX */ +#define TclGetAndDetachPids \ + (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ +#define TclpCloseFile \ + (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ +#define TclpCreateCommandChannel \ + (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ +#define TclpCreatePipe \ + (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ +#define TclpCreateProcess \ + (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ +#define TclUnixWaitForFile_ \ + (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */ +#define TclpMakeFile \ + (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ +#define TclpOpenFile \ + (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ +#define TclUnixWaitForFile \ + (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ +#define TclpCreateTempFile \ + (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ +#define TclpReaddir \ + (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ +#define TclpLocaltime_unix \ + (tclIntPlatStubsPtr->tclpLocaltime_unix) /* 11 */ +#define TclpGmtime_unix \ + (tclIntPlatStubsPtr->tclpGmtime_unix) /* 12 */ +#define TclpInetNtoa \ + (tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */ +#define TclUnixCopyFile \ + (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ +#define TclMacOSXGetFileAttribute \ + (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */ +#define TclMacOSXSetFileAttribute \ + (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */ +#define TclMacOSXCopyFileAttributes \ + (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ +#define TclMacOSXMatchType \ + (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ +#define TclMacOSXNotifierAddRunLoopMode \ + (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ +/* Slot 20 is reserved */ +/* Slot 21 is reserved */ +#define TclpCreateTempFile_ \ + (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ +/* Slot 23 is reserved */ +/* Slot 24 is reserved */ +/* Slot 25 is reserved */ +/* Slot 26 is reserved */ +/* Slot 27 is reserved */ +/* Slot 28 is reserved */ +#define TclWinCPUID \ + (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ +#define TclUnixOpenTemporaryFile \ + (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ +#endif /* MACOSX */ + +#endif /* defined(USE_TCL_STUBS) */ + +#else /* TCL_MAJOR_VERSION > 8 */ /* !BEGIN!: Do not edit below this line. */ #ifdef __cplusplus @@ -207,32 +735,50 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ +#endif /* TCL_MAJOR_VERSION */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT -#define TclWinConvertWSAError Tcl_WinConvertError -#define TclWinConvertError Tcl_WinConvertError +#undef TclpLocaltime_unix +#undef TclpGmtime_unix +#undef TclWinConvertWSAError +#define TclWinConvertWSAError TclWinConvertError +#if !defined(TCL_USE_STUBS) && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +# undef TclWinConvertError +# define TclWinConvertError Tcl_WinConvertError +#endif -#ifdef MAC_OSX_TCL /* not accessable on Win32/UNIX */ -MODULE_SCOPE int TclMacOSXGetFileAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj **attributePtrPtr); -/* 16 */ -MODULE_SCOPE int TclMacOSXSetFileAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj *attributePtr); -/* 17 */ -MODULE_SCOPE int TclMacOSXCopyFileAttributes(const char *src, - const char *dst, - const Tcl_StatBuf *statBufPtr); -/* 18 */ -MODULE_SCOPE int TclMacOSXMatchType(Tcl_Interp *interp, - const char *pathName, const char *fileName, - Tcl_StatBuf *statBufPtr, - Tcl_GlobTypeData *types); +#undef TclpInetNtoa +#define TclpInetNtoa inet_ntoa + +#undef TclpCreateTempFile_ +#undef TclUnixWaitForFile_ +#ifndef MAC_OSX_TCL /* not accessable on Win32/UNIX */ +#undef TclMacOSXGetFileAttribute /* 15 */ +#undef TclMacOSXSetFileAttribute /* 16 */ +#undef TclMacOSXCopyFileAttributes /* 17 */ +#undef TclMacOSXMatchType /* 18 */ +#undef TclMacOSXNotifierAddRunLoopMode /* 19 */ #endif -#if !defined(_WIN32) +#if defined(_WIN32) +# undef TclWinNToHS +# undef TclWinGetServByName +# undef TclWinGetSockOpt +# undef TclWinSetSockOpt +# undef TclWinGetPlatformId +# undef TclWinResetInterfaces +# undef TclWinSetInterfaces +# if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +# define TclWinNToHS ntohs +# define TclWinGetServByName getservbyname +# define TclWinGetSockOpt getsockopt +# define TclWinSetSockOpt setsockopt +# define TclWinGetPlatformId() (2) /* VER_PLATFORM_WIN32_NT */ +# define TclWinResetInterfaces() /* nop */ +# define TclWinSetInterfaces(dummy) /* nop */ +# endif /* TCL_NO_DEPRECATED */ +#else # undef TclpGetPid # define TclpGetPid(pid) ((size_t)(pid)) #endif -- cgit v0.12 -- cgit v0.12 From 9336a020ee8538c5927e9cbe8cbad80ef915c741 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 8 Jul 2022 04:06:35 +0000 Subject: Start on TIP-602 implementation. Work in progress --- generic/tclEnv.c | 3 ++ generic/tclFCmd.c | 8 +++-- generic/tclFileName.c | 86 +++++++++++++++++++++++++++++++++++++++++---------- generic/tclIOUtil.c | 10 ++++-- generic/tclInt.h | 2 ++ generic/tclPathObj.c | 22 +++++++++---- library/safe.tcl | 2 ++ unix/tclUnixInit.c | 15 +++++++++ win/tclWinFCmd.c | 8 +++-- 9 files changed, 126 insertions(+), 30 deletions(-) diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 73a8b84..e469fe9 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -365,6 +365,7 @@ TclSetEnv( Tcl_MutexUnlock(&envMutex); +#ifdef TCL_TILDE_EXPAND if (!strcmp(name, "HOME")) { /* * If the user's home directory has changed, we must invalidate the @@ -373,6 +374,8 @@ TclSetEnv( Tcl_FSMountsChanged(NULL); } +#endif + } /* diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index ad60146..c19623d 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -882,7 +882,8 @@ FileBasename( Tcl_IncrRefCount(splitPtr); if (objc != 0) { - if ((objc == 1) && (*TclGetString(pathPtr) == '~')) { +#ifdef TCL_TILDE_EXPAND + if ((objc == 1) && (*TclGetString(pathPtr) == '~')) { Tcl_DecrRefCount(splitPtr); if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { return NULL; @@ -890,9 +891,10 @@ FileBasename( splitPtr = Tcl_FSSplitPath(pathPtr, &objc); Tcl_IncrRefCount(splitPtr); } +#endif - /* - * Return the last component, unless it is the only component, and it + /* + * Return the last component, unless it is the only component, and it * is the root of an absolute path. */ diff --git a/generic/tclFileName.c b/generic/tclFileName.c index dba137c..b13a435 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -362,6 +362,7 @@ Tcl_GetPathType( * file). The exported function Tcl_FSGetPathType should be used by * extensions. * + * If TCL_TILDE_EXPAND defined: * Note that '~' paths are always considered TCL_PATH_ABSOLUTE, even * though expanding the '~' could lead to any possible path type. This * function should therefore be considered a low-level, string @@ -389,8 +390,9 @@ TclpGetNativePathType( const char *path = TclGetString(pathPtr); if (path[0] == '~') { - /* - * This case is common to all platforms. Paths that begin with ~ are +#ifdef TCL_TILDE_EXPAND + /* + * This case is common to all platforms. Paths that begin with ~ are * absolute. */ @@ -401,6 +403,9 @@ TclpGetNativePathType( } *driveNameLengthPtr = end - path; } +#else + type = TCL_PATH_RELATIVE; +#endif } else { switch (tclPlatform) { case TCL_PLATFORM_UNIX: { @@ -697,13 +702,17 @@ SplitUnixPath( length = path - elementStart; if (length > 0) { Tcl_Obj *nextElt; - if ((elementStart[0] == '~') && (elementStart != origPath)) { +#ifdef TCL_TILDE_EXPAND + if ((elementStart[0] == '~') && (elementStart != origPath)) { TclNewLiteralStringObj(nextElt, "./"); Tcl_AppendToObj(nextElt, elementStart, length); } else { nextElt = Tcl_NewStringObj(elementStart, length); } - Tcl_ListObjAppendElement(NULL, result, nextElt); +#else + nextElt = Tcl_NewStringObj(elementStart, length); +#endif + Tcl_ListObjAppendElement(NULL, result, nextElt); } if (*path++ == '\0') { break; @@ -766,10 +775,13 @@ SplitWinPath( length = p - elementStart; if (length > 0) { Tcl_Obj *nextElt; - if ((elementStart != path) && ((elementStart[0] == '~') - || (isalpha(UCHAR(elementStart[0])) - && elementStart[1] == ':'))) { - TclNewLiteralStringObj(nextElt, "./"); + if ((elementStart != path) && + ( +#ifdef TCL_TILDE_EXPAND + (elementStart[0] == '~') || +#endif + (isalpha(UCHAR(elementStart[0])) && elementStart[1] == ':'))) { + TclNewLiteralStringObj(nextElt, "./"); Tcl_AppendToObj(nextElt, elementStart, length); } else { nextElt = Tcl_NewStringObj(elementStart, length); @@ -871,9 +883,15 @@ TclpNativeJoinPath( p = joining; if (length != 0) { - if ((p[0] == '.') && (p[1] == '/') && ((p[2] == '~') - || (tclPlatform==TCL_PLATFORM_WINDOWS && isalpha(UCHAR(p[2])) - && (p[3] == ':')))) { + if ((p[0] == '.') && + (p[1] == '/') && + ( +#ifdef TCL_TILDE_EXPAND + (p[2] == '~') || +#endif + (tclPlatform==TCL_PLATFORM_WINDOWS && + isalpha(UCHAR(p[2])) && + (p[3] == ':')))) { p += 2; } } @@ -1146,6 +1164,7 @@ TclGetExtension( return p; } +#ifdef TCL_TILDE_EXPAND /* *---------------------------------------------------------------------- * @@ -1204,6 +1223,35 @@ DoTildeSubst( } return Tcl_DStringValue(resultPtr); } +#endif /* TCL_TILDE_EXPAND */ + +/* + *---------------------------------------------------------------------- + * + * TclResolveTildePaths -- + * + * Given a Tcl_Obj that is a list of paths, returns a Tcl_Obj containing + * the paths with any ~-prefixed paths resolved. Returns NULL if + * none of the paths contained a ~-prefixed path, or passed in value + * was not a list, or if NULL was passed in. + * + * ~-prefixed paths that cannot be resolved are removed from the + * returned list. + * + * Results: + * Returns a Tcl_Obj with resolved paths or NULL. + * + *---------------------------------------------------------------------- + */ +Tcl_Obj *TclResolveTildePaths( + Tcl_Interp *interp, + Tcl_Obj *pathsObj) +{ + /* TODO */ + + return NULL; +} + /* *---------------------------------------------------------------------- @@ -1729,7 +1777,6 @@ TclGlob( * NULL. */ { const char *separators; - const char *head; char *tail, *start; int result; Tcl_Obj *filenamesObj, *savedResultObj; @@ -1745,7 +1792,6 @@ TclGlob( } if (pathPrefix == NULL) { - char c; Tcl_DString buffer; Tcl_DStringInit(&buffer); @@ -1755,7 +1801,10 @@ TclGlob( * Perform tilde substitution, if needed. */ - if (start[0] == '~') { +#ifdef TCL_TILDE_EXPAND + if (start[0] == '~') { + const char *head; + char c; /* * Find the first path separator after the tilde. */ @@ -1794,6 +1843,9 @@ TclGlob( } else { tail = pattern; } +#else + tail = pattern; +#endif /* TCL_TILDE_EXPAND */ } else { Tcl_IncrRefCount(pathPrefix); tail = pattern; @@ -2351,14 +2403,16 @@ DoGlob( for (i=0; result==TCL_OK && i 0) { Tcl_Obj *nextElt; - if (elementStart[0] == '~') { +#ifdef TCL_TILDE_EXPAND + if (elementStart[0] == '~') { TclNewLiteralStringObj(nextElt, "./"); Tcl_AppendToObj(nextElt, elementStart, length); } else { nextElt = Tcl_NewStringObj(elementStart, length); } - Tcl_ListObjAppendElement(NULL, result, nextElt); +#else + nextElt = Tcl_NewStringObj(elementStart, length); +#endif /* TCL_TILDE_EXPAND */ + Tcl_ListObjAppendElement(NULL, result, nextElt); } if (*p++ == '\0') { break; diff --git a/generic/tclInt.h b/generic/tclInt.h index 6997dda..0923795 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3020,6 +3020,8 @@ MODULE_SCOPE int TclIsDigitProc(int byte); MODULE_SCOPE int TclIsBareword(int byte); MODULE_SCOPE Tcl_Obj * TclJoinPath(size_t elements, Tcl_Obj * const objv[], int forceRelative); +MODULE_SCOPE Tcl_Obj * TclResolveTildePaths(Tcl_Interp *interp, + Tcl_Obj *pathsObj); MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index f7da276..aff0a33 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -699,7 +699,8 @@ TclPathPart( splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements); Tcl_IncrRefCount(splitPtr); - if (splitElements == 1 && TclGetString(pathPtr)[0] == '~') { +#ifdef TCL_TILDE_EXPAND + if (splitElements == 1 && TclGetString(pathPtr)[0] == '~') { Tcl_Obj *norm; TclDecrRefCount(splitPtr); @@ -710,7 +711,8 @@ TclPathPart( splitPtr = Tcl_FSSplitPath(norm, &splitElements); Tcl_IncrRefCount(splitPtr); } - if (portion == TCL_PATH_TAIL) { +#endif /* TCL_TILDE_EXPAND */ + if (portion == TCL_PATH_TAIL) { /* * Return the last component, unless it is the only component, and * it is the root of an absolute path. @@ -1038,8 +1040,9 @@ TclJoinPath( } ptr = Tcl_GetStringFromObj(res, &length); - /* - * Strip off any './' before a tilde, unless this is the beginning of +#ifdef TCL_TILDE_EXPAND + /* + * Strip off any './' before a tilde, unless this is the beginning of * the path. */ @@ -1047,9 +1050,10 @@ TclJoinPath( (strElt[1] == '/') && (strElt[2] == '~')) { strElt += 2; } +#endif /* TCL_TILDE_EXPAND */ - /* - * A NULL value for fsPtr at this stage basically means we're trying + /* + * A NULL value for fsPtr at this stage basically means we're trying * to join a relative path onto something which is also relative (or * empty). There's nothing particularly wrong with that. */ @@ -1246,6 +1250,7 @@ TclNewFSPathObj( const char *p; int state = 0, count = 0; +#ifdef TCL_TILDE_EXPAND /* [Bug 2806250] - this is only a partial solution of the problem. * The PATHFLAGS != 0 representation assumes in many places that * the "tail" part stored in the normPathPtr field is itself a @@ -1269,6 +1274,7 @@ TclNewFSPathObj( Tcl_DecrRefCount(tail); return pathPtr; } +#endif /* TCL_TILDE_EXPAND */ TclNewObj(pathPtr); fsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath)); @@ -2230,6 +2236,7 @@ SetFsPathFromAny( * Handle tilde substitutions, if needed. */ +#ifdef TCL_TILDE_EXPAND if (len && name[0] == '~') { Tcl_DString temp; size_t split; @@ -2341,6 +2348,9 @@ SetFsPathFromAny( } else { transPtr = TclJoinPath(1, &pathPtr, 1); } +#else + transPtr = TclJoinPath(1, &pathPtr, 1); +#endif /* TCL_TILDE_EXPAND */ /* * Now we have a translated filename in 'transPtr'. This will have forward diff --git a/library/safe.tcl b/library/safe.tcl index 6c905fb..09c82e5 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -733,6 +733,8 @@ proc ::safe::CheckFileName {child file} { # prevent discovery of what home directories exist. proc ::safe::AliasFileSubcommand {child subcommand name} { + # TODO - if TIP602 is accepted for Tcl9, this check could be removed. + # The check is required if TCL_TILDE_EXPAND is defined. if {[string match ~* $name]} { set name ./$name } diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index ec85fbe..9d84a21 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -863,6 +863,21 @@ TclpSetVariables( Tcl_SetVar2(interp, "tcl_pkgPath", NULL, pkgPath, TCL_GLOBAL_ONLY); } +#ifndef TCL_TILDE_EXPAND + { + Tcl_Obj *resolvedPaths = + TclResolveTildePaths(interp, + Tcl_GetVar2Ex( + interp, + "tcl_pkgPath", + NULL, + TCL_GLOBAL_ONLY)); + if (resolvedPaths) { + Tcl_SetVar2Ex(interp, "tcl_pkgPath", NULL, resolvedPaths, TCL_GLOBAL_ONLY); + } + } +#endif + #ifdef DJGPP Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY); #else diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 025ac4b..003f7bb 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -1719,7 +1719,8 @@ ConvertFileNameFormat( * Deal with issues of tildes being absolute. */ - if (Tcl_DStringValue(&dsTemp)[0] == '~') { +#ifdef TCL_TILDE_EXPAND + if (Tcl_DStringValue(&dsTemp)[0] == '~') { TclNewLiteralStringObj(tempPath, "./"); Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp), Tcl_DStringLength(&dsTemp)); @@ -1727,7 +1728,10 @@ ConvertFileNameFormat( } else { tempPath = TclDStringToObj(&dsTemp); } - Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath); +#else + tempPath = TclDStringToObj(&dsTemp); +#endif /* TCL_TILDE_EXPAND */ + Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath); FindClose(handle); } } -- cgit v0.12 From 3674905dbda8443171db562a6c69bf50228f18fb Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 8 Jul 2022 13:48:36 +0000 Subject: Resolve ~ for MacOS during initialization --- generic/tclFileName.c | 28 -------- generic/tclInt.h | 3 +- generic/tclPathObj.c | 188 ++++++++++++++++++++++++++++++++++++++++++++++++++ unix/tclUnixInit.c | 16 ++--- 4 files changed, 197 insertions(+), 38 deletions(-) diff --git a/generic/tclFileName.c b/generic/tclFileName.c index b13a435..3ffdede 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1228,34 +1228,6 @@ DoTildeSubst( /* *---------------------------------------------------------------------- * - * TclResolveTildePaths -- - * - * Given a Tcl_Obj that is a list of paths, returns a Tcl_Obj containing - * the paths with any ~-prefixed paths resolved. Returns NULL if - * none of the paths contained a ~-prefixed path, or passed in value - * was not a list, or if NULL was passed in. - * - * ~-prefixed paths that cannot be resolved are removed from the - * returned list. - * - * Results: - * Returns a Tcl_Obj with resolved paths or NULL. - * - *---------------------------------------------------------------------- - */ -Tcl_Obj *TclResolveTildePaths( - Tcl_Interp *interp, - Tcl_Obj *pathsObj) -{ - /* TODO */ - - return NULL; -} - - -/* - *---------------------------------------------------------------------- - * * Tcl_GlobObjCmd -- * * This procedure is invoked to process the "glob" Tcl command. See the diff --git a/generic/tclInt.h b/generic/tclInt.h index 0923795..394fc54 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3020,8 +3020,9 @@ MODULE_SCOPE int TclIsDigitProc(int byte); MODULE_SCOPE int TclIsBareword(int byte); MODULE_SCOPE Tcl_Obj * TclJoinPath(size_t elements, Tcl_Obj * const objv[], int forceRelative); -MODULE_SCOPE Tcl_Obj * TclResolveTildePaths(Tcl_Interp *interp, +MODULE_SCOPE Tcl_Obj * TclResolveTildePath(Tcl_Interp *interp, Tcl_Obj *pathsObj); +MODULE_SCOPE Tcl_Obj * TclResolveTildePathList(Tcl_Obj *pathsObj); MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index aff0a33..7efd14e 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -2569,6 +2569,194 @@ TclNativePathInFilesystem( } /* + *---------------------------------------------------------------------- + * + * TclResolveTildePath -- + * + * If the passed Tcl_Obj is begins with a tilde, does tilde resolution + * and returns a Tcl_Obj containing the resolved path. If the tilde + * component cannot be resolved, returns NULL. If the path does not + * begin with a tilde, returns unmodified. + * + * The trailing components of the path are returned verbatim. No + * processing is done on them. Moreover, no assumptions should be + * made about the separators in the returned path. They may be / + * or native. Appropriate path manipulations functions should be + * used by caller if desired. + * + * Results: + * Returns a Tcl_Obj with resolved path and reference count 0, or the + * original Tcl_Obj if it does not begin with a tilde. Returns NULL + * if the path begins with a ~ that cannot be resolved. + * + *---------------------------------------------------------------------- + */ +Tcl_Obj * +TclResolveTildePath( + Tcl_Interp *interp, /* May be NULL. Only used for error messages */ + Tcl_Obj *pathObj) +{ + size_t len; + Tcl_Obj *resolvedObj; + const char *name; + Tcl_DString dirString; + size_t split; + char separator = '/'; + + /* + * Copied almost verbatim from the corresponding SetFsPathFromAny fragment + * in 8.7. + * + * First step is to translate the filename. This is similar to + * Tcl_TranslateFilename, but shouldn't convert everything to windows + * backslashes on that platform. The current implementation of this piece + * is a slightly optimised version of the various Tilde/Split/Join stuff + * to avoid multiple split/join operations. + * + * We remove any trailing directory separator. + * + * However, the split/join routines are quite complex, and one has to make + * sure not to break anything on Unix or Win (fCmd.test, fileName.test and + * cmdAH.test exercise most of the code). + */ + + name = Tcl_GetStringFromObj(pathObj, &len); + if (name[0] != '~') { + return pathObj; /* No tilde prefix, no need to resolve */ + } + + /* + * We have multiple cases '~/foo/bar...', '~user/foo/bar...', etc. + * split becomes value 1 for '~/...' as well as for '~'. + */ + split = FindSplitPos(name, separator); + + if (split == 1) { + /* No user name specified -> current user */ + + const char *dir; + Tcl_DString dirString; + + Tcl_DStringInit(&dirString); + dir = TclGetEnv("HOME", &dirString); + if (dir == NULL) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't find HOME environment variable to" + " expand path", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", + "HOMELESS", NULL); + } + return NULL; + } + } else { + /* User name specified - ~user */ + + const char *expandedUser; + Tcl_DString userName; + + Tcl_DStringInit(&userName); + Tcl_DStringAppend(&userName, name+1, split-1); + expandedUser = Tcl_DStringValue(&userName); + + Tcl_DStringInit(&dirString); + if (TclpGetUserHome(expandedUser, &dirString) == NULL) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "user \"%s\" doesn't exist", expandedUser)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER", + NULL); + } + Tcl_DStringFree(&userName); + Tcl_DStringFree(&dirString); + return NULL; + } + Tcl_DStringFree(&userName); + } + resolvedObj = TclDStringToObj(&dirString); + + if (split < len) { + /* If any trailer, append it verbatim */ + Tcl_AppendToObj(resolvedObj, split + name, len-split); + } + + return resolvedObj; +} + +/* + *---------------------------------------------------------------------- + * + * TclResolveTildePathList -- + * + * Given a Tcl_Obj that is a list of paths, returns a Tcl_Obj containing + * the paths with any ~-prefixed paths resolved. + * + * Empty strings and ~-prefixed paths that cannot be resolved are + * removed from the returned list. + * + * The trailing components of the path are returned verbatim. No + * processing is done on them. Moreover, no assumptions should be + * made about the separators in the returned path. They may be / + * or native. Appropriate path manipulations functions should be + * used by caller if desired. + * + * Results: + * Returns a Tcl_Obj with resolved paths. This may be a new Tcl_Obj with + * reference count 0 or the original passed-in Tcl_Obj if no paths needed + * resolution. A NULL is returned if the passed in value is not a list + * or was NULL. + * + *---------------------------------------------------------------------- + */ +Tcl_Obj * +TclResolveTildePathList( + Tcl_Obj *pathsObj) +{ + Tcl_Obj **objv; + size_t objc; + size_t i; + Tcl_Obj *resolvedPaths; + const char *path; + + if (pathsObj == NULL) { + return NULL; + } + if (Tcl_ListObjGetElements(NULL, pathsObj, &objc, &objv) != TCL_OK) { + return NULL; /* Not a list */ + } + + /* + * Figure out if any paths need resolving to avoid unnecessary allocations. + */ + for (i = 0; i < objc; ++i) { + path = Tcl_GetString(objv[i]); + if (path[0] == '~') { + break; /* At least one path needs resolution */ + } + } + if (i == objc) { + return pathsObj; /* No paths needed to be resolved */ + } + + resolvedPaths = Tcl_NewListObj(objc, NULL); + for (i = 0; i < objc; ++i) { + Tcl_Obj *resolvedPath; + + path = Tcl_GetString(objv[i]); + if (path[0] == 0) { + continue; /* Skip empty strings */ + } + resolvedPath = TclResolveTildePath(NULL, objv[i]); + if (resolvedPath) { + Tcl_ListObjAppendElement(NULL, resolvedPaths, resolvedPath); + } + } + + return resolvedPaths; +} + + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 9d84a21..50befc3 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -865,15 +865,13 @@ TclpSetVariables( #ifndef TCL_TILDE_EXPAND { - Tcl_Obj *resolvedPaths = - TclResolveTildePaths(interp, - Tcl_GetVar2Ex( - interp, - "tcl_pkgPath", - NULL, - TCL_GLOBAL_ONLY)); - if (resolvedPaths) { - Tcl_SetVar2Ex(interp, "tcl_pkgPath", NULL, resolvedPaths, TCL_GLOBAL_ONLY); + Tcl_Obj *origPaths; + Tcl_Obj *resolvedPaths; + origPaths = Tcl_GetVar2Ex(interp, "tcl_pkgPath", NULL, TCL_GLOBAL_ONLY); + resolvedPaths = TclResolveTildePathList(origPaths); + if (resolvedPaths != origPaths && resolvedPaths != NULL) { + Tcl_SetVar2Ex(interp, "tcl_pkgPath", NULL, + resolvedPaths, TCL_GLOBAL_ONLY); } } #endif -- cgit v0.12 From a41449f1cd90f78d0810898baea3568d4adabf39 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 14 Jul 2022 12:35:19 +0000 Subject: First shot at TIP #625 for Tcl 9.0. Mark lrepeat-1.8 as 'knownBug', that's OK for now. --- generic/tclCmdIL.c | 44 +- generic/tclInt.h | 232 ++- generic/tclInterp.c | 17 +- generic/tclListObj.c | 3553 +++++++++++++++++++++++++++++--------------- tests-perf/comparePerf.tcl | 371 +++++ tests-perf/listPerf.tcl | 1290 ++++++++++++++++ tests/lrepeat.test | 2 +- 7 files changed, 4262 insertions(+), 1247 deletions(-) create mode 100644 tests-perf/comparePerf.tcl create mode 100644 tests-perf/listPerf.tcl diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index f59d832..f0969fe 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2888,7 +2888,7 @@ Tcl_LrepeatObjCmd( if (elementCount && objc > LIST_MAX/elementCount) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max length of a Tcl list (%d elements) exceeded", LIST_MAX)); + "max length of a Tcl list (%" TCL_Z_MODIFIER "u elements) exceeded", LIST_MAX)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); return TCL_ERROR; } @@ -2901,10 +2901,15 @@ Tcl_LrepeatObjCmd( listPtr = Tcl_NewListObj(totalElems, NULL); if (totalElems) { - List *listRepPtr = ListRepPtr(listPtr); - - listRepPtr->elemCount = elementCount*objc; - dataArray = listRepPtr->elements; + ListRep listRep; + ListObjGetRep(listPtr, &listRep); + dataArray = ListRepElementsBase(&listRep); + listRep.storePtr->numUsed = totalElems; + if (listRep.spanPtr) { + /* Future proofing in case Tcl_NewListObj returns a span */ + listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; + listRep.spanPtr->spanLength = listRep.storePtr->numUsed; + } } /* @@ -3084,14 +3089,21 @@ Tcl_LreverseObjCmd( } if (Tcl_IsShared(objv[1]) - || (ListRepPtr(objv[1])->refCount > 1)) { /* Bug 1675044 */ + || ListObjRepIsShared(objv[1])) { /* Bug 1675044 */ Tcl_Obj *resultObj, **dataArray; - List *listRepPtr; + ListRep listRep; resultObj = Tcl_NewListObj(elemc, NULL); - listRepPtr = ListRepPtr(resultObj); - listRepPtr->elemCount = elemc; - dataArray = listRepPtr->elements; + + /* Modify the internal rep in-place */ + ListObjGetRep(resultObj, &listRep); + listRep.storePtr->numUsed = elemc; + dataArray = ListRepElementsBase(&listRep); + if (listRep.spanPtr) { + /* Future proofing */ + listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; + listRep.spanPtr->spanLength = listRep.storePtr->numUsed; + } for (i=0,j=elemc-1 ; ielements; + ListObjGetRep(resultPtr, &listRep); + newArray = ListRepElementsBase(&listRep); if (group) { for (i=0; elementPtr!=NULL ; elementPtr=elementPtr->nextPtr) { idx = elementPtr->payload.index; @@ -4453,7 +4465,11 @@ Tcl_LsortObjCmd( Tcl_IncrRefCount(objPtr); } } - listRepPtr->elemCount = i; + listRep.storePtr->numUsed = i; + if (listRep.spanPtr) { + listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; + listRep.spanPtr->spanLength = listRep.storePtr->numUsed; + } Tcl_SetObjResult(interp, resultPtr); } diff --git a/generic/tclInt.h b/generic/tclInt.h index b6d5b9a..5a59e39 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2381,59 +2381,208 @@ typedef enum TclEolTranslation { #define TCL_INVOKE_NO_TRACEBACK (1<<2) /* - * The structure used as the internal representation of Tcl list objects. This - * struct is grown (reallocated and copied) as necessary to hold all the - * list's element pointers. The struct might contain more slots than currently - * used to hold all element pointers. This is done to make append operations - * faster. + * TclListSizeT is the type for holding list element counts. It's defined + * simplify sharing source between Tcl8 and Tcl9. */ +#if TCL_MAJOR_VERSION > 8 -typedef struct List { - size_t refCount; - size_t maxElemCount; /* Total number of element array slots. */ - size_t elemCount; /* Current number of list elements. */ - int canonicalFlag; /* Set if the string representation was - * derived from the list representation. May - * be ignored if there is no string rep at - * all.*/ - Tcl_Obj *elements[TCLFLEXARRAY]; /* First list element; the struct is grown to - * accommodate all elements. */ -} List; +typedef ptrdiff_t ListSizeT; /* TODO - may need to fix to match Tcl9's API */ + +/* + * SSIZE_MAX, NOT SIZE_MAX as negative differences need to be expressed + * between values of the ListSizeT type so limit the range to signed + */ +#define ListSizeT_MAX PTRDIFF_MAX -#define LIST_MAX \ - ((int)(((size_t)UINT_MAX - offsetof(List, elements))/sizeof(Tcl_Obj *))) -#define LIST_SIZE(numElems) \ - (TCL_HASH_TYPE)(offsetof(List, elements) + ((numElems) * sizeof(Tcl_Obj *))) +#else + +typedef int ListSizeT; +#define ListSizeT_MAX INT_MAX + +#endif /* - * Macro used to get the elements of a list object. + * ListStore -- + * + * A Tcl list's internal representation is defined through three structures. + * + * A ListStore struct is a structure that includes a variable size array that + * serves as storage for a Tcl list. A contiguous sequence of slots in the + * array, the "in-use" area, holds valid pointers to Tcl_Obj values that + * belong to one or more Tcl lists. The unused slots before and after these + * are free slots that may be used to prepend and append without having to + * reallocate the struct. The ListStore may be shared amongst multiple lists + * and reference counted. + * + * A ListSpan struct defines a sequence of slots within a ListStore. This sequence + * always lies within the "in-use" area of the ListStore. Like ListStore, the + * structure may be shared among multiple lists and is reference counted. + * + * A ListRep struct holds the internal representation of a Tcl list as stored + * in a Tcl_Obj. It is composed of a ListStore and a ListSpan that together + * define the content of the list. The ListSpan specifies the range of slots + * within the ListStore that hold elements for this list. The ListSpan is + * optional in which case the list includes all the "in-use" slots of the + * ListStore. + * */ +typedef struct ListStore { + ListSizeT firstUsed; /* Index of first slot in use within slots[] */ + ListSizeT numUsed; /* Number of slots in use (starting firstUsed) */ + ListSizeT numAllocated; /* Total number of slots[] array slots. */ + int refCount; /* Number of references to this instance */ + int flags; /* LISTSTORE_* flags */ + Tcl_Obj *slots[TCLFLEXARRAY]; /* Variable size array. Grown as needed */ +} ListStore; -#define ListRepPtr(listPtr) \ - ((List *) (listPtr)->internalRep.twoPtrValue.ptr1) +#define LISTSTORE_CANONICAL 0x1 /* All Tcl_Obj's referencing this + store have their string representation + derived from the list representation */ -#define ListObjGetElements(listPtr, objc, objv) \ - ((objv) = ListRepPtr(listPtr)->elements, \ - (objc) = ListRepPtr(listPtr)->elemCount) +/* Max number of elements that can be contained in a list */ +#define LIST_MAX \ + ((ListSizeT)(((size_t)ListSizeT_MAX - offsetof(ListStore, slots)) \ + / sizeof(Tcl_Obj *))) +/* Memory size needed for a ListStore to hold numSlots_ elements */ +#define LIST_SIZE(numSlots_) \ + ((int)(offsetof(ListStore, slots) + ((numSlots_) * sizeof(Tcl_Obj *)))) -#define ListObjLength(listPtr, len) \ - ((len) = ListRepPtr(listPtr)->elemCount) +/* + * ListSpan -- + * See comments above for ListStore + */ +typedef struct ListSpan { + ListSizeT spanStart; /* Starting index of the span */ + ListSizeT spanLength; /* Number of elements in the span */ + int refCount; /* Count of references to this span record */ +} ListSpan; -#define ListObjIsCanonical(listPtr) \ - (((listPtr)->bytes == NULL) || ListRepPtr(listPtr)->canonicalFlag) +/* + * ListRep -- + * See comments above for ListStore + */ +typedef struct ListRep { + ListStore *storePtr;/* element array shared amongst different lists */ + ListSpan *spanPtr; /* If not NULL, the span holds the range of slots + within *storePtr that contain this list elements. */ +} ListRep; -#define TclListObjGetElementsM(interp, listPtr, objcPtr, objvPtr) \ - (((listPtr)->typePtr == &tclListType) \ - ? ((ListObjGetElements((listPtr), *(objcPtr), *(objvPtr))), TCL_OK)\ - : Tcl_ListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr))) +/* + * Macros used to get access list internal representations. + * + * Naming conventions: + * ListRep* - expect a pointer to a valid ListRep + * ListObj* - expect a pointer to a Tcl_Obj whose internal type is known to + * be a list (tclListType). Will crash otherwise. + * TclListObj* - expect a pointer to a Tcl_Obj whose internal type may or may not + * be tclListType. These will convert as needed and return error if + * conversion not possible. + */ + +/* Returns the starting slot for this listRep in the contained ListStore */ +#define ListRepStart(listRepPtr_) \ + ((listRepPtr_)->spanPtr ? (listRepPtr_)->spanPtr->spanStart \ + : (listRepPtr_)->storePtr->firstUsed) + +/* Returns the number of elements in this listRep */ +#define ListRepLength(listRepPtr_) \ + ((listRepPtr_)->spanPtr ? (listRepPtr_)->spanPtr->spanLength \ + : (listRepPtr_)->storePtr->numUsed) + +/* Returns a pointer to the first slot containing this ListRep elements */ +#define ListRepElementsBase(listRepPtr_) \ + (&(listRepPtr_)->storePtr->slots[ListRepStart(listRepPtr_)]) + +/* Stores the number of elements and base address of the element array */ +#define ListRepElements(listRepPtr_, objc_, objv_) \ + (((objv_) = ListRepElementsBase(listRepPtr_)), \ + ((objc_) = ListRepLength(listRepPtr_))) + +/* Returns 1/0 whether the ListRep's ListStore is shared. */ +#define ListRepIsShared(listRepPtr_) ((listRepPtr_)->storePtr->refCount > 1) + +/* Returns a pointer to the ListStore component */ +#define ListObjStorePtr(listObj_) \ + ((ListStore *)((listObj_)->internalRep.twoPtrValue.ptr1)) + +/* Returns a pointer to the ListSpan component */ +#define ListObjSpanPtr(listObj_) \ + ((ListSpan *)((listObj_)->internalRep.twoPtrValue.ptr2)) + +/* Returns the ListRep internal representaton in a Tcl_Obj */ +#define ListObjGetRep(listObj_, listRepPtr_) \ + do { \ + (listRepPtr_)->storePtr = ListObjStorePtr(listObj_); \ + (listRepPtr_)->spanPtr = ListObjSpanPtr(listObj_); \ + } while (0) + +/* Returns the length of the list */ +#define ListObjLength(listObj_, len_) \ + ((len_) = ListObjSpanPtr(listObj_) ? ListObjSpanPtr(listObj_)->spanLength \ + : ListObjStorePtr(listObj_)->numUsed) + +/* Returns the starting slot index of this list's elements in the ListStore */ +#define ListObjStart(listObj_) \ + (ListObjSpanPtr(listObj_) ? ListObjSpanPtr(listObj_)->spanStart \ + : ListObjStorePtr(listObj_)->firstUsed) + +/* Stores the element count and base address of this list's elements */ +#define ListObjGetElements(listObj_, objc_, objv_) \ + (((objv_) = &ListObjStorePtr(listObj_)->slots[ListObjStart(listObj_)]), \ + (ListObjLength(listObj_, (objc_)))) + +/* + * Returns 1/0 whether the internal representation (not the Tcl_Obj itself) + * is shared. Note by intent this only checks for sharing of ListStore, + * not spans. + */ +#define ListObjRepIsShared(listObj_) (ListObjStorePtr(listObj_)->refCount > 1) -#define TclListObjLengthM(interp, listPtr, lenPtr) \ - (((listPtr)->typePtr == &tclListType) \ - ? ((ListObjLength((listPtr), *(lenPtr))), TCL_OK)\ - : Tcl_ListObjLength((interp), (listPtr), (lenPtr))) +/* + * Certain commands like concat are optimized if an existing string + * representation of a list object is known to be in canonical format (i.e. + * generated from the list representation). There are three conditions when + * this will be the case: + * (1) No string representation exists which means it will obviously have + * to be generated from the list representation when needed + * (2) The ListStore flags is marked canonical. This is done at the time + * the string representation is generated from the list IF the list + * representation does not have a span (see comments in UpdateStringOfList). + * (3) The list representation does not have a span component. This is + * because list Tcl_Obj's with spans are always created from existing lists + * and never from strings (see SetListFromAny) and thus their string + * representation will always be canonical. + */ +#define ListObjIsCanonical(listObj_) \ + (((listObj_)->bytes == NULL) \ + || (ListObjStorePtr(listObj_)->flags & LISTSTORE_CANONICAL) \ + || ListObjSpanPtr(listObj_) != NULL) + +/* + * Converts the Tcl_Obj to a list if it isn't one and stores the element + * count and base address of this list's elements in objcPtr_ and objvPtr_. + * Return TCL_OK on success or TCL_ERROR if the Tcl_Obj cannot be + * converted to a list. + */ +#define TclListObjGetElementsM(interp_, listObj_, objcPtr_, objvPtr_) \ + (((listObj_)->typePtr == &tclListType) \ + ? ((ListObjGetElements((listObj_), *(objcPtr_), *(objvPtr_))), \ + TCL_OK) \ + : Tcl_ListObjGetElements( \ + (interp_), (listObj_), (objcPtr_), (objvPtr_))) + +/* + * Converts the Tcl_Obj to a list if it isn't one and stores the element + * count in lenPtr_. Returns TCL_OK on success or TCL_ERROR if the + * Tcl_Obj cannot be converted to a list. + */ +#define TclListObjLengthM(interp_, listObj_, lenPtr_) \ + (((listObj_)->typePtr == &tclListType) \ + ? ((ListObjLength((listObj_), *(lenPtr_))), TCL_OK) \ + : Tcl_ListObjLength((interp_), (listObj_), (lenPtr_))) -#define TclListObjIsCanonical(listPtr) \ - (((listPtr)->typePtr == &tclListType) ? ListObjIsCanonical((listPtr)) : 0) +#define TclListObjIsCanonical(listObj_) \ + (((listObj_)->typePtr == &tclListType) ? ListObjIsCanonical((listObj_)) : 0) /* * Modes for collecting (or not) in the implementations of TclNRForeachCmd, @@ -3030,6 +3179,9 @@ MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, size_t line, int n, int *lines, Tcl_Obj *const *elems); MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); +MODULE_SCOPE int TclListObjAppendElements(Tcl_Interp *interp, + Tcl_Obj *toObj, size_t elemCount, + Tcl_Obj *const elemObjv[]); MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Obj *listPtr, size_t fromIdx, size_t toIdx); MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr, diff --git a/generic/tclInterp.c b/generic/tclInterp.c index d368829..589b0da 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -1829,7 +1829,7 @@ AliasNRCmd( int prefc, cmdc, i; Tcl_Obj **prefv, **cmdv; Tcl_Obj *listPtr; - List *listRep; + ListRep listRep; int flags = TCL_EVAL_INVOKE; /* @@ -1841,14 +1841,19 @@ AliasNRCmd( prefv = &aliasPtr->objPtr; cmdc = prefc + objc - 1; + /* TODO - encapsulate this into tclListObj.c */ listPtr = Tcl_NewListObj(cmdc, NULL); - listRep = ListRepPtr(listPtr); - listRep->elemCount = cmdc; - cmdv = listRep->elements; + ListObjGetRep(listPtr, &listRep); + cmdv = ListRepElementsBase(&listRep); + listRep.storePtr->numUsed = cmdc; + if (listRep.spanPtr) { + listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; + listRep.spanPtr->spanLength = listRep.storePtr->numUsed; + } prefv = &aliasPtr->objPtr; - memcpy(cmdv, prefv, (prefc * sizeof(Tcl_Obj *))); - memcpy(cmdv+prefc, objv+1, ((objc-1) * sizeof(Tcl_Obj *))); + memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *)); + memcpy(cmdv+prefc, objv+1, (objc-1) * sizeof(Tcl_Obj *)); for (i=0; i +/* TODO - memmove is fast. Measure at what size we should prefer memmove + (for unshared objects only) in lieu of range operations */ + +/* + * Macros for validation and bug checking. + */ + +/* + * Control whether asserts are enabled. Always enable in debug builds. In non-debug + * builds, can be set with cdebug="-DENABLE_LIST_ASSERTS" on the nmake command line. + */ +#ifdef ENABLE_LIST_ASSERTS +# ifdef NDEBUG +# undef NDEBUG /* Activate assert() macro */ +# endif +#else +# ifndef NDEBUG +# define ENABLE_LIST_ASSERTS /* Always activate list asserts in debug mode */ +# endif +#endif + +#ifdef ENABLE_LIST_ASSERTS + +#define LIST_ASSERT(cond_) assert(cond_) /* TODO - is there a Tcl-specific one? */ +/* + * LIST_INDEX_ASSERT is to catch errors with negative indices and counts + * being passed AFTER validation. On Tcl9 length types are unsigned hence + * the checks against LIST_MAX. On Tcl8 length types are signed hence the + * also checks against 0. + */ +#define LIST_INDEX_ASSERT(idxarg_) \ + do { \ + ListSizeT idx_ = (idxarg_); /* To guard against ++ etc. */ \ + LIST_ASSERT(idx_ >= 0 && idx_ < LIST_MAX); \ + } while (0) +/* Ditto for counts except upper limit is different */ +#define LIST_COUNT_ASSERT(countarg_) \ + do { \ + ListSizeT count_ = (countarg_); /* To guard against ++ etc. */ \ + LIST_ASSERT(count_ >= 0 && count_ <= LIST_MAX); \ + } while (0) + +#else + +#define LIST_ASSERT(cond_) ((void) 0) +#define LIST_INDEX_ASSERT(idx_) ((void) 0) +#define LIST_COUNT_ASSERT(count_) ((void) 0) + +#endif + +/* Checks for when caller should have already converted to internal list type */ +#define LIST_ASSERT_TYPE(listObj_) \ + LIST_ASSERT((listObj_)->typePtr == &tclListType); + + /* - * Prototypes for functions defined later in this file: + * If ENABLE_LIST_INVARIANTS is enabled (-DENABLE_LIST_INVARIANTS from the + * command line), the entire list internal representation is checked for + * inconsistencies. This has a non-trivial cost so has to be separately + * enabled and not part of assertions checking. */ +#ifdef ENABLE_LIST_INVARIANTS +#define LISTREP_CHECK(listRepPtr_) ListRepValidate(listRepPtr_) +#else +#define LISTREP_CHECK(listRepPtr_) (void) 0 +#endif + +/* + * Flags used for controlling behavior of allocation of list + * internal representations. + * + * If the LISTREP_PANIC_ON_FAIL bit is set, the function will panic if + * list is too large or memory cannot be allocated. Without the flag + * a NULL pointer is returned. + * + * The LISTREP_SPACE_FAVOR_NONE, LISTREP_SPACE_FAVOR_FRONT, + * LISTREP_SPACE_FAVOR_BACK, LISTREP_SPACE_ONLY_BACK flags are used to + * control additional space when allocating. + * - If none of these flags is present, the exact space requested is + * allocated, nothing more. + * - Otherwise, if only LISTREP_FAVOR_FRONT is present, extra space is + * allocated with more towards the front. + * - Conversely, if only LISTREP_FAVOR_BACK is present extra space is allocated + * with more to the back. + * - If both flags are present (LISTREP_SPACE_FAVOR_NONE), the extra space + * is equally apportioned. + * - Finally if LISTREP_SPACE_ONLY_BACK is present, ALL extra space is at + * the back. + */ +#define LISTREP_PANIC_ON_FAIL 0x00000001 +#define LISTREP_SPACE_FAVOR_FRONT 0x00000002 +#define LISTREP_SPACE_FAVOR_BACK 0x00000004 +#define LISTREP_SPACE_ONLY_BACK 0x00000008 +#define LISTREP_SPACE_FAVOR_NONE \ + (LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK) +#define LISTREP_SPACE_FLAGS \ + (LISTREP_SPACE_FAVOR_FRONT | LISTREP_SPACE_FAVOR_BACK \ + | LISTREP_SPACE_ONLY_BACK) + +/* + * Prototypes for non-inline static functions defined later in this file: + */ +static int MemoryAllocationError(Tcl_Interp *, size_t size); +static int ListLimitExceededError(Tcl_Interp *); +static ListStore * +ListStoreNew(ListSizeT objc, Tcl_Obj *const objv[], int flags); +static int +ListRepInit(ListSizeT objc, Tcl_Obj *const objv[], int flags, ListRep *); +static int ListRepInitAttempt(Tcl_Interp *, + ListSizeT objc, + Tcl_Obj *const objv[], + ListRep *); +static void ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags); +static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr); +static int TclListObjGetRep(Tcl_Interp *, Tcl_Obj *listPtr, ListRep *repPtr); +static void ListRepRange(ListRep *srcRepPtr, + ListSizeT rangeStart, + ListSizeT rangeEnd, + int preserveSrcRep, + ListRep *rangeRepPtr); +static ListStore *ListStoreReallocate(ListStore *storePtr, ListSizeT numSlots); +#ifdef ENABLE_LIST_ASSERTS /* Else gcc complains about unused static */ +static void ListRepValidate(const ListRep *repPtr); +#endif -static List * AttemptNewList(Tcl_Interp *interp, size_t objc, - Tcl_Obj *const objv[]); -static List * NewListInternalRep(size_t objc, Tcl_Obj *const objv[], size_t p); static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeListInternalRep(Tcl_Obj *listPtr); static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -30,13 +146,7 @@ static void UpdateStringOfList(Tcl_Obj *listPtr); * The structure below defines the list Tcl object type by means of functions * that can be invoked by generic object code. * - * The internal representation of a list object is a two-pointer - * representation. The first pointer designates a List structure that contains - * an array of pointers to the element objects, together with integers that - * represent the current element count and the allocated size of the array. - * The second pointer is normally NULL; during execution of functions in this - * file that operate on nested sublists, it is occasionally used as working - * storage to avoid an auxiliary stack. + * The internal representation of a list object is ListRep defined in tcl.h. */ const Tcl_ObjType tclListType = { @@ -48,144 +158,929 @@ const Tcl_ObjType tclListType = { }; /* Macros to manipulate the List internal rep */ +#define ListRepIncrRefs(repPtr_) \ + do { \ + (repPtr_)->storePtr->refCount++; \ + if ((repPtr_)->spanPtr) \ + (repPtr_)->spanPtr->refCount++; \ + } while (0) + +/* Returns number of free unused slots at the back of the ListRep's ListStore */ +#define ListRepNumFreeTail(repPtr_) \ + ((repPtr_)->storePtr->numAllocated \ + - ((repPtr_)->storePtr->firstUsed + (repPtr_)->storePtr->numUsed)) + +/* Returns number of free unused slots at the front of the ListRep's ListStore */ +#define ListRepNumFreeHead(repPtr_) ((repPtr_)->storePtr->firstUsed) + +/* Returns a pointer to the slot corresponding to list index listIdx_ */ +#define ListRepSlotPtr(repPtr_, listIdx_) \ + (&(repPtr_)->storePtr->slots[ListRepStart(repPtr_) + (listIdx_)]) -#define ListSetInternalRep(objPtr, listRepPtr) \ - do { \ - Tcl_ObjInternalRep ir; \ - ir.twoPtrValue.ptr1 = (listRepPtr); \ - ir.twoPtrValue.ptr2 = NULL; \ - (listRepPtr)->refCount++; \ - Tcl_StoreInternalRep((objPtr), &tclListType, &ir); \ +/* + * Macros to replace the internal representation in a Tcl_Obj. There are + * subtle differences in each so make sure to use the right one to avoid + * memory leaks, access to freed memory and the like. + * + * ListObjStompRep - assumes the Tcl_Obj internal representation can be + * overwritten AND that the passed ListRep already has reference counts that + * include the reference from the Tcl_Obj. Basically just copies the pointers + * and sets the internal Tcl_Obj type to list + * + * ListObjOverwriteRep - like ListObjOverwriteRep but additionally + * increments reference counts on the passed ListRep. Generally used when + * the string representation of the Tcl_Obj is not to be modified. + * + * ListObjReplaceRepAndInvalidate - Like ListObjOverwriteRep but additionally + * assumes the Tcl_Obj internal rep is valid (and possibly even same as + * passed ListRep) and frees it first. Additionally invalidates the string + * representation. Generally used when modifying a Tcl_Obj value. + */ +#define ListObjStompRep(objPtr_, repPtr_) \ + do { \ + (objPtr_)->internalRep.twoPtrValue.ptr1 = (repPtr_)->storePtr; \ + (objPtr_)->internalRep.twoPtrValue.ptr2 = (repPtr_)->spanPtr; \ + (objPtr_)->typePtr = &tclListType; \ } while (0) -#define ListGetInternalRep(objPtr, listRepPtr) \ - do { \ - const Tcl_ObjInternalRep *irPtr; \ - irPtr = TclFetchInternalRep((objPtr), &tclListType); \ - (listRepPtr) = irPtr ? (List *)irPtr->twoPtrValue.ptr1 : NULL; \ +#define ListObjOverwriteRep(objPtr_, repPtr_) \ + do { \ + ListRepIncrRefs(repPtr_); \ + ListObjStompRep(objPtr_, repPtr_); \ } while (0) -#define ListResetInternalRep(objPtr, listRepPtr) \ - TclFetchInternalRep((objPtr), &tclListType)->twoPtrValue.ptr1 = (listRepPtr) +#define ListObjReplaceRepAndInvalidate(objPtr_, repPtr_) \ + do { \ + /* Note order important, don't use ListObjOverwriteRep! */ \ + ListRepIncrRefs(repPtr_); \ + TclFreeInternalRep(objPtr_); \ + TclInvalidateStringRep(objPtr_); \ + ListObjStompRep(objPtr_, repPtr_); \ + } while (0) -#ifndef TCL_MIN_ELEMENT_GROWTH -#define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *) +/* + *------------------------------------------------------------------------ + * + * ListSpanNew -- + * + * Allocates and initializes memory for a new ListSpan. The reference + * count on the returned struct is 0. + * + * Results: + * Non-NULL pointer to the allocated ListSpan. + * + * Side effects: + * The function will panic on memory allocation failure. + * + *------------------------------------------------------------------------ + */ +static inline ListSpan * +ListSpanNew( + ListSizeT firstSlot, /* Starting slot index of the span */ + ListSizeT numSlots) /* Number of slots covered by the span */ +{ + ListSpan *spanPtr = (ListSpan *) Tcl_Alloc(sizeof(*spanPtr)); + spanPtr->refCount = 0; + spanPtr->spanStart = firstSlot; + spanPtr->spanLength = numSlots; + return spanPtr; +} + +/* + *------------------------------------------------------------------------ + * + * ListSpanIncrRefs -- + * + * Increments the reference count on the spanPtr + * + * Results: + * None. + * + * Side effects: + * The obvious. + * + *------------------------------------------------------------------------ + */ + +static inline void +ListSpanIncrRefs(ListSpan *spanPtr) +{ + spanPtr->refCount += 1; +} + +/* + *------------------------------------------------------------------------ + * + * ListSpanDecrRefs -- + * + * Decrements the reference count on a span, freeing the memory if + * it drops to zero or less. + * + * Results: + * None. + * + * Side effects: + * The memory may be freed. + * + *------------------------------------------------------------------------ + */ + +static inline void +ListSpanDecrRefs(ListSpan *spanPtr) +{ + if (spanPtr->refCount <= 1) { + Tcl_Free(spanPtr); + } else { + spanPtr->refCount -= 1; + } +} + +/* + *------------------------------------------------------------------------ + * + * ListSpanMerited -- + * + * Creation of a new list may sometimes be done as a span on existing + * storage instead of allocating new. The tradeoff is that if the + * original list is released, the new span-based list may hold on to + * more memory than desired. This function implements heuristics for + * deciding which option is better. + * + * Results: + * Returns non-0 if a span-based list is likely to be more optimal + * and 0 if not. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------ + */ + +static inline int +ListSpanMerited( + ListSizeT length, /* Length of the proposed span */ + ListSizeT usedStorageLength, /* Number of slots currently in used */ + ListSizeT allocatedStorageLength) /* Length of the currently allocation */ +{ + /* + TODO + - heuristics thresholds need to be determined + - currently, information about the sharing (ref count) of existing + storage is not passed. Perhaps it should be. For example if the + existing storage has a "large" ref count, then it might make sense + to do even a small span. + */ +#ifndef TCL_LIST_SPAN_MINSIZE /* May be set on build line */ +#define TCL_LIST_SPAN_MINSIZE 101 #endif - + + if (length < TCL_LIST_SPAN_MINSIZE) + return 0;/* No span for small lists */ + if (length < (allocatedStorageLength/2 - allocatedStorageLength/8)) + return 0; /* No span if less than 3/8 of allocation */ + if (length < usedStorageLength / 2) + return 0; /* No span if less than half current storage */ + + return 1; +} + /* - *---------------------------------------------------------------------- + *------------------------------------------------------------------------ + * + * ListStoreUpSize -- + * + * For reasons of efficiency, extra space is allocated for a ListStore + * compared to what was requested. This function calculates how many + * slots should actually be allocated for a given request size. + * + * Results: + * Number of slots to allocate. + * + * Side effects: + * None. * - * NewListInternalRep -- + *------------------------------------------------------------------------ + */ +static inline ListSizeT +ListStoreUpSize(ListSizeT numSlotsRequested) { + /* TODO -how much extra? May be double only for smaller requests? */ + return numSlotsRequested < (LIST_MAX / 2) ? 2 * numSlotsRequested + : LIST_MAX; +} + +/* + *------------------------------------------------------------------------ * - * Creates a 'List' structure with space for 'objc' elements. 'objc' must - * be > 0. If 'objv' is not NULL, The list is initialized with first - * 'objc' values in that array. Otherwise the list is initialized to have - * 0 elements, with space to add 'objc' more. Flag value 'p' indicates - * how to behave on failure. + * ListRepFreeUnreferenced -- * - * Value + * Inline wrapper for ListRepUnsharedFreeUnreferenced that does quick checks + * before calling it. * - * A new 'List' structure with refCount 0. If some failure - * prevents this NULL is returned if 'p' is 0 , and 'Tcl_Panic' - * is called if it is not. + * IMPORTANT: this function must not be called on an internal + * representation of a Tcl_Obj that is itself shared. * - * Effect + * Results: + * None. * - * The refCount of each value in 'objv' is incremented as it is added - * to the list. + * Side effects: + * See comments for ListRepUnsharedFreeUnreferenced. * - *---------------------------------------------------------------------- + *------------------------------------------------------------------------ + */ +static inline void +ListRepFreeUnreferenced(const ListRep *repPtr) +{ + if (! ListRepIsShared(repPtr) && repPtr->spanPtr) { + ListRepUnsharedFreeUnreferenced(repPtr); + } +} + +/* + *------------------------------------------------------------------------ + * + * ObjArrayIncrRefs -- + * + * Increments the reference counts for Tcl_Obj's in a subarray. + * + * Results: + * None. + * + * Side effects: + * As above. + * + *------------------------------------------------------------------------ + */ +static inline void +ObjArrayIncrRefs( + Tcl_Obj * const *objv, /* Pointer to the array */ + ListSizeT startIdx, /* Starting index of subarray within objv */ + ListSizeT count) /* Number of elements in the subarray */ +{ + Tcl_Obj * const *end; + LIST_INDEX_ASSERT(startIdx); + LIST_COUNT_ASSERT(count); + objv += startIdx; + end = objv + count; + while (objv < end) { + Tcl_IncrRefCount(*objv); + ++objv; + } +} + +/* + *------------------------------------------------------------------------ + * + * ObjArrayDecrRefs -- + * + * Decrements the reference counts for Tcl_Obj's in a subarray. + * + * Results: + * None. + * + * Side effects: + * As above. + * + *------------------------------------------------------------------------ + */ +static inline void +ObjArrayDecrRefs( + Tcl_Obj * const *objv, /* Pointer to the array */ + ListSizeT startIdx, /* Starting index of subarray within objv */ + ListSizeT count) /* Number of elements in the subarray */ +{ + Tcl_Obj * const *end; + LIST_INDEX_ASSERT(startIdx); + LIST_COUNT_ASSERT(count); + objv += startIdx; + end = objv + count; + while (objv < end) { + Tcl_DecrRefCount(*objv); + ++objv; + } +} + +/* + *------------------------------------------------------------------------ + * + * ObjArrayCopy -- + * + * Copies an array of Tcl_Obj* pointers. + * + * Results: + * None. + * + * Side effects: + * Reference counts on copied Tcl_Obj's are incremented. + * + *------------------------------------------------------------------------ + */ +static inline void +ObjArrayCopy( + Tcl_Obj **to, /* Destination */ + ListSizeT count, /* Number of pointers to copy */ + Tcl_Obj *const from[]) /* Source array of Tcl_Obj* */ +{ + Tcl_Obj **end; + LIST_COUNT_ASSERT(count); + end = to + count; + /* TODO - would memmove followed by separate IncrRef loop be faster? */ + while (to < end) { + Tcl_IncrRefCount(*from); + *to++ = *from++; + } +} + +/* + *------------------------------------------------------------------------ + * + * MemoryAllocationError -- + * + * Generates a memory allocation failure error. + * + * Results: + * Always TCL_ERROR. + * + * Side effects: + * Error message and code are stored in the interpreter if not NULL. + * + *------------------------------------------------------------------------ + */ +static int +MemoryAllocationError( + Tcl_Interp *interp, /* Interpreter for error message. May be NULL */ + size_t size) /* Size of attempted allocation that failed */ +{ + if (interp != NULL) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf( + "list construction failed: unable to alloc %" TCL_LL_MODIFIER + "u bytes", + (Tcl_WideInt)size)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------ + * + * ListLimitExceeded -- + * + * Generates an error for exceeding maximum list size. + * + * Results: + * Always TCL_ERROR. + * + * Side effects: + * Error message and code are stored in the interpreter if not NULL. + * + *------------------------------------------------------------------------ + */ +static int +ListLimitExceededError(Tcl_Interp *interp) +{ + if (interp != NULL) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("max length of a Tcl list (%" TCL_Z_MODIFIER "u) elements) exceeded", + LIST_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------ + * + * ListRepUnsharedShiftDown -- + * + * Shifts the "in-use" contents in the ListStore for a ListRep down + * by the given number of slots. The ListStore must be unshared and + * the free space at the front of the storage area must be big enough. + * It is the caller's responsibility to check. + * + * Results: + * None. + * + * Side effects: + * The contents of the ListRep's ListStore area are shifted down in the + * storage area. The ListRep's ListSpan is updated accordingly. + * + *------------------------------------------------------------------------ + */ +static inline void +ListRepUnsharedShiftDown(ListRep *repPtr, ListSizeT shiftCount) +{ + ListStore *storePtr; + + LISTREP_CHECK(repPtr); + LIST_ASSERT(!ListRepIsShared(repPtr)); + + storePtr = repPtr->storePtr; + + LIST_COUNT_ASSERT(shiftCount); + LIST_ASSERT(storePtr->firstUsed >= shiftCount); + + memmove(&storePtr->slots[storePtr->firstUsed - shiftCount], + &storePtr->slots[storePtr->firstUsed], + storePtr->numUsed * sizeof(Tcl_Obj *)); + storePtr->firstUsed -= shiftCount; + if (repPtr->spanPtr) { + repPtr->spanPtr->spanStart -= shiftCount; + LIST_ASSERT(repPtr->spanPtr->spanLength == storePtr->numUsed); + } else { + /* + * If there was no span, firstUsed must have been 0 (Invariant) + * AND shiftCount must have been 0 (<= firstUsed on call) + * In other words, this would have been a no-op + */ + + LIST_ASSERT(storePtr->firstUsed == 0); + LIST_ASSERT(shiftCount == 0); + } + + LISTREP_CHECK(repPtr); +} + +/* + *------------------------------------------------------------------------ + * + * ListRepUnsharedShiftUp -- + * + * Shifts the "in-use" contents in the ListStore for a ListRep up + * by the given number of slots. The ListStore must be unshared and + * the free space at the back of the storage area must be big enough. + * It is the caller's responsibility to check. + * TODO - this function is not currently used. + * + * Results: + * None. + * + * Side effects: + * The contents of the ListRep's ListStore area are shifted up in the + * storage area. The ListRep's ListSpan is updated accordingly. + * + *------------------------------------------------------------------------ */ +static inline void +ListRepUnsharedShiftUp(ListRep *repPtr, ListSizeT shiftCount) +{ + ListStore *storePtr; + + LISTREP_CHECK(repPtr); + LIST_ASSERT(!ListRepIsShared(repPtr)); + LIST_COUNT_ASSERT(shiftCount); + + storePtr = repPtr->storePtr; + LIST_ASSERT((storePtr->firstUsed + storePtr->numUsed + shiftCount) + <= storePtr->numAllocated); + + memmove(&storePtr->slots[storePtr->firstUsed + shiftCount], + &storePtr->slots[storePtr->firstUsed], + storePtr->numUsed * sizeof(Tcl_Obj *)); + storePtr->firstUsed += shiftCount; + if (repPtr->spanPtr) { + repPtr->spanPtr->spanStart += shiftCount; + } else { + /* No span means entire original list is span */ + /* Should have been zero before shift - Invariant TBD */ + LIST_ASSERT(storePtr->firstUsed == shiftCount); + repPtr->spanPtr = ListSpanNew(shiftCount, storePtr->numUsed); + } -static List * -NewListInternalRep( - size_t objc, + LISTREP_CHECK(repPtr); +} + +#ifdef ENABLE_LIST_ASSERTS /* Else gcc complains about unused static */ +/* + *------------------------------------------------------------------------ + * + * ListRepValidate -- + * + * Checks all invariants for a ListRep. + * + * Results: + * None. + * + * Side effects: + * Panics (assertion failure) if any invariant is not met. + * + *------------------------------------------------------------------------ + */ +static void +ListRepValidate(const ListRep *repPtr) +{ + ListStore *storePtr = repPtr->storePtr; + + (void)storePtr; /* To stop gcc from whining about unused vars */ + + /* Separate each condition so line number gives exact reason for failure */ + LIST_ASSERT(storePtr != NULL); + LIST_ASSERT(storePtr->numAllocated >= 0); + LIST_ASSERT(storePtr->numAllocated <= LIST_MAX); + LIST_ASSERT(storePtr->firstUsed >= 0); + LIST_ASSERT(storePtr->firstUsed < storePtr->numAllocated); + LIST_ASSERT(storePtr->numUsed >= 0); + LIST_ASSERT(storePtr->numUsed <= storePtr->numAllocated); + LIST_ASSERT(storePtr->firstUsed + <= (storePtr->numAllocated - storePtr->numUsed)); + +#if 0 && defined(LIST_MEM_DEBUG) + /* Corresponding zeroing out not implemented yet */ + for (i = 0; i < storePtr->firstUsed; ++i) { + LIST_ASSERT(storePtr->slots[i] == NULL); + } + for (i = storePtr->firstUsed + storePtr->numUsed; + i < storePtr->numAllocated; + ++i) { + LIST_ASSERT(storePtr->slots[i] == NULL); + } +#endif + + if (! ListRepIsShared(repPtr)) { + /* + * If this is the only reference and there is no span, then store + * occupancy must begin at 0 + */ + LIST_ASSERT(repPtr->spanPtr || repPtr->storePtr->firstUsed == 0); + } + + LIST_ASSERT(ListRepStart(repPtr) >= storePtr->firstUsed); + LIST_ASSERT(ListRepLength(repPtr) <= storePtr->numUsed); + LIST_ASSERT(ListRepStart(repPtr) + <= (storePtr->firstUsed + storePtr->numUsed - ListRepLength(repPtr))); + +} +#endif /* ENABLE_LIST_ASSERTS */ + +/* + *---------------------------------------------------------------------- + * + * ListStoreNew -- + * + * Allocates a new ListStore with space for at least objc elements. objc + * must be > 0. If objv!=NULL, initializes with the first objc values + * in that array. If objv==NULL, initalize 0 elements, with space + * to add objc more. + * + * Normally the function allocates the exact space requested unless + * the flags arguments has any LISTREP_SPACE_* + * bits set. See the comments for those #defines. + * + * Results: + * On success, a pointer to the allocated ListStore is returned. + * On allocation failure, panics if LISTREP_PANIC_ON_FAIL is set in + * flags; otherwise returns NULL. + * + * Side effects: + * The ref counts of the elements in objv are incremented on success + * since the returned ListStore references them. + * + *---------------------------------------------------------------------- + */ +static ListStore * +ListStoreNew( + ListSizeT objc, Tcl_Obj *const objv[], - size_t p) + int flags) { - List *listRepPtr; + ListStore *storePtr; + ListSizeT capacity; - listRepPtr = (List *)Tcl_AttemptAlloc(LIST_SIZE(objc)); - if (listRepPtr == NULL) { - if (p) { - Tcl_Panic("list creation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", + /* + * First check to see if we'd overflow and try to allocate an object + * larger than our memory allocator allows. + */ + if (objc > LIST_MAX) { + if (flags & LISTREP_PANIC_ON_FAIL) { + Tcl_Panic("max length of a Tcl list (%" TCL_Z_MODIFIER "u elements) exceeded", + LIST_MAX); + } + return NULL; + } + + if (flags & LISTREP_SPACE_FLAGS) { + capacity = ListStoreUpSize(objc); + } else { + capacity = objc; + } + + storePtr = (ListStore *)Tcl_AttemptAlloc(LIST_SIZE(capacity)); + if (storePtr == NULL && capacity != objc) { + capacity = objc; /* Try allocating exact size */ + storePtr = (ListStore *)Tcl_AttemptAlloc(LIST_SIZE(capacity)); + } + if (storePtr == NULL) { + if (flags & LISTREP_PANIC_ON_FAIL) { + Tcl_Panic("list creation failed: unable to alloc %u bytes", LIST_SIZE(objc)); } return NULL; } - listRepPtr->canonicalFlag = 0; - listRepPtr->refCount = 0; - listRepPtr->maxElemCount = objc; + storePtr->refCount = 0; + storePtr->flags = 0; + storePtr->numAllocated = capacity; + if (capacity == objc) { + storePtr->firstUsed = 0; + } else { + ListSizeT extra = capacity - objc; + int spaceFlags = flags & LISTREP_SPACE_FLAGS; + if (spaceFlags == LISTREP_SPACE_ONLY_BACK) { + storePtr->firstUsed = 0; + } else if (spaceFlags == LISTREP_SPACE_FAVOR_FRONT) { + /* Leave more space in the front */ + storePtr->firstUsed = + extra - (extra / 4); /* NOT same as 3*extra/4 */ + } else if (spaceFlags == LISTREP_SPACE_FAVOR_BACK) { + /* Leave more space in the back */ + storePtr->firstUsed = extra / 4; + } else { + /* Apportion equally */ + storePtr->firstUsed = extra / 2; + } + } if (objv) { - Tcl_Obj **elemPtrs; - size_t i; - - listRepPtr->elemCount = objc; - elemPtrs = listRepPtr->elements; - for (i = 0; i < objc; i++) { - elemPtrs[i] = objv[i]; - Tcl_IncrRefCount(elemPtrs[i]); - } + storePtr->numUsed = objc; + ObjArrayCopy(&storePtr->slots[storePtr->firstUsed], objc, objv); } else { - listRepPtr->elemCount = 0; + storePtr->numUsed = 0; } - return listRepPtr; + + return storePtr; } - + +/* + *------------------------------------------------------------------------ + * + * ListStoreReallocate -- + * + * Reallocates the memory for a ListStore. + * + * Results: + * Pointer to the ListStore which may be the same as storePtr or pointer + * to a new block of memory. On reallocation failure, NULL is returned. + * + * + * Side effects: + * The memory pointed to by storePtr is freed if it a new block has to + * be returned. + * + * + *------------------------------------------------------------------------ + */ +ListStore * +ListStoreReallocate (ListStore *storePtr, ListSizeT numSlots) +{ + ListSizeT newCapacity; + ListStore *newStorePtr; + + newCapacity = ListStoreUpSize(numSlots); + newStorePtr = + (ListStore *)Tcl_AttemptRealloc(storePtr, LIST_SIZE(newCapacity)); + if (newStorePtr == NULL) { + newCapacity = numSlots; + newStorePtr = (ListStore *)Tcl_AttemptRealloc(storePtr, + LIST_SIZE(newCapacity)); + if (newStorePtr == NULL) + return NULL; + } + /* Only the capacity has changed, fix it in the header */ + newStorePtr->numAllocated = newCapacity; + return newStorePtr; +} + /* *---------------------------------------------------------------------- * - * AttemptNewList -- + * ListRepInit -- * - * Like NewListInternalRep, but additionally sets an error message on failure. + * Initializes a ListRep to hold a list internal representation + * with space for objc elements. + * + * objc must be > 0. If objv!=NULL, initializes with the first objc + * values in that array. If objv==NULL, initalize list internal rep to + * have 0 elements, with space to add objc more. + * + * Normally the function allocates the exact space requested unless + * the flags arguments has one of the LISTREP_SPACE_* bits set. + * See the comments for those #defines. + * + * The reference counts of the ListStore and ListSpan (if present) + * pointed to by the initialized repPtr are set to zero. + * Caller has to manage them as necessary. + * + * Results: + * On success, TCL_OK is returned with *listRepPtr initialized. + * On failure, panics if LISTREP_PANIC_ON_FAIL is set in flags; otherwise + * returns TCL_ERROR with *listRepPtr fields set to NULL. + * + * Side effects: + * The ref counts of the elements in objv are incremented since the + * resulting list now refers to them. * *---------------------------------------------------------------------- */ +static int +ListRepInit( + ListSizeT objc, + Tcl_Obj *const objv[], + int flags, + ListRep *repPtr + ) +{ + ListStore *storePtr; + + /* + * The whole list implementation has an implicit assumption that lenths + * and indices used a signed integer type. Tcl9 API's currently use + * unsigned types. This assert is to remind that need to review code + * when adapting for Tcl9. + */ + LIST_ASSERT(((ListSizeT)-1) < 0); + + storePtr = ListStoreNew(objc, objv, flags); + if (storePtr) { + repPtr->storePtr = storePtr; + if (storePtr->firstUsed == 0) { + repPtr->spanPtr = NULL; + } else { + repPtr->spanPtr = + ListSpanNew(storePtr->firstUsed, storePtr->numUsed); + } + return TCL_OK; + } + /* + * Initialize to keep gcc happy at the call site. Else it complains + * about possibly uninitialized use. + */ + repPtr->storePtr = NULL; + repPtr->spanPtr = NULL; + return TCL_ERROR; +} -static List * -AttemptNewList( +/* + *---------------------------------------------------------------------- + * + * ListRepInitAttempt -- + * + * Creates a list internal rep with space for objc elements. See + * ListRepInit for requirements for parameters (in particular objc must + * be > 0). This function only adds error messages to the interpreter if + * not NULL. + * + * The reference counts of the ListStore and ListSpan (if present) + * pointed to by the initialized repPtr are set to zero. + * Caller has to manage them as necessary. + * + * Results: + * On success, TCL_OK is returned with *listRepPtr initialized. + * On allocation failure, returnes TCL_ERROR with an error message + * in the interpreter if non-NULL. + * + * Side effects: + * The ref counts of the elements in objv are incremented since the + * resulting list now refers to them. + * + *---------------------------------------------------------------------- + */ +static int +ListRepInitAttempt( Tcl_Interp *interp, - size_t objc, - Tcl_Obj *const objv[]) + ListSizeT objc, + Tcl_Obj *const objv[], + ListRep *repPtr) { - List *listRepPtr = NewListInternalRep(objc, objv, 0); + int result = ListRepInit(objc, objv, 0, repPtr); - if (interp != NULL && listRepPtr == NULL) { + if (result != TCL_OK && interp != NULL) { if (objc > LIST_MAX) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max length of a Tcl list (%d elements) exceeded", - LIST_MAX)); + ListLimitExceededError(interp); } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "list creation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", - LIST_SIZE(objc))); + MemoryAllocationError(interp, LIST_SIZE(objc)); } - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } - return listRepPtr; + return result; } - + +/* + *------------------------------------------------------------------------ + * + * ListRepClone -- + * + * Does a deep clone of an existing ListRep. + * + * Normally the function allocates the exact space needed unless + * the flags arguments has one of the LISTREP_SPACE_* bits set. + * See the comments for those #defines. + * + * Results: + * None. + * + * Side effects: + * The toRepPtr location is initialized with the ListStore and ListSpan + * (if needed) containing a copy of the list elements in fromRepPtr. + * The function will panic if memory cannot be allocated. + * + *------------------------------------------------------------------------ + */ +static void +ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags) +{ + Tcl_Obj **fromObjs; + ListSizeT numFrom; + + ListRepElements(fromRepPtr, numFrom, fromObjs); + ListRepInit(numFrom, fromObjs, flags | LISTREP_PANIC_ON_FAIL, toRepPtr); +} + +/* + *------------------------------------------------------------------------ + * + * ListRepUnsharedFreeUnreferenced -- + * + * Frees any Tcl_Obj's from the "in-use" area of the ListStore for a + * ListRep that are not actually references from any lists. + * + * IMPORTANT: this function must not be called on a shared internal + * representation or the internal representation of a shared Tcl_Obj. + * + * Results: + * None. + * + * Side effects: + * The firstUsed and numUsed fields of the ListStore are updated to + * reflect the new "in-use" extent. + * + *------------------------------------------------------------------------ + */ + +static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr) +{ + ListSizeT count; + ListStore *storePtr; + ListSpan *spanPtr; + + LIST_ASSERT(!ListRepIsShared(repPtr)); + LISTREP_CHECK(repPtr); + + storePtr = repPtr->storePtr; + spanPtr = repPtr->spanPtr; + if (spanPtr == NULL) { + LIST_ASSERT(storePtr->firstUsed == 0); /* Invariant TBD */ + return; + } + + /* Collect garbage at front */ + count = spanPtr->spanStart - storePtr->firstUsed; + LIST_COUNT_ASSERT(count); + if (count > 0) { + ObjArrayDecrRefs(storePtr->slots, storePtr->firstUsed, count); + storePtr->firstUsed = spanPtr->spanStart; + LIST_ASSERT(storePtr->numUsed >= count); + storePtr->numUsed -= count; + } + + /* Collect garbage at back */ + count = (storePtr->firstUsed + storePtr->numUsed) + - (spanPtr->spanStart + spanPtr->spanLength); + LIST_COUNT_ASSERT(count); + if (count > 0) { + ObjArrayDecrRefs( + storePtr->slots, spanPtr->spanStart + spanPtr->spanLength, count); + LIST_ASSERT(storePtr->numUsed >= count); + storePtr->numUsed -= count; + } + + LIST_ASSERT(ListRepStart(repPtr) == storePtr->firstUsed); + LIST_ASSERT(ListRepLength(repPtr) == storePtr->numUsed); + LISTREP_CHECK(repPtr); +} + /* *---------------------------------------------------------------------- * * Tcl_NewListObj -- * - * Creates a new list object and adds values to it. When TCL_MEM_DEBUG is - * defined, 'Tcl_DbNewListObj' is called instead. - * - * Value + * This function is normally called when not debugging: i.e., when + * TCL_MEM_DEBUG is not defined. It creates a new list object from an + * (objc,objv) array: that is, each of the objc elements of the array + * referenced by objv is inserted as an element into a new Tcl object. * - * A new list 'Tcl_Obj' to which is appended values from 'objv', or if - * 'objc' is less than or equal to zero, a list 'Tcl_Obj' having no - * elements. The string representation of the new 'Tcl_Obj' is set to - * NULL. The refCount of the list is 0. + * When TCL_MEM_DEBUG is defined, this function just returns the result + * of calling the debugging version Tcl_DbNewListObj. * - * Effect + * Results: + * A new list object is returned that is initialized from the object + * pointers in objv. If objc is less than or equal to zero, an empty + * object is returned. The new object's string representation is left + * NULL. The resulting new list object has ref count 0. * - * The refCount of each elements in 'objv' is incremented as it is added - * to the list. + * Side effects: + * The ref counts of the elements in objv are incremented since the + * resulting list now refers to them. * *---------------------------------------------------------------------- */ @@ -195,7 +1090,7 @@ AttemptNewList( Tcl_Obj * Tcl_NewListObj( - size_t objc, /* Count of objects referenced by objv. */ + ListSizeT objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ { return Tcl_DbNewListObj(objc, objv, "unknown", 0); @@ -205,45 +1100,50 @@ Tcl_NewListObj( Tcl_Obj * Tcl_NewListObj( - size_t objc, /* Count of objects referenced by objv. */ + size_t objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ { - List *listRepPtr; - Tcl_Obj *listPtr; + ListRep listRep; + Tcl_Obj *listObj; - TclNewObj(listPtr); + TclNewObj(listObj); if (objc + 1 <= 1) { - return listPtr; + return listObj; } - /* - * Create the internal rep. - */ - - listRepPtr = NewListInternalRep(objc, objv, 1); + ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep); + ListObjReplaceRepAndInvalidate(listObj, &listRep); - /* - * Now create the object. - */ - - TclInvalidateStringRep(listPtr); - ListSetInternalRep(listPtr, listRepPtr); - return listPtr; + return listObj; } #endif /* if TCL_MEM_DEBUG */ - + /* *---------------------------------------------------------------------- * - * Tcl_DbNewListObj -- + * Tcl_DbNewListObj -- + * + * This function is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. It creates new list objects. It is the same + * as the Tcl_NewListObj function above except that it calls + * Tcl_DbCkalloc directly with the file name and line number from its + * caller. This simplifies debugging since then the [memory active] + * command will report the correct file name and line number when + * reporting objects that haven't been freed. + * + * When TCL_MEM_DEBUG is not defined, this function just returns the + * result of calling Tcl_NewListObj. * - * Like 'Tcl_NewListObj', but it calls Tcl_DbCkalloc directly with the - * file name and line number from its caller. This simplifies debugging - * since the [memory active] command will report the correct file - * name and line number when reporting objects that haven't been freed. + * Results: + * A new list object is returned that is initialized from the object + * pointers in objv. If objc is less than or equal to zero, an empty + * object is returned. The new object's string representation is left + * NULL. The new list object has ref count 0. * - * When TCL_MEM_DEBUG is not defined, 'Tcl_NewListObj' is called instead. + * Side effects: + * The ref counts of the elements in objv are incremented since the + * resulting list now refers to them. * *---------------------------------------------------------------------- */ @@ -252,91 +1152,188 @@ Tcl_NewListObj( Tcl_Obj * Tcl_DbNewListObj( - size_t objc, /* Count of objects referenced by objv. */ + ListSizeT objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[], /* An array of pointers to Tcl objects. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { - Tcl_Obj *listPtr; - List *listRepPtr; + Tcl_Obj *listObj; + ListRep listRep; + + TclDbNewObj(listObj, file, line); + + if (objc <= 0) { + return listObj; + } + + ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep); + ListObjReplaceRepAndInvalidate(listObj, &listRep); + + return listObj; +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_DbNewListObj( + size_t objc, /* Count of objects referenced by objv. */ + Tcl_Obj *const objv[], /* An array of pointers to Tcl objects. */ + TCL_UNUSED(const char *) /*file*/, + TCL_UNUSED(int) /*line*/) +{ + return Tcl_NewListObj(objc, objv); +} +#endif /* TCL_MEM_DEBUG */ - TclDbNewObj(listPtr, file, line); +/* + *------------------------------------------------------------------------ + * + * TclNewListObj2 -- + * + * Create a new Tcl_Obj list comprising of the concatenation of two + * Tcl_Obj* arrays. + * TODO - currently this function is not used within tclListObj but + * need to see if it would be useful in other files that preallocate + * lists and then append. + * + * Results: + * Non-NULL pointer to the allocate Tcl_Obj. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------ + */ +Tcl_Obj * +TclNewListObj2( + ListSizeT objc1, /* Count of objects referenced by objv1. */ + Tcl_Obj *const objv1[], /* First array of pointers to Tcl objects. */ + ListSizeT objc2, /* Count of objects referenced by objv2. */ + Tcl_Obj *const objv2[] /* Second array of pointers to Tcl objects. */ +) +{ + Tcl_Obj *listObj; + ListStore *storePtr; + ListSizeT objc = objc1 + objc2; - if (objc + 1 <= 1) { - return listPtr; + listObj = Tcl_NewListObj(objc, NULL); + if (objc == 0) { + return listObj; /* An empty object */ } + LIST_ASSERT_TYPE(listObj); - /* - * Create the internal rep. - */ - - listRepPtr = NewListInternalRep(objc, objv, 1); + storePtr = ListObjStorePtr(listObj); - /* - * Now create the object. - */ + LIST_ASSERT(ListObjSpanPtr(listObj) == NULL); + LIST_ASSERT(storePtr->firstUsed == 0); + LIST_ASSERT(storePtr->numUsed == 0); + LIST_ASSERT(storePtr->numAllocated >= objc); - TclInvalidateStringRep(listPtr); - ListSetInternalRep(listPtr, listRepPtr); - - return listPtr; + if (objc1) { + ObjArrayCopy(storePtr->slots, objc1, objv1); + } + if (objc2) { + ObjArrayCopy(&storePtr->slots[objc1], objc2, objv2); + } + storePtr->numUsed = objc; + return listObj; } -#else /* if not TCL_MEM_DEBUG */ +/* + *---------------------------------------------------------------------- + * + * TclListObjGetRep -- + * + * This function returns a copy of the ListRep stored + * as the internal representation of an object. The reference + * counts of the (ListStore, ListSpan) contained in the representation + * are NOT incremented. + * + * Results: + * The return value is normally TCL_OK; in this case *listRepP + * is set to a copy of the descriptor stored as the internal + * representation of the Tcl_Obj containing a list. if listPtr does not + * refer to a list object and the object can not be converted to one, + * TCL_ERROR is returned and an error message will be left in the + * interpreter's result if interp is not NULL. + * + * Side effects: + * The possible conversion of the object referenced by listPtr + * to a list object. *repPtr is initialized to the internal rep + * if result is TCL_OK, or set to NULL on error. + *---------------------------------------------------------------------- + */ -Tcl_Obj * -Tcl_DbNewListObj( - size_t objc, /* Count of objects referenced by objv. */ - Tcl_Obj *const objv[], /* An array of pointers to Tcl objects. */ - TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) +static int +TclListObjGetRep( + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *listObj, /* List object for which an element array is + * to be returned. */ + ListRep *repPtr) /* Location to store descriptor */ { - return Tcl_NewListObj(objc, objv); + if (!TclHasInternalRep(listObj, &tclListType)) { + int result; + result = SetListFromAny(interp, listObj); + if (result != TCL_OK) { + /* Init to keep gcc happy wrt uninitialized fields at call site */ + repPtr->storePtr = NULL; + repPtr->spanPtr = NULL; + return result; + } + } + ListObjGetRep(listObj, repPtr); + LISTREP_CHECK(repPtr); + return TCL_OK; } -#endif /* TCL_MEM_DEBUG */ - + /* *---------------------------------------------------------------------- * * Tcl_SetListObj -- * - * Like 'Tcl_NewListObj', but operates on an existing 'Tcl_Obj'instead of - * creating a new one. + * Modify an object to be a list containing each of the objc elements of + * the object array referenced by objv. + * + * Results: + * None. + * + * Side effects: + * The object is made a list object and is initialized from the object + * pointers in objv. If objc is less than or equal to zero, an empty + * object is returned. The new object's string representation is left + * NULL. The ref counts of the elements in objv are incremented since the + * list now refers to them. The object's old string and internal + * representations are freed and its type is set NULL. * *---------------------------------------------------------------------- */ - void Tcl_SetListObj( Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - size_t objc, /* Count of objects referenced by objv. */ + size_t objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ { - List *listRepPtr; - if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetListObj"); } /* - * Free any old string rep and any internal rep for the old type. - */ - - TclFreeInternalRep(objPtr); - TclInvalidateStringRep(objPtr); - - /* * Set the object's type to "list" and initialize the internal rep. * However, if there are no elements to put in the list, just give the - * object an empty string rep and a NULL type. + * object an empty string rep and a NULL type. NOTE ListRepInit must + * not be called with objc == 0! */ - if (objc > 0) { - listRepPtr = NewListInternalRep(objc, objv, 1); - ListSetInternalRep(objPtr, listRepPtr); + if (objc + 1 > 1) { + ListRep listRep; + /* TODO - perhaps ask for extra space? */ + ListRepInit(objc, objv, LISTREP_PANIC_ON_FAIL, &listRep); + ListObjReplaceRepAndInvalidate(objPtr, &listRep); } else { + TclFreeInternalRep(objPtr); + TclInvalidateStringRep(objPtr); Tcl_InitStringRep(objPtr, NULL, 0); } } @@ -346,20 +1343,18 @@ Tcl_SetListObj( * * TclListObjCopy -- * - * Creates a new 'Tcl_Obj' which is a pure copy of a list value. This - * provides for the C level a counterpart of the [lrange $list 0 end] - * command, while using internals details to be as efficient as possible. + * Makes a "pure list" copy of a list value. This provides for the C + * level a counterpart of the [lrange $list 0 end] command, while using + * internals details to be as efficient as possible. * - * Value - * - * The address of the new 'Tcl_Obj' which shares its internal - * representation with 'listPtr', and whose refCount is 0. If 'listPtr' - * is not actually a list, the value is NULL, and an error message is left - * in 'interp' if it is not NULL. - * - * Effect + * Results: + * Normally returns a pointer to a new Tcl_Obj, that contains the same + * list value as *listPtr does. The returned Tcl_Obj has a refCount of + * zero. If *listPtr does not hold a list, NULL is returned, and if + * interp is non-NULL, an error message is recorded there. * - * 'listPtr' is converted to a list if it isn't one already. + * Side effects: + * None. * *---------------------------------------------------------------------- */ @@ -367,137 +1362,254 @@ Tcl_SetListObj( Tcl_Obj * TclListObjCopy( Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *listPtr) /* List object for which an element array is + Tcl_Obj *listObj) /* List object for which an element array is * to be returned. */ { - Tcl_Obj *copyPtr; - List *listRepPtr; + Tcl_Obj *copyObj; - ListGetInternalRep(listPtr, listRepPtr); - if (NULL == listRepPtr) { - if (SetListFromAny(interp, listPtr) != TCL_OK) { + if (!TclHasInternalRep(listObj, &tclListType)) { + if (SetListFromAny(interp, listObj) != TCL_OK) { return NULL; } } - TclNewObj(copyPtr); - TclInvalidateStringRep(copyPtr); - DupListInternalRep(listPtr, copyPtr); - return copyPtr; + TclNewObj(copyObj); + TclInvalidateStringRep(copyObj); + DupListInternalRep(listObj, copyObj); + return copyObj; } /* - *---------------------------------------------------------------------- + *------------------------------------------------------------------------ * - * TclListObjRange -- + * ListRepRange -- * - * Makes a slice of a list value. - * *listPtr must be known to be a valid list. + * Initializes a ListRep as a range within the passed ListRep. + * The range limits are clamped to the list boundaries. * * Results: - * Returns a pointer to the sliced list. - * This may be a new object or the same object if not shared. + * None. * * Side effects: - * The possible conversion of the object referenced by listPtr - * to a list object. - * - *---------------------------------------------------------------------- + * The ListStore and ListSpan referenced by in the returned ListRep + * may or may not be the same as those passed in. For example, the + * ListStore may differ because the range is small enough that a new + * ListStore is more memory-optimal. The ListSpan may differ because + * it is NULL or shared. Regardless, reference counts on the returned + * values are not incremented. Generally, ListObjReplaceRepAndInvalidate may be + * used to store the new ListRep back into an object or a ListRepIncRefs + * followed by ListRepDecrRefs to free in case of errors. + * TODO WARNING:- this is not a very clean interface and easy for caller + * to get wrong. Better change it to pass in the source ListObj + * + *------------------------------------------------------------------------ */ - -Tcl_Obj * -TclListObjRange( - Tcl_Obj *listPtr, /* List object to take a range from. */ - size_t fromIdx, /* Index of first element to include. */ - size_t toIdx) /* Index of last element to include. */ +static void +ListRepRange( + ListRep *srcRepPtr, /* Contains source of the range */ + ListSizeT rangeStart, /* Index of first element to include */ + ListSizeT rangeEnd, /* Index of last element to include */ + int preserveSrcRep, /* If true, srcRepPtr contents must not be + modified (generally because a shared Tcl_Obj + references it) */ + ListRep *rangeRepPtr) /* Output. Must NOT be == srcRepPtr */ { - Tcl_Obj **elemPtrs; - size_t listLen, i, newLen; - List *listRepPtr; + Tcl_Obj **srcElems; + ListSizeT numSrcElems = ListRepLength(srcRepPtr); + ListSizeT rangeLen; + int doSpan; - TclListObjGetElementsM(NULL, listPtr, &listLen, &elemPtrs); + LISTREP_CHECK(srcRepPtr); - if (fromIdx == TCL_INDEX_NONE) { - fromIdx = 0; + /* Take the opportunity to garbage collect */ + /* TODO - we probably do not need the preserveSrcRep here unlike later */ + if (!preserveSrcRep) { + ListRepFreeUnreferenced(srcRepPtr); } - if (toIdx + 1 >= listLen + 1) { - toIdx = listLen-1; + + if (rangeStart < 0) { + rangeStart = 0; } - if (fromIdx + 1 > toIdx + 1) { - Tcl_Obj *obj; - TclNewObj(obj); - return obj; + if (rangeEnd >= numSrcElems) { + rangeEnd = numSrcElems - 1; } - - newLen = toIdx - fromIdx + 1; - - if (Tcl_IsShared(listPtr) || - ((ListRepPtr(listPtr)->refCount > 1))) { - return Tcl_NewListObj(newLen, &elemPtrs[fromIdx]); + if (rangeStart > rangeEnd) { + /* Empty list of capacity 1. */ + ListRepInit(1, NULL, LISTREP_PANIC_ON_FAIL, rangeRepPtr); + return; } - /* - * In-place is possible. - */ + rangeLen = rangeEnd - rangeStart + 1; /* - * Even if nothing below cause any changes, we still want the - * string-canonizing effect of [lrange 0 end]. + * We can create a range one of three ways: + * (1) Use a ListSpan referencing the current ListStore + * (2) Creating a new ListStore + * (3) Removing all elements outside the range in the current ListStore + * Option (3) may only be done if caller has not disallowed it AND + * the ListStore is not shared. + * + * The choice depends on heuristics related to speed and memory. + * TODO - heuristics below need to be measured and tuned. + * + * Note: Even if nothing below cause any changes, we still want the + * string-canonizing effect of [lrange 0 end] so the Tcl_Obj should not + * be returned as is even if the range encompasses the whole list. */ + doSpan = ListSpanMerited(rangeLen, + srcRepPtr->storePtr->numUsed, + srcRepPtr->storePtr->numAllocated); + + if (doSpan) { + /* Option 1 - because span would be most efficient */ + ListSizeT spanStart = ListRepStart(srcRepPtr) + rangeStart; + if (!preserveSrcRep && srcRepPtr->spanPtr + && srcRepPtr->spanPtr->refCount <= 1) { + /* If span is not shared reuse it */ + srcRepPtr->spanPtr->spanStart = spanStart; + srcRepPtr->spanPtr->spanLength = rangeLen; + *rangeRepPtr = *srcRepPtr; + } else { + /* Span not present or is shared - Allocate a new span */ + rangeRepPtr->storePtr = srcRepPtr->storePtr; + rangeRepPtr->spanPtr = ListSpanNew(spanStart, rangeLen); + } + /* + * We have potentially created a new internal representation that + * references the same storage as srcRep but not yet incremented its + * reference count. So do NOT call freezombies if preserveSrcRep + * is mandated. + */ + if (!preserveSrcRep) { + ListRepFreeUnreferenced(rangeRepPtr); + } + } else if (preserveSrcRep || ListRepIsShared(srcRepPtr)) { + /* Option 2 - span or modification in place not allowed/desired */ + ListRepElements(srcRepPtr, numSrcElems, srcElems); + /* TODO - allocate extra space? */ + ListRepInit(rangeLen, + &srcElems[rangeStart], + LISTREP_PANIC_ON_FAIL, + rangeRepPtr); + } else { + /* + * Option 3 - modify in place. Note that because of the invariant + * that spanless list stores must start at 0, we have to move + * everything to the front. + * TODO - perhaps if a span already exists, no need to move to front? + * or maybe no need to move all the way to the front? + * TODO - if range is small relative to allocation, allocate new? + */ + ListSizeT numAfterRangeEnd; - TclInvalidateStringRep(listPtr); - - /* - * Delete elements that should not be included. - */ + /* Asserts follow from call to ListRepFreeUnreferenced earlier */ + LIST_ASSERT(!preserveSrcRep); + LIST_ASSERT(!ListRepIsShared(srcRepPtr)); + LIST_ASSERT(ListRepStart(srcRepPtr) == srcRepPtr->storePtr->firstUsed); + LIST_ASSERT(ListRepLength(srcRepPtr) == srcRepPtr->storePtr->numUsed); - for (i = 0; i < fromIdx; i++) { - TclDecrRefCount(elemPtrs[i]); - } - for (i = toIdx + 1; i < (size_t)listLen; i++) { - TclDecrRefCount(elemPtrs[i]); - } + ListRepElements(srcRepPtr, numSrcElems, srcElems); - if (fromIdx > 0) { - memmove(elemPtrs, &elemPtrs[fromIdx], - (size_t) newLen * sizeof(Tcl_Obj*)); + /* Free leading elements outside range */ + if (rangeStart != 0) { + ObjArrayDecrRefs(srcElems, 0, rangeStart); + } + /* Ditto for trailing */ + numAfterRangeEnd = numSrcElems - (rangeEnd + 1); + LIST_ASSERT(numAfterRangeEnd + >= 0); /* Because numSrcElems > rangeEnd earlier */ + if (numAfterRangeEnd != 0) { + ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd); + } + memmove(&srcRepPtr->storePtr->slots[0], + &srcRepPtr->storePtr + ->slots[srcRepPtr->storePtr->firstUsed + rangeStart], + rangeLen * sizeof(Tcl_Obj *)); + srcRepPtr->storePtr->firstUsed = 0; + srcRepPtr->storePtr->numUsed = rangeLen; + srcRepPtr->storePtr->flags = 0; + rangeRepPtr->storePtr = srcRepPtr->storePtr; /* Note no incr ref */ + rangeRepPtr->spanPtr = NULL; } - listRepPtr = ListRepPtr(listPtr); - listRepPtr->elemCount = newLen; + /* TODO - call freezombies here if !preserveSrcRep? */ - return listPtr; + /* Note ref counts intentionally not incremented */ + LISTREP_CHECK(rangeRepPtr); + return; } - + /* *---------------------------------------------------------------------- * - * Tcl_ListObjGetElements -- - * - * Retreive the elements in a list 'Tcl_Obj'. + * TclListObjRange -- * - * Value + * Makes a slice of a list value. + * *listObj must be known to be a valid list. * - * TCL_OK + * Results: + * Returns a pointer to the sliced list. + * This may be a new object or the same object if not shared. + * Returns NULL if passed listObj was not a list and could not be + * converted to one. * - * A count of list elements is stored, 'objcPtr', And a pointer to the - * array of elements in the list is stored in 'objvPtr'. + * Side effects: + * The possible conversion of the object referenced by listPtr + * to a list object. * - * The elements accessible via 'objvPtr' should be treated as readonly - * and the refCount for each object is _not_ incremented; the caller - * must do that if it holds on to a reference. Furthermore, the - * pointer and length returned by this function may change as soon as - * any function is called on the list object. Be careful about - * retaining the pointer in a local data structure. + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclListObjRange( + Tcl_Obj *listObj, /* List object to take a range from. */ + size_t rangeStart, /* Index of first element to include. */ + size_t rangeEnd) /* Index of last element to include. */ +{ + ListRep listRep; + ListRep resultRep; + + int isShared; + if (TclListObjGetRep(NULL, listObj, &listRep) != TCL_OK) + return NULL; + + isShared = Tcl_IsShared(listObj); + + ListRepRange(&listRep, rangeStart, rangeEnd, isShared, &resultRep); + + if (isShared) { + TclNewObj(listObj); + } + ListObjReplaceRepAndInvalidate(listObj, &resultRep); + return listObj; +} + +/* + *---------------------------------------------------------------------- * - * TCL_ERROR + * Tcl_ListObjGetElements -- * - * 'listPtr' is not a valid list. An error message is left in the - * interpreter's result if 'interp' is not NULL. + * This function returns an (objc,objv) array of the elements in a list + * object. * - * Effect + * Results: + * The return value is normally TCL_OK; in this case *objcPtr is set to + * the count of list elements and *objvPtr is set to a pointer to an + * array of (*objcPtr) pointers to each list element. If listPtr does not + * refer to a list object and the object can not be converted to one, + * TCL_ERROR is returned and an error message will be left in the + * interpreter's result if interp is not NULL. + * + * The objects referenced by the returned array should be treated as + * readonly and their ref counts are _not_ incremented; the caller must + * do that if it holds on to a reference. Furthermore, the pointer and + * length returned by this function may change as soon as any function is + * called on the list object; be careful about retaining the pointer in a + * local data structure. * - * 'listPtr' is converted to a list object if it isn't one already. + * Side effects: + * The possible conversion of the object referenced by listPtr + * to a list object. * *---------------------------------------------------------------------- */ @@ -506,35 +1618,18 @@ TclListObjRange( int Tcl_ListObjGetElements( Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *listPtr, /* List object for which an element array is + Tcl_Obj *objPtr, /* List object for which an element array is * to be returned. */ size_t *objcPtr, /* Where to store the count of objects * referenced by objv. */ Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of * pointers to the list's objects. */ { - List *listRepPtr; - - ListGetInternalRep(listPtr, listRepPtr); - - if (listRepPtr == NULL) { - int result; - size_t length; + ListRep listRep; - (void) Tcl_GetStringFromObj(listPtr, &length); - if (length == 0) { - *objcPtr = 0; - *objvPtr = NULL; - return TCL_OK; - } - result = SetListFromAny(interp, listPtr); - if (result != TCL_OK) { - return result; - } - ListGetInternalRep(listPtr, listRepPtr); - } - *objcPtr = listRepPtr->elemCount; - *objvPtr = listRepPtr->elements; + if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK) + return TCL_ERROR; + ListRepElements(&listRep, *objcPtr, *objvPtr); return TCL_OK; } @@ -543,27 +1638,20 @@ Tcl_ListObjGetElements( * * Tcl_ListObjAppendList -- * - * Appends the elements of elemListPtr to those of listPtr. + * This function appends the elements in the list fromObj + * to toObj. toObj must not be shared else the function will panic. * - * Value - * - * TCL_OK - * - * Success. - * - * TCL_ERROR - * - * 'listPtr' or 'elemListPtr' are not valid lists. An error - * message is left in the interpreter's result if 'interp' is not NULL. - * - * Effect + * Results: + * The return value is normally TCL_OK. If fromObj or toObj do not + * refer to list values, TCL_ERROR is returned and an error message is + * left in the interpreter's result if interp is not NULL. * - * The reference count of each element of 'elemListPtr' as it is added to - * 'listPtr'. 'listPtr' and 'elemListPtr' are converted to 'tclListType' - * if they are not already. Appending the new elements may cause the - * array of element pointers in 'listObj' to grow. If any objects are - * appended to 'listPtr'. Any preexisting string representation of - * 'listPtr' is invalidated. + * Side effects: + * The reference counts of the elements in fromObj are incremented + * since the list now refers to them. toObj and fromObj are + * converted, if necessary, to list objects. Also, appending the new + * elements may cause toObj's array of element pointers to grow. + * toObj's old string representation, if any, is invalidated. * *---------------------------------------------------------------------- */ @@ -571,21 +1659,17 @@ Tcl_ListObjGetElements( int Tcl_ListObjAppendList( Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *listPtr, /* List object to append elements to. */ - Tcl_Obj *elemListPtr) /* List obj with elements to append. */ + Tcl_Obj *toObj, /* List object to append elements to. */ + Tcl_Obj *fromObj) /* List obj with elements to append. */ { size_t objc; Tcl_Obj **objv; - if (Tcl_IsShared(listPtr)) { + if (Tcl_IsShared(toObj)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList"); } - /* - * Pull the elements to append from elemListPtr. - */ - - if (TCL_OK != TclListObjGetElementsM(interp, elemListPtr, &objc, &objv)) { + if (TclListObjGetElementsM(interp, fromObj, &objc, &objv) != TCL_OK) { return TCL_ERROR; } @@ -594,249 +1678,241 @@ Tcl_ListObjAppendList( * Delete zero existing elements. */ - return Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, objc, objv); + return TclListObjAppendElements(interp, toObj, objc, objv); } - + /* - *---------------------------------------------------------------------- - * - * Tcl_ListObjAppendElement -- - * - * Like 'Tcl_ListObjAppendList', but Appends a single value to a list. + *------------------------------------------------------------------------ * - * Value + * TclListObjAppendElements -- * - * TCL_OK + * Appends multiple elements to a Tcl_Obj list object. If + * the passed Tcl_Obj is not a list object, it will be converted to one + * and an error raised if the conversion fails. * - * 'objPtr' is appended to the elements of 'listPtr'. + * The Tcl_Obj must not be shared though the internal representation + * may be. * - * TCL_ERROR - * - * listPtr does not refer to a list object and the object can not be - * converted to one. An error message will be left in the - * interpreter's result if interp is not NULL. - * - * Effect + * Results: + * On success, TCL_OK is returned with the specified elements appended. + * On failure, TCL_ERROR is returned with an error message in the + * interpreter if not NULL. * - * If 'listPtr' is not already of type 'tclListType', it is converted. - * The 'refCount' of 'objPtr' is incremented as it is added to 'listPtr'. - * Appending the new element may cause the the array of element pointers - * in 'listObj' to grow. Any preexisting string representation of - * 'listPtr' is invalidated. + * Side effects: + * None. * - *---------------------------------------------------------------------- + *------------------------------------------------------------------------ */ - -int -Tcl_ListObjAppendElement( + int TclListObjAppendElements ( Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *listPtr, /* List object to append objPtr to. */ - Tcl_Obj *objPtr) /* Object to append to listPtr's list. */ + Tcl_Obj *toObj, /* List object to append */ + size_t elemCount, /* Number of elements in elemObjs[] */ + Tcl_Obj * const elemObjv[]) /* Objects to append to toObj's list. */ { - List *listRepPtr, *newPtr = NULL; - size_t numElems, numRequired; - int needGrow, isShared, attempt; + ListRep listRep; + Tcl_Obj **toObjv; + size_t toLen; + size_t finalLen; - if (Tcl_IsShared(listPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement"); + if (Tcl_IsShared(toObj)) { + Tcl_Panic("%s called with shared object", "TclListObjAppendElements"); } - ListGetInternalRep(listPtr, listRepPtr); - if (listRepPtr == NULL) { - int result; - size_t length; - - (void) Tcl_GetStringFromObj(listPtr, &length); - if (length == 0) { - Tcl_SetListObj(listPtr, 1, &objPtr); - return TCL_OK; - } - result = SetListFromAny(interp, listPtr); - if (result != TCL_OK) { - return result; - } - ListGetInternalRep(listPtr, listRepPtr); - } + if (TclListObjGetRep(interp, toObj, &listRep) != TCL_OK) + return TCL_ERROR; /* Cannot be converted to a list */ - numElems = listRepPtr->elemCount; - numRequired = numElems + 1 ; - needGrow = (numRequired > listRepPtr->maxElemCount); - isShared = (listRepPtr->refCount > 1); + if (elemCount == 0) + return TCL_OK; /* Nothing to do. Note AFTER check for list above */ - if (numRequired > LIST_MAX) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max length of a Tcl list (%d elements) exceeded", - LIST_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } - return TCL_ERROR; + ListRepElements(&listRep, toLen, toObjv); + if (elemCount > LIST_MAX || toLen > (LIST_MAX - elemCount)) { + return ListLimitExceededError(interp); } - if (needGrow && !isShared) { + finalLen = toLen + elemCount; + if (!ListRepIsShared(&listRep)) { /* - * Need to grow + unshared internalrep => try to realloc + * Reuse storage if possible. Even if too small, realloc-ing instead + * of creating a new ListStore will save us on manipulating Tcl_Obj + * reference counts on the elements which is a substantial cost + * if the list is not small. */ + size_t numTailFree; - attempt = 2 * numRequired; - if (attempt <= LIST_MAX) { - newPtr = (List *)Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt)); - } - if (newPtr == NULL) { - attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH; - if (attempt > LIST_MAX) { - attempt = LIST_MAX; - } - newPtr = (List *)Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt)); - } - if (newPtr == NULL) { - attempt = numRequired; - newPtr = (List *)Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt)); - } - if (newPtr) { - listRepPtr = newPtr; - listRepPtr->maxElemCount = attempt; - needGrow = 0; - } - } - if (isShared || needGrow) { - Tcl_Obj **dst, **src = listRepPtr->elements; + ListRepFreeUnreferenced(&listRep); /* Collect garbage before checking room */ - /* - * Either we have a shared internalrep and we must copy to write, or we - * need to grow and realloc attempts failed. Attempt internalrep copy. - */ + LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed); + LIST_ASSERT(ListRepLength(&listRep) == listRep.storePtr->numUsed); + LIST_ASSERT(toLen == listRep.storePtr->numUsed); - attempt = 2 * numRequired; - newPtr = AttemptNewList(NULL, attempt, NULL); - if (newPtr == NULL) { - attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH; - if (attempt > LIST_MAX) { - attempt = LIST_MAX; + if (finalLen > (size_t)listRep.storePtr->numAllocated) { + ListStore *newStorePtr; + newStorePtr = ListStoreReallocate(listRep.storePtr, finalLen); + if (newStorePtr == NULL) { + return MemoryAllocationError(interp, LIST_SIZE(finalLen)); } - newPtr = AttemptNewList(NULL, attempt, NULL); - } - if (newPtr == NULL) { - attempt = numRequired; - newPtr = AttemptNewList(interp, attempt, NULL); - } - if (newPtr == NULL) { + LIST_ASSERT(newStorePtr->numAllocated >= finalLen); + listRep.storePtr = newStorePtr; /* - * All growth attempts failed; throw the error. + * WARNING: at this point the Tcl_Obj internal rep potentially + * points to freed storage if the reallocation returned a + * different location. Overwrite it to bring it back in sync. */ - - return TCL_ERROR; + ListObjStompRep(toObj, &listRep); } - - dst = newPtr->elements; - newPtr->refCount++; - newPtr->canonicalFlag = listRepPtr->canonicalFlag; - newPtr->elemCount = listRepPtr->elemCount; - - if (isShared) { - /* - * The original internalrep must remain undisturbed. Copy into the new - * one and bump refcounts - */ - while (numElems--) { - *dst = *src++; - Tcl_IncrRefCount(*dst++); - } - listRepPtr->refCount--; - } else { - /* - * Old internalrep to be freed, re-use refCounts. - */ - - memcpy(dst, src, numElems * sizeof(Tcl_Obj *)); - Tcl_Free(listRepPtr); + LIST_ASSERT(listRep.storePtr->numAllocated >= finalLen); + /* Current store big enough */ + numTailFree = ListRepNumFreeTail(&listRep); + LIST_ASSERT((numTailFree + listRep.storePtr->firstUsed) + >= elemCount); /* Total free */ + if (numTailFree < elemCount) { + /* Not enough room at back. Move some to front */ + ListSizeT shiftCount = elemCount - numTailFree; + /* Divide remaining space between front and back */ + shiftCount += (listRep.storePtr->numAllocated - finalLen) / 2; + LIST_ASSERT(shiftCount <= listRep.storePtr->firstUsed); + if (shiftCount) + ListRepUnsharedShiftDown(&listRep, shiftCount); } - listRepPtr = newPtr; - } - ListResetInternalRep(listPtr, listRepPtr); - listRepPtr->refCount++; - TclFreeInternalRep(listPtr); - ListSetInternalRep(listPtr, listRepPtr); - listRepPtr->refCount--; - - /* - * Add objPtr to the end of listPtr's array of element pointers. Increment - * the ref count for the (now shared) objPtr. - */ + ObjArrayCopy(&listRep.storePtr->slots[ListRepStart(&listRep) + + ListRepLength(&listRep)], + elemCount, + elemObjv); + listRep.storePtr->numUsed = finalLen; + if (listRep.spanPtr) { + LIST_ASSERT(listRep.spanPtr->spanStart + == listRep.storePtr->firstUsed); + listRep.spanPtr->spanLength = finalLen; + } + LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed); + LIST_ASSERT(ListRepLength(&listRep) == finalLen); + LISTREP_CHECK(&listRep); - listRepPtr->elements[listRepPtr->elemCount] = objPtr; - Tcl_IncrRefCount(objPtr); - listRepPtr->elemCount++; + ListObjReplaceRepAndInvalidate(toObj, &listRep); + return TCL_OK; + } /* - * Invalidate any old string representation since the list's internal - * representation has changed. + * Have to make a new list rep, either shared or no room in old one. + * If the old list did not have a span (all elements at front), do + * not leave space in the front either, assuming all appends and no + * prepends. */ + if (ListRepInit(finalLen, + NULL, + listRep.spanPtr ? LISTREP_SPACE_FAVOR_BACK + : LISTREP_SPACE_ONLY_BACK, + &listRep) + != TCL_OK) { + return TCL_ERROR; + } + LIST_ASSERT(listRep.storePtr->numAllocated >= finalLen); - TclInvalidateStringRep(listPtr); + if (toLen) { + ObjArrayCopy(ListRepSlotPtr(&listRep, 0), toLen, toObjv); + } + ObjArrayCopy(ListRepSlotPtr(&listRep, toLen), elemCount, elemObjv); + listRep.storePtr->numUsed = finalLen; + if (listRep.spanPtr) { + LIST_ASSERT(listRep.spanPtr->spanStart == listRep.storePtr->firstUsed); + listRep.spanPtr->spanLength = finalLen; + } + LISTREP_CHECK(&listRep); + ListObjReplaceRepAndInvalidate(toObj, &listRep); return TCL_OK; } - + /* *---------------------------------------------------------------------- * - * Tcl_ListObjIndex -- + * Tcl_ListObjAppendElement -- * - * Retrieve a pointer to the element of 'listPtr' at 'index'. The index - * of the first element is 0. + * This function is a special purpose version of Tcl_ListObjAppendList: + * it appends a single object referenced by elemObj to the list object + * referenced by toObj. If toObj is not already a list object, an + * attempt will be made to convert it to one. * - * Value + * Results: + * The return value is normally TCL_OK; in this case elemObj is added to + * the end of toObj's list. If toObj does not refer to a list object + * and the object can not be converted to one, TCL_ERROR is returned and + * an error message will be left in the interpreter's result if interp is + * not NULL. * - * TCL_OK + * Side effects: + * The ref count of elemObj is incremented since the list now refers to + * it. toObj will be converted, if necessary, to a list object. Also, + * appending the new element may cause listObj's array of element + * pointers to grow. toObj's old string representation, if any, is + * invalidated. * - * A pointer to the element at 'index' is stored in 'objPtrPtr'. If - * 'index' is out of range, NULL is stored in 'objPtrPtr'. This - * object should be treated as readonly and its 'refCount' is _not_ - * incremented. The caller must do that if it holds on to the - * reference. + *---------------------------------------------------------------------- + */ + +int +Tcl_ListObjAppendElement( + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *toObj, /* List object to append elemObj to. */ + Tcl_Obj *elemObj) /* Object to append to toObj's list. */ +{ + /* + * TODO - compare perf with 8.6 to see if worth optimizing single + * element case + */ + return TclListObjAppendElements(interp, toObj, 1, &elemObj); +} + +/* + *---------------------------------------------------------------------- * - * TCL_ERROR + * Tcl_ListObjIndex -- * - * 'listPtr' is not a valid list. An an error message is left in the - * interpreter's result if 'interp' is not NULL. + * This function returns a pointer to the index'th object from the list + * referenced by listPtr. The first element has index 0. If index is + * negative or greater than or equal to the number of elements in the + * list, a NULL is returned. If listPtr is not a list object, an attempt + * will be made to convert it to a list. * - * Effect + * Results: + * The return value is normally TCL_OK; in this case objPtrPtr is set to + * the Tcl_Obj pointer for the index'th list element or NULL if index is + * out of range. This object should be treated as readonly and its ref + * count is _not_ incremented; the caller must do that if it holds on to + * the reference. If listPtr does not refer to a list and can't be + * converted to one, TCL_ERROR is returned and an error message is left + * in the interpreter's result if interp is not NULL. * - * If 'listPtr' is not already of type 'tclListType', it is converted. + * Side effects: + * listPtr will be converted, if necessary, to a list object. * *---------------------------------------------------------------------- */ int Tcl_ListObjIndex( - Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *listPtr, /* List object to index into. */ - size_t index, /* Index of element to return. */ - Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */ + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *listObj, /* List object to index into. */ + size_t index, /* Index of element to return. */ + Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */ { - List *listRepPtr; - - ListGetInternalRep(listPtr, listRepPtr); - if (listRepPtr == NULL) { - int result; - size_t length; + Tcl_Obj **elemObjs; + size_t numElems; - (void) Tcl_GetStringFromObj(listPtr, &length); - if (length == 0) { - *objPtrPtr = NULL; - return TCL_OK; - } - result = SetListFromAny(interp, listPtr); - if (result != TCL_OK) { - return result; - } - ListGetInternalRep(listPtr, listRepPtr); + /* + * TODO + * Unlike the original list code, this does not optimize for lindex'ing + * an empty string when the internal rep is not already a list. On the + * other hand, this code will be faster for the case where the object + * is currently a dict. Benchmark the two cases. + */ + if (TclListObjGetElementsM(interp, listObj, &numElems, &elemObjs) + != TCL_OK) { + return TCL_ERROR; } - - if (index >= listRepPtr->elemCount) { + if (index >= numElems) { *objPtrPtr = NULL; } else { - *objPtrPtr = listRepPtr->elements[index]; + *objPtrPtr = elemObjs[index]; } return TCL_OK; @@ -847,20 +1923,19 @@ Tcl_ListObjIndex( * * Tcl_ListObjLength -- * - * Retrieve the number of elements in a list. - * - * Value - * - * TCL_OK - * - * A count of list elements is stored at the address provided by - * 'intPtr'. If 'listPtr' is not already of type 'tclListPtr', it is - * converted. + * This function returns the number of elements in a list object. If the + * object is not already a list object, an attempt will be made to + * convert it to one. * - * TCL_ERROR + * Results: + * The return value is normally TCL_OK; in this case *intPtr will be set + * to the integer count of list elements. If listPtr does not refer to a + * list object and the object can not be converted to one, TCL_ERROR is + * returned and an error message will be left in the interpreter's result + * if interp is not NULL. * - * 'listPtr' is not a valid list. An error message will be left in - * the interpreter's result if 'interp' is not NULL. + * Side effects: + * The possible conversion of the argument object to a list object. * *---------------------------------------------------------------------- */ @@ -868,337 +1943,498 @@ Tcl_ListObjIndex( #undef Tcl_ListObjLength int Tcl_ListObjLength( - Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *listPtr, /* List object whose #elements to return. */ - size_t *intPtr) /* The resulting length is stored here. */ + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *listObj, /* List object whose #elements to return. */ + size_t *lenPtr) /* The resulting int is stored here. */ { - List *listRepPtr; - - ListGetInternalRep(listPtr, listRepPtr); - if (listRepPtr == NULL) { - int result; - size_t length; + ListRep listRep; - (void) Tcl_GetStringFromObj(listPtr, &length); - if (length == 0) { - *intPtr = 0; - return TCL_OK; - } - result = SetListFromAny(interp, listPtr); - if (result != TCL_OK) { - return result; - } - ListGetInternalRep(listPtr, listRepPtr); + /* + * TODO + * Unlike the original list code, this does not optimize for lindex'ing + * an empty string when the internal rep is not already a list. On the + * other hand, this code will be faster for the case where the object + * is currently a dict. Benchmark the two cases. + */ + if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) { + return TCL_ERROR; } - - *intPtr = listRepPtr->elemCount; + *lenPtr = ListRepLength(&listRep); return TCL_OK; } - + /* *---------------------------------------------------------------------- * - * Tcl_ListObjReplace -- - * - * Replace values in a list. - * - * If 'first' is zero or TCL_INDEX_NONE, it refers to the first element. If - * 'first' outside the range of elements in the list, no elements are - * deleted. - * - * If 'count' is zero or TCL_INDEX_NONE no elements are deleted, and any new - * elements are inserted at the beginning of the list. - * - * Value - * - * TCL_OK - * - * The first 'objc' values of 'objv' replaced 'count' elements in 'listPtr' - * starting at 'first'. If 'objc' 0, no new elements are added. - * - * TCL_ERROR + * Tcl_ListObjReplace -- * - * 'listPtr' is not a valid list. An error message is left in the - * interpreter's result if 'interp' is not NULL. + * This function replaces zero or more elements of the list referenced by + * listObj with the objects from an (objc,objv) array. The objc elements + * of the array referenced by objv replace the count elements in listPtr + * starting at first. * - * Effect + * If the argument first is zero or negative, it refers to the first + * element. If first is greater than or equal to the number of elements + * in the list, then no elements are deleted; the new elements are + * appended to the list. Count gives the number of elements to replace. + * If count is zero or negative then no elements are deleted; the new + * elements are simply inserted before first. * - * If 'listPtr' is not of type 'tclListType', it is converted if possible. + * The argument objv refers to an array of objc pointers to the new + * elements to be added to listPtr in place of those that were deleted. + * If objv is NULL, no new elements are added. If listPtr is not a list + * object, an attempt will be made to convert it to one. * - * The 'refCount' of each element appended to the list is incremented. - * Similarly, the 'refCount' for each replaced element is decremented. + * Results: + * The return value is normally TCL_OK. If listPtr does not refer to a + * list object and can not be converted to one, TCL_ERROR is returned and + * an error message will be left in the interpreter's result if interp is + * not NULL. * - * If 'listPtr' is modified, any previous string representation is - * invalidated. + * Side effects: + * The ref counts of the objc elements in objv are incremented since the + * resulting list now refers to them. Similarly, the ref counts for + * replaced objects are decremented. listObj is converted, if necessary, + * to a list object. listObj's old string representation, if any, is + * freed. * *---------------------------------------------------------------------- */ - int Tcl_ListObjReplace( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *listPtr, /* List object whose elements to replace. */ - size_t first, /* Index of first element to replace. */ - size_t count, /* Number of elements to replace. */ - size_t objc, /* Number of objects to insert. */ - Tcl_Obj *const objv[]) /* An array of objc pointers to Tcl objects to - * insert. */ + Tcl_Obj *listObj, /* List object whose elements to replace. */ + size_t first, /* Index of first element to replace. */ + size_t numToDelete, /* Number of elements to replace. */ + size_t numToInsert, /* Number of objects to insert. */ + Tcl_Obj *const insertObjs[])/* Tcl objects to insert */ { - List *listRepPtr; - Tcl_Obj **elemPtrs; - size_t numElems, numRequired, numAfterLast, start, i, j; - int needGrow, isShared; - - if (Tcl_IsShared(listPtr)) { + ListRep listRep; + ListSizeT origListLen; + ListSizeT lenChange; + ListSizeT leadSegmentLen; + ListSizeT tailSegmentLen; + ListSizeT numFreeSlots; + ListSizeT leadShift; + ListSizeT tailShift; + Tcl_Obj **listObjs; + + if (Tcl_IsShared(listObj)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); } - ListGetInternalRep(listPtr, listRepPtr); - if (listRepPtr == NULL) { - size_t length; + if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) + return TCL_ERROR; /* Cannot be converted to a list */ - (void) Tcl_GetStringFromObj(listPtr, &length); - if (length == 0) { - if (objc == 0) { - return TCL_OK; - } - Tcl_SetListObj(listPtr, objc, NULL); - } else { - int result = SetListFromAny(interp, listPtr); + /* TODO - will need modification if Tcl9 sticks to unsigned indices */ - if (result != TCL_OK) { - return result; - } - } - ListGetInternalRep(listPtr, listRepPtr); + /* Make limits sane */ + origListLen = ListRepLength(&listRep); + if (first == TCL_INDEX_NONE) { + first = 0; + } + if (first > (size_t)origListLen) { + first = origListLen; /* So we'll insert after last element. */ + } + if (numToDelete == TCL_INDEX_NONE) { + numToDelete = 0; + } else if (first > ListSizeT_MAX - numToDelete /* Handle integer overflow */ + || (size_t)origListLen < first + numToDelete) { + numToDelete = origListLen - first; + } + + if (numToInsert > ListSizeT_MAX - (origListLen - numToDelete)) { + return ListLimitExceededError(interp); } /* - * Note that when count == 0 and objc == 0, this routine is logically a - * no-op, removing and adding no elements to the list. However, by flowing - * through this routine anyway, we get the important side effect that the - * resulting listPtr is a list in canoncial form. This is important. - * Resist any temptation to optimize this case. + * There are a number of special cases to consider from an optimization + * point of view. + * (1) Pure deletes (numToInsert==0) from the front or back can be treated + * as a range op irrespective of whether the ListStore is shared or not + * (2) Pure inserts (numToDelete == 0) + * (2a) Pure inserts at the back can be treated as appends + * (2b) Pure inserts from the *front* can be optimized under certain + * conditions by inserting before first ListStore slot in use if there + * is room, again irrespective of sharing + * (3) If the ListStore is shared OR there is insufficient free space + * OR existing allocation is too large compared to new size, create + * a new ListStore + * (4) Unshared ListStore with sufficient free space. Delete, shift and + * insert within the ListStore. */ - elemPtrs = listRepPtr->elements; - numElems = listRepPtr->elemCount; + /* Note: do not do TclInvalidateStringRep as yet in case there are errors */ - if (first == TCL_INDEX_NONE) { - first = 0; - } - if (first >= numElems) { - first = numElems; /* So we'll insert after last element. */ + /* Check Case (1) - Treat pure deletes from front or back as range ops */ + if (numToInsert == 0) { + if (numToDelete == 0) { + /* Should force canonical even for no-op */ + TclInvalidateStringRep(listObj); + return TCL_OK; + } + if (first == 0) { + /* Delete from front, so return tail */ + ListRep tailRep; + ListRepRange(&listRep, numToDelete, origListLen-1, 0, &tailRep); + ListObjReplaceRepAndInvalidate(listObj, &tailRep); + return TCL_OK; + } else if ((first+numToDelete) >= (size_t)origListLen) { + /* Delete from tail, so return head */ + ListRep headRep; + ListRepRange(&listRep, 0, first-1, 0, &headRep); + ListObjReplaceRepAndInvalidate(listObj, &headRep); + return TCL_OK; + } + /* Deletion from middle. Fall through to general case */ } - if (count == TCL_INDEX_NONE) { - count = 0; - } else if (count > LIST_MAX /* Handle integer overflow */ - || numElems < first+count) { - count = numElems - first; + /* Garbage collect before checking the pure insert optimization */ + ListRepFreeUnreferenced(&listRep); + + /* + * Check Case (2) - pure inserts under certain conditions: + */ + if (numToDelete == 0) { + /* Case (2a) - Append to list */ + if (first == (size_t)origListLen) { + return TclListObjAppendElements( + interp, listObj, numToInsert, insertObjs); + } + + /* + * Case (2b) - pure inserts at front under some circumstances + * (i) Insertion must be at head of list + * (ii) The list's span must be at head of the in-use slots in the store + * (iii) There must be unused room at front of the store + * NOTE THIS IS TRUE EVEN IF THE ListStore IS SHARED as it will not + * affect the other Tcl_Obj's referencing this ListStore. See the TIP. + */ + if (first == 0 && /* (i) */ + ListRepStart(&listRep) == listRep.storePtr->firstUsed && /* (ii) */ + numToInsert <= (size_t)listRep.storePtr->firstUsed /* (iii) */ + ) { + ListSizeT newLen; + LIST_ASSERT(numToInsert); /* Else would have returned above */ + listRep.storePtr->firstUsed -= numToInsert; + ObjArrayCopy(&listRep.storePtr->slots[listRep.storePtr->firstUsed], + numToInsert, + insertObjs); + listRep.storePtr->numUsed += numToInsert; + newLen = listRep.spanPtr->spanLength + numToInsert; + if (listRep.spanPtr && listRep.spanPtr->refCount <= 1) { + /* An unshared span record, re-use it */ + listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; + listRep.spanPtr->spanLength = newLen; + } else { + /* Need a new span record */ + if (listRep.storePtr->firstUsed == 0) { + listRep.spanPtr = NULL; + } else { + listRep.spanPtr = + ListSpanNew(listRep.storePtr->firstUsed, newLen); + } + } + ListObjReplaceRepAndInvalidate(listObj, &listRep); + return TCL_OK; + } } - isShared = (listRepPtr->refCount > 1); - numRequired = numElems - count + objc; /* Known <= LIST_MAX */ - needGrow = numRequired > listRepPtr->maxElemCount; - for (i = 0; i < objc; i++) { - Tcl_IncrRefCount(objv[i]); + /* Just for readability of the code */ + lenChange = numToInsert - numToDelete; + leadSegmentLen = first; + tailSegmentLen = origListLen - (first + numToDelete); + numFreeSlots = listRep.storePtr->numAllocated - listRep.storePtr->numUsed; + + /* + * Before further processing, if unshared, try and reallocate to avoid + * new allocation below. This avoids expensive ref count manipulation + * later by not having to go through the ListRepInit and + * ListObjReplaceAndInvalidate below. + */ + if (numFreeSlots < lenChange && !ListRepIsShared(&listRep)) { + ListStore *newStorePtr = + ListStoreReallocate(listRep.storePtr, origListLen + lenChange); + if (newStorePtr == NULL) { + return MemoryAllocationError(interp, + LIST_SIZE(origListLen + lenChange)); + } + listRep.storePtr = newStorePtr; + numFreeSlots = + listRep.storePtr->numAllocated - listRep.storePtr->numUsed; + /* + * WARNING: at this point the Tcl_Obj internal rep potentially + * points to freed storage if the reallocation returned a + * different location. Overwrite it to bring it back in sync. + */ + ListObjStompRep(listObj, &listRep); } - if (needGrow && !isShared) { - /* Try to use realloc */ - List *newPtr = NULL; - size_t attempt = 2 * numRequired; - if (attempt <= LIST_MAX) { - newPtr = (List *)Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt)); + /* + * Case (3) a new ListStore is required + * (a) The passed-in ListStore is shared + * (b) There is not enough free space in the unshared passed-in ListStore + * (c) The new unshared size is much "smaller" (TODO) than the allocated space + * TODO - for unshared case ONLY, consider a "move" based implementation + */ + if (ListRepIsShared(&listRep) || /* 3a */ + numFreeSlots < lenChange || /* 3b */ + (origListLen + lenChange) < (listRep.storePtr->numAllocated / 4) /* 3c */ + ) { + ListRep newRep; + Tcl_Obj **toObjs; + listObjs = &listRep.storePtr->slots[ListRepStart(&listRep)]; + ListRepInit(origListLen + lenChange, + NULL, + LISTREP_PANIC_ON_FAIL | LISTREP_SPACE_FAVOR_NONE, + &newRep); + toObjs = ListRepSlotPtr(&newRep, 0); + if (leadSegmentLen > 0) { + ObjArrayCopy(toObjs, leadSegmentLen, listObjs); } - if (newPtr == NULL) { - attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH; - if (attempt > LIST_MAX) { - attempt = LIST_MAX; - } - newPtr = (List *)Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt)); + if (numToInsert > 0) { + ObjArrayCopy(&toObjs[leadSegmentLen], + numToInsert, + insertObjs); } - if (newPtr == NULL) { - attempt = numRequired; - newPtr = (List *)Tcl_AttemptRealloc(listRepPtr, LIST_SIZE(attempt)); + if (tailSegmentLen > 0) { + ObjArrayCopy(&toObjs[leadSegmentLen + numToInsert], + tailSegmentLen, + &listObjs[leadSegmentLen+numToDelete]); } - if (newPtr) { - listRepPtr = newPtr; - ListResetInternalRep(listPtr, listRepPtr); - elemPtrs = listRepPtr->elements; - listRepPtr->maxElemCount = attempt; - needGrow = numRequired > listRepPtr->maxElemCount; + newRep.storePtr->numUsed = origListLen + lenChange; + if (newRep.spanPtr) { + newRep.spanPtr->spanLength = newRep.storePtr->numUsed; } + LISTREP_CHECK(&newRep); + ListObjReplaceRepAndInvalidate(listObj, &newRep); + return TCL_OK; } - if (!needGrow && !isShared) { - int shift; - /* - * Can use the current List struct. First "delete" count elements - * starting at first. - */ + /* + * Case (4) - unshared ListStore with sufficient room. + * After deleting elements, there will be a corresponding gap. If this + * gap does not match number of insertions, either the lead segment, + * or the tail segment, or both will have to be moved. + * The general strategy is to move the fewest number of elements. If + * + * TODO - what about appends to unshared ? Is below sufficiently optimal? + */ - for (j = first; j < first + count; j++) { - Tcl_Obj *victimPtr = elemPtrs[j]; + /* Following must hold for unshared listreps after ListRepFreeUnreferenced above */ + LIST_ASSERT(origListLen == listRep.storePtr->numUsed); + LIST_ASSERT(origListLen == ListRepLength(&listRep)); + LIST_ASSERT(ListRepStart(&listRep) == listRep.storePtr->firstUsed); - TclDecrRefCount(victimPtr); - } + LIST_ASSERT((numToDelete + numToInsert) > 0); - /* - * Shift the elements after the last one removed to their new - * locations. - */ + /* Base of slot array holding the list elements */ + listObjs = &listRep.storePtr->slots[ListRepStart(&listRep)]; + + /* + * Free up elements to be deleted. Before that, increment the ref counts + * for objects to be inserted in case there is overlap. See bug3598580 + * or test listobj-11.1 + */ + if (numToInsert) { + ObjArrayIncrRefs(insertObjs, 0, numToInsert); + } + if (numToDelete) { + ObjArrayDecrRefs(listObjs, first, numToDelete); + } - start = first + count; - numAfterLast = numElems - start; - shift = objc - count; /* numNewElems - numDeleted */ - if ((numAfterLast > 0) && (shift != 0)) { - Tcl_Obj **src = elemPtrs + start; + /* + * Calculate shifts if necessary to accomodate insertions. + * NOTE: all indices are relative to listObjs which is not necessarily the + * start of the ListStore storage area. + * + * leadShift - how much to shift the lead segment + * tailShift - how much to shift the tail segment + * insertTarget - index where to insert. + */ - memmove(src+shift, src, numAfterLast * sizeof(Tcl_Obj*)); - } - } else { + if (lenChange == 0) { + /* Exact fit */ + leadShift = 0; + tailShift = 0; + } else if (lenChange < 0) { /* - * Cannot use the current List struct; it is shared, too small, or - * both. Allocate a new struct and insert elements into it. + * More deletions than insertions. The gap after deletions is large + * enough for insertions. Move a segment depending on size. */ - - List *oldListRepPtr = listRepPtr; - Tcl_Obj **oldPtrs = elemPtrs; - int newMax; - - if (needGrow) { - newMax = 2 * numRequired; + if (leadSegmentLen > tailSegmentLen) { + /* Tail segment smaller. Insert after lead, move tail down */ + leadShift = 0; + tailShift = lenChange; } else { - newMax = listRepPtr->maxElemCount; + /* Lead segment smaller. Insert before tail, move lead up */ + leadShift = -lenChange; + tailShift = 0; } + } else { + LIST_ASSERT(lenChange > 0); /* Reminder */ - listRepPtr = AttemptNewList(NULL, newMax, NULL); - if (listRepPtr == NULL) { - unsigned int limit = LIST_MAX - numRequired; - unsigned int extra = numRequired - numElems - + TCL_MIN_ELEMENT_GROWTH; - int growth = (int) ((extra > limit) ? limit : extra); - - listRepPtr = AttemptNewList(NULL, numRequired + growth, NULL); - if (listRepPtr == NULL) { - listRepPtr = AttemptNewList(interp, numRequired, NULL); - if (listRepPtr == NULL) { - for (i = 0; i < objc; i++) { - /* See bug 3598580 */ - Tcl_DecrRefCount(objv[i]); - } - return TCL_ERROR; + /* + * We need to make room for the insertions. Again we have multiple + * possibilities. We may be able to get by just shifting one segment + * or need to shift both. In the former case, favor shifting the + * smaller segment. + */ + ListSizeT leadSpace = ListRepNumFreeHead(&listRep); + ListSizeT tailSpace = ListRepNumFreeTail(&listRep); + ListSizeT finalFreeSpace = leadSpace + tailSpace - lenChange; + + LIST_ASSERT((leadSpace + tailSpace) >= lenChange); + if (leadSpace >= lenChange + && (leadSegmentLen < tailSegmentLen || tailSpace < lenChange)) { + /* Move only lead to the front to make more room */ + leadShift = -lenChange; + tailShift = 0; + /* + * Redistribute the remaining free space between the front and + * back if either there is no tail space left or if the + * entire list is the head anyways. This is an important + * optimization for further operations like further asymmetric + * insertions. + */ + if (finalFreeSpace > 1 && (tailSpace == 0 || tailSegmentLen == 0)) { + ListSizeT postShiftLeadSpace = leadSpace - lenChange; + if (postShiftLeadSpace > (finalFreeSpace/2)) { + ListSizeT extraShift = postShiftLeadSpace - (finalFreeSpace / 2); + leadShift -= extraShift; + tailShift = -extraShift; /* Move tail to the front as well */ } } - } - - ListResetInternalRep(listPtr, listRepPtr); - listRepPtr->refCount++; - - elemPtrs = listRepPtr->elements; - - if (isShared) { + LIST_ASSERT(leadShift >= 0 || leadSpace >= -leadShift); + } else if (tailSpace >= lenChange) { + /* Move only tail segment to the back to make more room. */ + leadShift = 0; + tailShift = lenChange; /* - * The old struct will remain in place; need new refCounts for the - * new List struct references. Copy over only the surviving - * elements. + * See comments above. This is analogous. */ - - for (i=0; i < first; i++) { - elemPtrs[i] = oldPtrs[i]; - Tcl_IncrRefCount(elemPtrs[i]); - } - for (i = first + count, j = first + objc; - j < numRequired; i++, j++) { - elemPtrs[j] = oldPtrs[i]; - Tcl_IncrRefCount(elemPtrs[j]); + if (finalFreeSpace > 1 && (leadSpace == 0 || leadSegmentLen == 0)) { + ListSizeT postShiftTailSpace = tailSpace - lenChange; + if (postShiftTailSpace > (finalFreeSpace/2)) { + ListSizeT extraShift = postShiftTailSpace - (finalFreeSpace / 2); + tailShift += extraShift; + leadShift = extraShift; /* Move head to the back as well */ + } } - - oldListRepPtr->refCount--; + LIST_ASSERT(tailShift <= tailSpace); } else { /* - * The old struct will be removed; use its inherited refCounts. + * Both lead and tail need to be shifted to make room. + * Divide remaining free space equally between front and back. */ - - if (first > 0) { - memcpy(elemPtrs, oldPtrs, first * sizeof(Tcl_Obj *)); - } + LIST_ASSERT(leadSpace < lenChange); + LIST_ASSERT(tailSpace < lenChange); /* - * "Delete" count elements starting at first. + * leadShift = leadSpace - (finalFreeSpace/2) + * Thus leadShift <= leadSpace + * Also, + * = leadSpace - (leadSpace + tailSpace - lenChange)/2 + * = leadSpace/2 - tailSpace/2 + lenChange/2 + * >= 0 because lenChange > tailSpace */ - - for (j = first; j < first + count; j++) { - Tcl_Obj *victimPtr = oldPtrs[j]; - - TclDecrRefCount(victimPtr); + leadShift = leadSpace - (finalFreeSpace / 2); + tailShift = lenChange - leadShift; + if (tailShift > tailSpace) { + /* Account for integer division errors */ + leadShift += 1; + tailShift -= 1; } - /* - * Copy the elements after the last one removed, shifted to their - * new locations. + * Following must be true because otherwise one of the previous + * if clauses would have been taken. */ - - start = first + count; - numAfterLast = numElems - start; - if (numAfterLast > 0) { - memcpy(elemPtrs + first + objc, oldPtrs + start, - (size_t) numAfterLast * sizeof(Tcl_Obj *)); - } - - Tcl_Free(oldListRepPtr); + LIST_ASSERT(leadShift > 0 && leadShift < lenChange); + LIST_ASSERT(tailShift > 0 && tailShift < lenChange); + leadShift = -leadShift; /* Lead is actually shifted downward */ } } - /* - * Insert the new elements into elemPtrs before "first". - */ - - for (i=0,j=first ; i 0) { + /* Will happen when we have to make room at bottom */ + if (tailShift != 0 && tailSegmentLen != 0) { + ListSizeT tailStart = leadSegmentLen + numToDelete; + memmove(&listObjs[tailStart + tailShift], + &listObjs[tailStart], + tailSegmentLen * sizeof(Tcl_Obj *)); + } + if (leadSegmentLen != 0) { + memmove(&listObjs[leadShift], + &listObjs[0], + leadSegmentLen * sizeof(Tcl_Obj *)); + } + } else { + if (leadShift != 0 && leadSegmentLen != 0) { + memmove(&listObjs[leadShift], + &listObjs[0], + leadSegmentLen * sizeof(Tcl_Obj *)); + } + if (tailShift != 0 && tailSegmentLen != 0) { + ListSizeT tailStart = leadSegmentLen + numToDelete; + memmove(&listObjs[tailStart + tailShift], + &listObjs[tailStart], + tailSegmentLen * sizeof(Tcl_Obj *)); + } + } + if (numToInsert) { + /* Do NOT use ObjArrayCopy here since we have already incr'ed ref counts */ + memmove(&listObjs[leadSegmentLen + leadShift], + insertObjs, + numToInsert * sizeof(Tcl_Obj *)); } - /* - * Update the count of elements. - */ - - listRepPtr->elemCount = numRequired; - - /* - * Invalidate and free any old representations that may not agree - * with the revised list's internal representation. - */ + listRep.storePtr->firstUsed += leadShift; + listRep.storePtr->numUsed = origListLen + lenChange; + listRep.storePtr->flags = 0; - listRepPtr->refCount++; - TclFreeInternalRep(listPtr); - ListSetInternalRep(listPtr, listRepPtr); - listRepPtr->refCount--; + if (listRep.spanPtr && listRep.spanPtr->refCount <= 1) { + /* An unshared span record, re-use it, even if not required */ + listRep.spanPtr->spanStart = listRep.storePtr->firstUsed; + listRep.spanPtr->spanLength = listRep.storePtr->numUsed; + } else { + /* Need a new span record */ + if (listRep.storePtr->firstUsed == 0) { + listRep.spanPtr = NULL; + } else { + listRep.spanPtr = ListSpanNew(listRep.storePtr->firstUsed, + listRep.storePtr->numUsed); + } + } - TclInvalidateStringRep(listPtr); + LISTREP_CHECK(&listRep); + ListObjReplaceRepAndInvalidate(listObj, &listRep); return TCL_OK; } + /* *---------------------------------------------------------------------- * * TclLindexList -- * - * Implements the 'lindex' command when objc==3. + * This procedure handles the 'lindex' command when objc==3. * - * Implemented entirely as a wrapper around 'TclLindexFlat'. Reconfigures - * the argument format into required form while taking care to manage - * shimmering so as to tend to keep the most useful internalreps - * and/or avoid the most expensive conversions. - * - * Value + * Results: + * Returns a pointer to the object extracted, or NULL if an error + * occurred. The returned object already includes one reference count for + * the pointer returned. * - * A pointer to the specified element, with its 'refCount' incremented, or - * NULL if an error occurred. + * Side effects: + * None. * - * Notes + * Notes: + * This procedure is implemented entirely as a wrapper around + * TclLindexFlat. All it does is reconfigure the argument format into the + * form required by TclLindexFlat, while taking care to manage shimmering + * in such a way that we tend to keep the most useful internalreps and/or + * avoid the most expensive conversions. * *---------------------------------------------------------------------- */ @@ -1206,28 +2442,27 @@ Tcl_ListObjReplace( Tcl_Obj * TclLindexList( Tcl_Interp *interp, /* Tcl interpreter. */ - Tcl_Obj *listPtr, /* List being unpacked. */ - Tcl_Obj *argPtr) /* Index or index list. */ + Tcl_Obj *listObj, /* List being unpacked. */ + Tcl_Obj *argObj) /* Index or index list. */ { - size_t index; /* Index into the list. */ Tcl_Obj *indexListCopy; - List *listRepPtr; + Tcl_Obj **indexObjs; + ListSizeT numIndexObjs; /* * Determine whether argPtr designates a list or a single index. We have * to be careful about the order of the checks to avoid repeated - * shimmering; see TIP#22 and TIP#33 for the details. + * shimmering; if internal rep is already a list do not shimmer it. + * see TIP#22 and TIP#33 for the details. */ - - ListGetInternalRep(argPtr, listRepPtr); - if ((listRepPtr == NULL) - && TclGetIntForIndexM(NULL , argPtr, (size_t)WIDE_MAX - 1, &index) == TCL_OK) { + if (!TclHasInternalRep(argObj, &tclListType) + && TclGetIntForIndexM(NULL, argObj, ListSizeT_MAX - 1, &index) + == TCL_OK) { /* * argPtr designates a single index. */ - - return TclLindexFlat(interp, listPtr, 1, &argPtr); + return TclLindexFlat(interp, listObj, 1, &argObj); } /* @@ -1242,43 +2477,44 @@ TclLindexList( * implementation does not. */ - indexListCopy = TclListObjCopy(NULL, argPtr); + indexListCopy = TclListObjCopy(NULL, argObj); if (indexListCopy == NULL) { /* - * argPtr designates something that is neither an index nor a - * well-formed list. Report the error via TclLindexFlat. + * The argument is neither an index nor a well-formed list. + * Report the error via TclLindexFlat. + * TODO - This is as original. why not directly return an error? */ - - return TclLindexFlat(interp, listPtr, 1, &argPtr); + return TclLindexFlat(interp, listObj, 1, &argObj); } - ListGetInternalRep(indexListCopy, listRepPtr); - - assert(listRepPtr != NULL); - - listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount, - listRepPtr->elements); + ListObjGetElements(indexListCopy, numIndexObjs, indexObjs); + listObj = TclLindexFlat(interp, listObj, numIndexObjs, indexObjs); Tcl_DecrRefCount(indexListCopy); - return listPtr; + return listObj; } /* *---------------------------------------------------------------------- * - * TclLindexFlat -- - * - * The core of the 'lindex' command, with all index - * arguments presented as a flat list. + * TclLindexFlat -- * - * Value + * This procedure is the core of the 'lindex' command, with all index + * arguments presented as a flat list. * - * A pointer to the object extracted, with its 'refCount' incremented, or - * NULL if an error occurred. Thus, the calling code will usually do - * something like: + * Results: + * Returns a pointer to the object extracted, or NULL if an error + * occurred. The returned object already includes one reference count for + * the pointer returned. * - * Tcl_SetObjResult(interp, result); - * Tcl_DecrRefCount(result); + * Side effects: + * None. * + * Notes: + * The reference count of the returned object includes one reference + * corresponding to the pointer returned. Thus, the calling code will + * usually do something like: + * Tcl_SetObjResult(interp, result); + * Tcl_DecrRefCount(result); * *---------------------------------------------------------------------- */ @@ -1286,16 +2522,16 @@ TclLindexList( Tcl_Obj * TclLindexFlat( Tcl_Interp *interp, /* Tcl interpreter. */ - Tcl_Obj *listPtr, /* Tcl object representing the list. */ + Tcl_Obj *listObj, /* Tcl object representing the list. */ size_t indexCount, /* Count of indices. */ Tcl_Obj *const indexArray[])/* Array of pointers to Tcl objects that * represent the indices in the list. */ { size_t i; - Tcl_IncrRefCount(listPtr); + Tcl_IncrRefCount(listObj); - for (i=0 ; i error. - */ - + /* The sublist is not a list at all => error. */ break; } - TclListObjGetElementsM(NULL, sublistCopy, &listLen, &elemPtrs); + LIST_ASSERT_TYPE(sublistCopy); + ListObjGetElements(sublistCopy, listLen, elemPtrs); if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1, &index) == TCL_OK) { - if (index >= (size_t)listLen) { + if (index >= listLen) { /* * Index is out of range. Break out of loop with empty result. * First check remaining indices for validity */ while (++i < indexCount) { - if (TclGetIntForIndexM(interp, indexArray[i], (size_t)WIDE_MAX - 1, &index) + if (TclGetIntForIndexM( + interp, indexArray[i], ListSizeT_MAX - 1, &index) != TCL_OK) { Tcl_DecrRefCount(sublistCopy); return NULL; } } - TclNewObj(listPtr); + TclNewObj(listObj); } else { - /* - * Extract the pointer to the appropriate element. - */ - - listPtr = elemPtrs[index]; + /* Extract the pointer to the appropriate element. */ + listObj = elemPtrs[index]; } - Tcl_IncrRefCount(listPtr); + Tcl_IncrRefCount(listObj); } Tcl_DecrRefCount(sublistCopy); } - return listPtr; + return listObj; } /* @@ -1354,17 +2586,24 @@ TclLindexFlat( * * TclLsetList -- * - * The core of [lset] when objc == 4. Objv[2] may be either a + * Core of the 'lset' command when objc == 4. Objv[2] may be either a * scalar index or a list of indices. * It also handles 'lpop' when given a NULL value. * - * Implemented entirely as a wrapper around 'TclLindexFlat', as described - * for 'TclLindexList'. + * Results: + * Returns the new value of the list variable, or NULL if there was an + * error. The returned object includes one reference count for the + * pointer returned. * - * Value + * Side effects: + * None. * - * The new list, with the 'refCount' of 'valuPtr' incremented, or NULL if - * there was an error. + * Notes: + * This procedure is implemented entirely as a wrapper around + * TclLsetFlat. All it does is reconfigure the argument format into the + * form required by TclLsetFlat, while taking care to manage shimmering + * in such a way that we tend to keep the most useful internalreps and/or + * avoid the most expensive conversions. * *---------------------------------------------------------------------- */ @@ -1372,16 +2611,15 @@ TclLindexFlat( Tcl_Obj * TclLsetList( Tcl_Interp *interp, /* Tcl interpreter. */ - Tcl_Obj *listPtr, /* Pointer to the list being modified. */ - Tcl_Obj *indexArgPtr, /* Index or index-list arg to 'lset'. */ - Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */ + Tcl_Obj *listObj, /* Pointer to the list being modified. */ + Tcl_Obj *indexArgObj, /* Index or index-list arg to 'lset'. */ + Tcl_Obj *valueObj) /* Value arg to 'lset' or NULL to 'lpop'. */ { - size_t indexCount = 0; /* Number of indices in the index list. */ + ListSizeT indexCount = 0; /* Number of indices in the index list. */ Tcl_Obj **indices = NULL; /* Vector of indices in the index list. */ - Tcl_Obj *retValuePtr; /* Pointer to the list to be returned. */ - size_t index; /* Current index in the list - discarded. */ + Tcl_Obj *retValueObj; /* Pointer to the list to be returned. */ + size_t index; /* Current index in the list - discarded. */ Tcl_Obj *indexListCopy; - List *listRepPtr; /* * Determine whether the index arg designates a list or a single index. @@ -1389,36 +2627,32 @@ TclLsetList( * shimmering; see TIP #22 and #23 for details. */ - ListGetInternalRep(indexArgPtr, listRepPtr); - if (listRepPtr == NULL - && TclGetIntForIndexM(NULL, indexArgPtr, (size_t)WIDE_MAX - 1, &index) == TCL_OK) { - /* - * indexArgPtr designates a single index. - */ - - return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr); - + if (!TclHasInternalRep(indexArgObj, &tclListType) + && TclGetIntForIndexM(NULL, indexArgObj, ListSizeT_MAX - 1, &index) + == TCL_OK) { + /* indexArgPtr designates a single index. */ + return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj); } - indexListCopy = TclListObjCopy(NULL, indexArgPtr); + indexListCopy = TclListObjCopy(NULL, indexArgObj); if (indexListCopy == NULL) { /* * indexArgPtr designates something that is neither an index nor a * well formed list. Report the error via TclLsetFlat. */ - - return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr); + return TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj); } - TclListObjGetElementsM(NULL, indexArgPtr, &indexCount, &indices); + LIST_ASSERT_TYPE(indexListCopy); + ListObjGetElements(indexListCopy, indexCount, indices); /* * Let TclLsetFlat handle the actual lset'ting. */ - retValuePtr = TclLsetFlat(interp, listPtr, indexCount, indices, valuePtr); + retValueObj = TclLsetFlat(interp, listObj, indexCount, indices, valueObj); Tcl_DecrRefCount(indexListCopy); - return retValuePtr; + return retValueObj; } /* @@ -1429,41 +2663,31 @@ TclLsetList( * Core engine of the 'lset' command. * It also handles 'lpop' when given a NULL value. * - * Value - * - * The resulting list - * - * The 'refCount' of 'valuePtr' is incremented. If 'listPtr' was not - * duplicated, its 'refCount' is incremented. The reference count of - * an unduplicated object is therefore 2 (one for the returned pointer - * and one for the variable that holds it). The reference count of a - * duplicate object is 1, reflecting that result is the only active - * reference. The caller is expected to store the result in the - * variable and decrement its reference count. (INST_STORE_* does - * exactly this.) - * - * NULL - * - * An error occurred. If 'listPtr' was duplicated, the reference - * count on the duplicate is decremented so that it is 0, causing any - * memory allocated by this function to be freed. - * - * - * Effect - * - * On entry, the reference count of 'listPtr' does not reflect any - * references held on the stack. The first action of this function is to - * determine whether 'listPtr' is shared and to create a duplicate - * unshared copy if it is. The reference count of the duplicate is - * incremented. At this point, the reference count is 1 in either case so - * that the object is considered unshared. + * Results: + * Returns the new value of the list variable, or NULL if an error + * occurred. The returned object includes one reference count for the + * pointer returned. * - * The unshared list is altered directly to produce the result. - * 'TclLsetFlat' maintains a linked list of 'Tcl_Obj' values whose string - * representations must be spoilt by threading via 'ptr2' of the - * two-pointer internal representation. On entry to 'TclLsetFlat', the - * values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any - * Tcl_Obj that has been modified is set to NULL. + * Side effects: + * On entry, the reference count of the variable value does not reflect + * any references held on the stack. The first action of this function is + * to determine whether the object is shared, and to duplicate it if it + * is. The reference count of the duplicate is incremented. At this + * point, the reference count will be 1 for either case, so that the + * object will appear to be unshared. + * + * If an error occurs, and the object has been duplicated, the reference + * count on the duplicate is decremented so that it is now 0: this + * dismisses any memory that was allocated by this function. + * + * If no error occurs, the reference count of the original object is + * incremented if the object has not been duplicated, and nothing is done + * to a reference count of the duplicate. Now the reference count of an + * unduplicated object is 2 (the returned pointer, plus the one stored in + * the variable). The reference count of a duplicate object is 1, + * reflecting that the returned pointer is the only active reference. The + * caller is expected to store the returned value back in the variable + * and decrement its reference count. (INST_STORE_* does exactly this.) * *---------------------------------------------------------------------- */ @@ -1471,52 +2695,60 @@ TclLsetList( Tcl_Obj * TclLsetFlat( Tcl_Interp *interp, /* Tcl interpreter. */ - Tcl_Obj *listPtr, /* Pointer to the list being modified. */ + Tcl_Obj *listObj, /* Pointer to the list being modified. */ size_t indexCount, /* Number of index args. */ Tcl_Obj *const indexArray[], /* Index args. */ - Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */ + Tcl_Obj *valueObj) /* Value arg to 'lset' or NULL to 'lpop'. */ { size_t index, len; - int result; - Tcl_Obj *subListPtr, *retValuePtr, *chainPtr; - Tcl_ObjInternalRep *irPtr; + int result; + Tcl_Obj *subListObj, *retValueObj; + Tcl_Obj *pendingInvalidates[10]; + Tcl_Obj **pendingInvalidatesPtr = pendingInvalidates; + ListSizeT numPendingInvalidates = 0; /* * If there are no indices, simply return the new value. (Without * indices, [lset] is a synonym for [set]. - * [lpop] does not use this but protect for NULL valuePtr just in case. + * [lpop] does not use this but protect for NULL valueObj just in case. */ if (indexCount == 0) { - if (valuePtr != NULL) { - Tcl_IncrRefCount(valuePtr); + if (valueObj != NULL) { + Tcl_IncrRefCount(valueObj); } - return valuePtr; + return valueObj; } /* * If the list is shared, make a copy we can modify (copy-on-write). We * use Tcl_DuplicateObj() instead of TclListObjCopy() for a few reasons: - * 1) we have not yet confirmed listPtr is actually a list; 2) We make a + * 1) we have not yet confirmed listObj is actually a list; 2) We make a * verbatim copy of any existing string rep, and when we combine that with * the delayed invalidation of string reps of modified Tcl_Obj's * implemented below, the outcome is that any error condition that causes - * this routine to return NULL, will leave the string rep of listPtr and + * this routine to return NULL, will leave the string rep of listObj and * all elements to be unchanged. */ - subListPtr = Tcl_IsShared(listPtr) ? Tcl_DuplicateObj(listPtr) : listPtr; + subListObj = Tcl_IsShared(listObj) ? Tcl_DuplicateObj(listObj) : listObj; /* * Anchor the linked list of Tcl_Obj's whose string reps must be * invalidated if the operation succeeds. */ - retValuePtr = subListPtr; - chainPtr = NULL; + retValueObj = subListObj; result = TCL_OK; + /* Allocate if static array for pending invalidations is too small */ + if (indexCount + > (int) (sizeof(pendingInvalidates) / sizeof(pendingInvalidates[0]))) { + pendingInvalidatesPtr = + (Tcl_Obj **) Tcl_Alloc(indexCount * sizeof(*pendingInvalidatesPtr)); + } + /* * Loop through all the index arguments, and for each one dive into the * appropriate sublist. @@ -1530,8 +2762,8 @@ TclLsetFlat( * Check for the possible error conditions... */ - if (TclListObjGetElementsM(interp, subListPtr, &elemCount, &elemPtrs) - != TCL_OK) { + if (TclListObjGetElementsM(interp, subListObj, &elemCount, &elemPtrs) + != TCL_OK) { /* ...the sublist we're indexing into isn't a list at all. */ result = TCL_ERROR; break; @@ -1543,22 +2775,27 @@ TclLsetFlat( */ if (TclGetIntForIndexM(interp, *indexArray, elemCount - 1, &index) - != TCL_OK) { + != TCL_OK) { /* ...the index we're trying to use isn't an index at all. */ result = TCL_ERROR; - indexArray++; + indexArray++; /* Why bother with this increment? TBD */ break; } indexArray++; if (index > elemCount - || (valuePtr == NULL && index >= elemCount)) { + || (valueObj == NULL && index >= elemCount)) { /* ...the index points outside the sublist. */ if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "index \"%s\" out of range", Tcl_GetString(indexArray[-1]))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" - "OUTOFRANGE", NULL); + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("index \"%s\" out of range", + Tcl_GetString(indexArray[-1]))); + Tcl_SetErrorCode(interp, + "TCL", + "VALUE", + "INDEX" + "OUTOFRANGE", + NULL); } result = TCL_ERROR; break; @@ -1566,128 +2803,126 @@ TclLsetFlat( /* * No error conditions. As long as we're not yet on the last index, - * determine the next sublist for the next pass through the loop, and - * take steps to make sure it is an unshared copy, as we intend to - * modify it. + * determine the next sublist for the next pass through the loop, + * and take steps to make sure it is an unshared copy, as we intend + * to modify it. */ if (--indexCount) { - parentList = subListPtr; - if (index == (size_t)elemCount) { - TclNewObj(subListPtr); + parentList = subListObj; + if (index == elemCount) { + TclNewObj(subListObj); } else { - subListPtr = elemPtrs[index]; + subListObj = elemPtrs[index]; } - if (Tcl_IsShared(subListPtr)) { - subListPtr = Tcl_DuplicateObj(subListPtr); + if (Tcl_IsShared(subListObj)) { + subListObj = Tcl_DuplicateObj(subListObj); } /* * Replace the original elemPtr[index] in parentList with a copy * we know to be unshared. This call will also deal with the * situation where parentList shares its internalrep with other - * Tcl_Obj's. Dealing with the shared internalrep case can cause - * subListPtr to become shared again, so detect that case and make - * and store another copy. + * Tcl_Obj's. Dealing with the shared internalrep case can + * cause subListObj to become shared again, so detect that case + * and make and store another copy. */ - if (index == (size_t)elemCount) { - Tcl_ListObjAppendElement(NULL, parentList, subListPtr); + if (index == elemCount) { + Tcl_ListObjAppendElement(NULL, parentList, subListObj); } else { - TclListObjSetElement(NULL, parentList, index, subListPtr); + TclListObjSetElement(NULL, parentList, index, subListObj); } - if (Tcl_IsShared(subListPtr)) { - subListPtr = Tcl_DuplicateObj(subListPtr); - TclListObjSetElement(NULL, parentList, index, subListPtr); + if (Tcl_IsShared(subListObj)) { + subListObj = Tcl_DuplicateObj(subListObj); + TclListObjSetElement(NULL, parentList, index, subListObj); } /* - * The TclListObjSetElement() calls do not spoil the string rep of - * parentList, and that's fine for now, since all we've done so - * far is replace a list element with an unshared copy. The list - * value remains the same, so the string rep. is still valid, and - * unchanged, which is good because if this whole routine returns - * NULL, we'd like to leave no change to the value of the lset - * variable. Later on, when we set valuePtr in its proper place, - * then all containing lists will have their values changed, and - * will need their string reps spoiled. We maintain a list of all - * those Tcl_Obj's (via a little internalrep surgery) so we can spoil - * them at that time. + * The TclListObjSetElement() calls do not spoil the string rep + * of parentList, and that's fine for now, since all we've done + * so far is replace a list element with an unshared copy. The + * list value remains the same, so the string rep. is still + * valid, and unchanged, which is good because if this whole + * routine returns NULL, we'd like to leave no change to the + * value of the lset variable. Later on, when we set valueObj + * in its proper place, then all containing lists will have + * their values changed, and will need their string reps + * spoiled. We maintain a list of all those Tcl_Obj's (via a + * little internalrep surgery) so we can spoil them at that + * time. */ - irPtr = TclFetchInternalRep(parentList, &tclListType); - irPtr->twoPtrValue.ptr2 = chainPtr; - chainPtr = parentList; + pendingInvalidatesPtr[numPendingInvalidates] = parentList; + ++numPendingInvalidates; } } while (indexCount > 0); /* * Either we've detected and error condition, and exited the loop with * result == TCL_ERROR, or we've successfully reached the last index, and - * we're ready to store valuePtr. In either case, we need to clean up our - * string spoiling list of Tcl_Obj's. + * we're ready to store valueObj. On success, we need to invalidate + * the string representations of intermediate lists whose contained + * list element would have changed. */ + if (result == TCL_OK) { + while (numPendingInvalidates > 0) { + Tcl_Obj *objPtr; - while (chainPtr) { - Tcl_Obj *objPtr = chainPtr; - List *listRepPtr; - - /* - * Clear away our internalrep surgery mess. - */ - - irPtr = TclFetchInternalRep(objPtr, &tclListType); - listRepPtr = (List *)irPtr->twoPtrValue.ptr1; - chainPtr = (Tcl_Obj *)irPtr->twoPtrValue.ptr2; - - if (result == TCL_OK) { - - /* - * We're going to store valuePtr, so spoil string reps of all - * containing lists. - */ - - listRepPtr->refCount++; - TclFreeInternalRep(objPtr); - ListSetInternalRep(objPtr, listRepPtr); - listRepPtr->refCount--; + --numPendingInvalidates; + objPtr = pendingInvalidatesPtr[numPendingInvalidates]; - TclInvalidateStringRep(objPtr); - } else { - irPtr->twoPtrValue.ptr2 = NULL; + if (result == TCL_OK) { + /* + * We're going to store valueObj, so spoil string reps of all + * containing lists. + * TODO - historically, the storing of the internal rep was done + * because the ptr2 field of the internal rep was used to chain + * objects whose string rep needed to be invalidated. Now this + * is no longer the case, so replacing of the internal rep + * should not be needed. The TclInvalidateStringRep should + * suffice. Formulate a test case before changing. + */ + ListRep objInternalRep; + TclListObjGetRep(NULL, objPtr, &objInternalRep); + ListObjReplaceRepAndInvalidate(objPtr, &objInternalRep); + } } } + if (pendingInvalidatesPtr != pendingInvalidates) + Tcl_Free(pendingInvalidatesPtr); + if (result != TCL_OK) { /* * Error return; message is already in interp. Clean up any excess * memory. */ - if (retValuePtr != listPtr) { - Tcl_DecrRefCount(retValuePtr); + if (retValueObj != listObj) { + Tcl_DecrRefCount(retValueObj); } return NULL; } /* - * Store valuePtr in proper sublist and return. The TCL_INDEX_NONE is - * to avoid a compiler warning (not a problem because we checked that - * we have a proper list - or something convertible to one - above). + * Store valueObj in proper sublist and return. The -1 is to avoid a + * compiler warning (not a problem because we checked that we have a + * proper list - or something convertible to one - above). */ - len = TCL_INDEX_NONE; - TclListObjLengthM(NULL, subListPtr, &len); - if (valuePtr == NULL) { - Tcl_ListObjReplace(NULL, subListPtr, index, 1, 0, NULL); - } else if (index == (size_t)len) { - Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr); + len = -1; + TclListObjLengthM(NULL, subListObj, &len); + if (valueObj == NULL) { + Tcl_ListObjReplace(NULL, subListObj, index, 1, 0, NULL); + } else if (index == len) { + Tcl_ListObjAppendElement(NULL, subListObj, valueObj); } else { - TclListObjSetElement(NULL, subListPtr, index, valuePtr); - TclInvalidateStringRep(subListPtr); + TclListObjSetElement(NULL, subListObj, index, valueObj); + TclInvalidateStringRep(subListObj); } - Tcl_IncrRefCount(retValuePtr); - return retValuePtr; + Tcl_IncrRefCount(retValueObj); + return retValueObj; } /* @@ -1695,38 +2930,23 @@ TclLsetFlat( * * TclListObjSetElement -- * - * Set a single element of a list to a specified value. - * - * It is the caller's responsibility to invalidate the string - * representation of the 'listPtr'. + * Set a single element of a list to a specified value * - * Value - * - * TCL_OK - * - * Success. - * - * TCL_ERROR - * - * 'listPtr' does not refer to a list object and cannot be converted - * to one. An error message will be left in the interpreter result if - * interp is not NULL. - * - * TCL_ERROR - * - * An index designates an element outside the range [0..listLength-1], - * where 'listLength' is the count of elements in the list object - * designated by 'listPtr'. An error message is left in the - * interpreter result. - * - * Effect - * - * If 'listPtr' designates a shared object, 'Tcl_Panic' is called. If - * 'listPtr' is not already of type 'tclListType', it is converted and the - * internal representation is unshared. The 'refCount' of the element at - * 'index' is decremented and replaced in the list with the 'valuePtr', - * whose 'refCount' in turn is incremented. + * Results: + * The return value is normally TCL_OK. If listObj does not refer to a + * list object and cannot be converted to one, TCL_ERROR is returned and + * an error message will be left in the interpreter result if interp is + * not NULL. Similarly, if index designates an element outside the range + * [0..listLength-1], where listLength is the count of elements in the + * list object designated by listObj, TCL_ERROR is returned and an error + * message is left in the interpreter result. * + * Side effects: + * Tcl_Panic if listObj designates a shared object. Otherwise, attempts + * to convert it to a list with a non-shared internal rep. Decrements the + * ref count of the object at the specified index within the list, + * replaces with the object designated by valueObj, and increments the + * ref count of the replacement object. * *---------------------------------------------------------------------- */ @@ -1735,53 +2955,29 @@ int TclListObjSetElement( Tcl_Interp *interp, /* Tcl interpreter; used for error reporting * if not NULL. */ - Tcl_Obj *listPtr, /* List object in which element should be + Tcl_Obj *listObj, /* List object in which element should be * stored. */ - size_t index, /* Index of element to store. */ - Tcl_Obj *valuePtr) /* Tcl object to store in the designated list + size_t index, /* Index of element to store. */ + Tcl_Obj *valueObj) /* Tcl object to store in the designated list * element. */ { - List *listRepPtr; /* Internal representation of the list being - * modified. */ - Tcl_Obj **elemPtrs; /* Pointers to elements of the list. */ + ListRep listRep; + Tcl_Obj **elemPtrs; /* Pointers to elements of the list. */ size_t elemCount; /* Number of elements in the list. */ - /* - * Ensure that the listPtr parameter designates an unshared list. - */ + /* Ensure that the listObj parameter designates an unshared list. */ - if (Tcl_IsShared(listPtr)) { + if (Tcl_IsShared(listObj)) { Tcl_Panic("%s called with shared object", "TclListObjSetElement"); } - ListGetInternalRep(listPtr, listRepPtr); - if (listRepPtr == NULL) { - int result; - size_t length; - - (void) Tcl_GetStringFromObj(listPtr, &length); - if (length == 0) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "index \"%" TCL_Z_MODIFIER "u\" out of range", index)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", - "OUTOFRANGE", NULL); - } - return TCL_ERROR; - } - result = SetListFromAny(interp, listPtr); - if (result != TCL_OK) { - return result; - } - ListGetInternalRep(listPtr, listRepPtr); + if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) { + return TCL_ERROR; } - elemCount = listRepPtr->elemCount; - - /* - * Ensure that the index is in bounds. - */ + elemCount = ListRepLength(&listRep); + /* Ensure that the index is in bounds. */ if (index>=elemCount) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1792,66 +2988,27 @@ TclListObjSetElement( return TCL_ERROR; } - /* - * If the internal rep is shared, replace it with an unshared copy. - */ - - if (listRepPtr->refCount > 1) { - Tcl_Obj **dst, **src = listRepPtr->elements; - List *newPtr = AttemptNewList(NULL, listRepPtr->maxElemCount, NULL); - - if (newPtr == NULL) { - newPtr = AttemptNewList(interp, elemCount, NULL); - if (newPtr == NULL) { - return TCL_ERROR; - } - } - newPtr->refCount++; - newPtr->elemCount = elemCount; - newPtr->canonicalFlag = listRepPtr->canonicalFlag; - - dst = newPtr->elements; - while (elemCount--) { - *dst = *src++; - Tcl_IncrRefCount(*dst++); - } - - listRepPtr->refCount--; - - listRepPtr = newPtr; - ListResetInternalRep(listPtr, listRepPtr); + /* Replace a shared internal rep with an unshared copy */ + if (listRep.storePtr->refCount > 1) { + ListRep newInternalRep; + /* TODO - leave extra space? */ + ListRepClone(&listRep, &newInternalRep, LISTREP_PANIC_ON_FAIL); + listRep = newInternalRep; } - elemPtrs = listRepPtr->elements; - - /* - * Add a reference to the new list element. - */ - Tcl_IncrRefCount(valuePtr); + /* Retrieve element array AFTER potential cloning above */ + ListRepElements(&listRep, elemCount, elemPtrs); /* - * Remove a reference from the old list element. + * Add a reference to the new list element and remove from old before + * replacing it. Order is important! */ - + Tcl_IncrRefCount(valueObj); Tcl_DecrRefCount(elemPtrs[index]); + elemPtrs[index] = valueObj; - /* - * Stash the new object in the list. - */ - - elemPtrs[index] = valuePtr; - - /* - * Invalidate outdated internalreps. - */ - - ListGetInternalRep(listPtr, listRepPtr); - listRepPtr->refCount++; - TclFreeInternalRep(listPtr); - ListSetInternalRep(listPtr, listRepPtr); - listRepPtr->refCount--; - - TclInvalidateStringRep(listPtr); + /* Internal rep may be cloned so replace */ + ListObjReplaceRepAndInvalidate(listObj, &listRep); return TCL_OK; } @@ -1861,11 +3018,13 @@ TclListObjSetElement( * * FreeListInternalRep -- * - * Deallocate the storage associated with the internal representation of a - * a list object. + * Deallocate the storage associated with a list object's internal + * representation. * - * Effect + * Results: + * None. * + * Side effects: * Frees listPtr's List* internal representation, if no longer shared. * May decrement the ref counts of element objects, which may free them. * @@ -1874,21 +3033,19 @@ TclListObjSetElement( static void FreeListInternalRep( - Tcl_Obj *listPtr) /* List object with internal rep to free. */ + Tcl_Obj *listObj) /* List object with internal rep to free. */ { - List *listRepPtr; - - ListGetInternalRep(listPtr, listRepPtr); - assert(listRepPtr != NULL); - - if (listRepPtr->refCount-- <= 1) { - Tcl_Obj **elemPtrs = listRepPtr->elements; - int i, numElems = listRepPtr->elemCount; - - for (i = 0; i < numElems; i++) { - Tcl_DecrRefCount(elemPtrs[i]); - } - Tcl_Free(listRepPtr); + ListRep listRep; + + ListObjGetRep(listObj, &listRep); + if (listRep.storePtr->refCount-- <= 1) { + ObjArrayDecrRefs( + listRep.storePtr->slots, + listRep.storePtr->firstUsed, listRep.storePtr->numUsed); + Tcl_Free(listRep.storePtr); + } + if (listRep.spanPtr) { + ListSpanDecrRefs(listRep.spanPtr); } } @@ -1897,47 +3054,43 @@ FreeListInternalRep( * * DupListInternalRep -- * - * Initialize the internal representation of a list 'Tcl_Obj' to share the + * Initialize the internal representation of a list Tcl_Obj to share the * internal representation of an existing list object. * - * Effect + * Results: + * None. * - * The 'refCount' of the List internal rep is incremented. + * Side effects: + * The reference count of the List internal rep is incremented. * *---------------------------------------------------------------------- */ static void DupListInternalRep( - Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - Tcl_Obj *copyPtr) /* Object with internal rep to set. */ + Tcl_Obj *srcObj, /* Object with internal rep to copy. */ + Tcl_Obj *copyObj) /* Object with internal rep to set. */ { - List *listRepPtr; - - ListGetInternalRep(srcPtr, listRepPtr); - assert(listRepPtr != NULL); - ListSetInternalRep(copyPtr, listRepPtr); + ListRep listRep; + ListObjGetRep(srcObj, &listRep); + ListObjOverwriteRep(copyObj, &listRep); } - + /* *---------------------------------------------------------------------- * * SetListFromAny -- * - * Convert any object to a list. - * - * Value - * - * TCL_OK - * - * Success. The internal representation of 'objPtr' is set, and the type - * of 'objPtr' is 'tclListType'. + * Attempt to generate a list internal form for the Tcl object "objPtr". * - * TCL_ERROR - * - * An error occured during conversion. An error message is left in the - * interpreter's result if 'interp' is not NULL. + * Results: + * The return value is TCL_OK or TCL_ERROR. If an error occurs during + * conversion, an error message is left in the interpreter's result + * unless "interp" is NULL. * + * Side effects: + * If no error occurs, a list is stored as "objPtr"s internal + * representation. * *---------------------------------------------------------------------- */ @@ -1947,8 +3100,8 @@ SetListFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr) /* The object to convert. */ { - List *listRepPtr; Tcl_Obj **elemPtrs; + ListRep listRep; /* * Dictionaries are a special case; they have a string representation such @@ -1962,7 +3115,7 @@ SetListFromAny( Tcl_Obj *keyPtr, *valuePtr; Tcl_DictSearch search; int done; - size_t size; + ListSizeT size; /* * Create the new list representation. Note that we do not need to do @@ -1974,17 +3127,22 @@ SetListFromAny( */ Tcl_DictObjSize(NULL, objPtr, &size); - listRepPtr = AttemptNewList(interp, size > 0 ? 2*size : 1, NULL); - if (!listRepPtr) { + /* TODO - leave space in front and/or back? */ + if (ListRepInitAttempt( + interp, size > 0 ? 2 * size : 1, NULL, &listRep) + != TCL_OK) { return TCL_ERROR; } - listRepPtr->elemCount = 2 * size; - /* - * Populate the list representation. - */ + LIST_ASSERT(listRep.spanPtr == NULL); /* Guard against future changes */ + LIST_ASSERT(listRep.storePtr->firstUsed == 0); + LIST_ASSERT((listRep.storePtr->flags & LISTSTORE_CANONICAL) == 0); + + listRep.storePtr->numUsed = 2 * size; - elemPtrs = listRepPtr->elements; + /* Populate the list representation. */ + + elemPtrs = listRep.storePtr->slots; Tcl_DictObjFirst(NULL, objPtr, &search, &keyPtr, &valuePtr, &done); while (!done) { *elemPtrs++ = keyPtr; @@ -1994,7 +3152,7 @@ SetListFromAny( Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); } } else { - size_t estCount, length; + ListSizeT estCount, length; const char *limit, *nextElem = Tcl_GetStringFromObj(objPtr, &length); /* @@ -2005,15 +3163,18 @@ SetListFromAny( estCount = TclMaxListLength(nextElem, length, &limit); estCount += (estCount == 0); /* Smallest list struct holds 1 * element. */ - listRepPtr = AttemptNewList(interp, estCount, NULL); - if (listRepPtr == NULL) { + /* TODO - allocate additional space? */ + if (ListRepInitAttempt(interp, estCount, NULL, &listRep) + != TCL_OK) { return TCL_ERROR; } - elemPtrs = listRepPtr->elements; - /* - * Each iteration, parse and store a list element. - */ + LIST_ASSERT(listRep.spanPtr == NULL); /* Guard against future changes */ + LIST_ASSERT(listRep.storePtr->firstUsed == 0); + + elemPtrs = listRep.storePtr->slots; + + /* Each iteration, parse and store a list element. */ while (nextElem < limit) { const char *elemStart; @@ -2023,11 +3184,11 @@ SetListFromAny( if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem, &elemStart, &nextElem, &elemSize, &literal)) { - fail: - while (--elemPtrs >= listRepPtr->elements) { +fail: + while (--elemPtrs >= listRep.storePtr->slots) { Tcl_DecrRefCount(*elemPtrs); } - Tcl_Free(listRepPtr); + Tcl_Free(listRep.storePtr); return TCL_ERROR; } if (elemStart == limit) { @@ -2039,11 +3200,7 @@ SetListFromAny( check = Tcl_InitStringRep(*elemPtrs, literal ? elemStart : NULL, elemSize); if (elemSize && check == NULL) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot construct list, out of memory", -1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } + MemoryAllocationError(interp, elemSize); goto fail; } if (!literal) { @@ -2054,16 +3211,29 @@ SetListFromAny( Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */ } - listRepPtr->elemCount = elemPtrs - listRepPtr->elements; + listRep.storePtr->numUsed = + elemPtrs - listRep.storePtr->slots; } + LISTREP_CHECK(&listRep); + /* * Store the new internalRep. We do this as late * as possible to allow the conversion code, in particular * Tcl_GetStringFromObj, to use the old internalRep. */ - ListSetInternalRep(objPtr, listRepPtr); + /* + * Note old string representation NOT to be invalidated. + * So do NOT use ListObjReplaceRepAndInvalidate. InternalRep to be freed AFTER + * IncrRefs so do not use ListObjOverwriteRep + */ + ListRepIncrRefs(&listRep); + TclFreeInternalRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = listRep.storePtr; + objPtr->internalRep.twoPtrValue.ptr2 = listRep.spanPtr; + objPtr->typePtr = &tclListType; + return TCL_OK; } @@ -2072,73 +3242,84 @@ SetListFromAny( * * UpdateStringOfList -- * - * Update the string representation for a list object. - * - * Any previously-exising string representation is not invalidated, so - * storage is lost if this has not been taken care of. + * Update the string representation for a list object. Note: This + * function does not invalidate an existing old string rep so storage + * will be lost if this has not already been done. * - * Effect + * Results: + * None. * - * The string representation of 'listPtr' is set to the resulting string. - * This string will be empty if the list has no elements. It is assumed - * that the list internal representation is not NULL. + * Side effects: + * The object's string is set to a valid string that results from the + * list-to-string conversion. This string will be empty if the list has + * no elements. The list internal representation should not be NULL and + * we assume it is not NULL. * *---------------------------------------------------------------------- */ static void UpdateStringOfList( - Tcl_Obj *listPtr) /* List object with string rep to update. */ + Tcl_Obj *listObj) /* List object with string rep to update. */ { # define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; - size_t numElems, i, length, bytesNeeded = 0; + ListSizeT numElems, i, length, bytesNeeded = 0; const char *elem, *start; char *dst; Tcl_Obj **elemPtrs; - List *listRepPtr; + ListRep listRep; - ListGetInternalRep(listPtr, listRepPtr); + ListObjGetRep(listObj, &listRep); + LISTREP_CHECK(&listRep); - assert(listRepPtr != NULL); - - numElems = listRepPtr->elemCount; + ListRepElements(&listRep, numElems, elemPtrs); /* * Mark the list as being canonical; although it will now have a string * rep, it is one we derived through proper "canonical" quoting and so * it's known to be free from nasties relating to [concat] and [eval]. + * However, we only do this if this is not a spanned list. Marking the + * storage canonical for a spanned list make ALL lists using the storage + * canonical which is not right. (Consider a list generated from a + * string and then this function called for a spanned list generated + * from it). On the other hand, a spanned list is always canonical + * (never generated from a string) so it does not have to be explicitly + * marked as such. The ListObjIsCanonical macro takes this into account. + * See the comments there. */ + if (listRep.spanPtr == NULL) { + LIST_ASSERT(listRep.storePtr->firstUsed == 0);/* Invariant */ + listRep.storePtr->flags |= LISTSTORE_CANONICAL; + } - listRepPtr->canonicalFlag = 1; - - /* - * Handle empty list case first, so rest of the routine is simpler. - */ + /* Handle empty list case first, so rest of the routine is simpler. */ if (numElems == 0) { - Tcl_InitStringRep(listPtr, NULL, 0); + Tcl_InitStringRep(listObj, NULL, 0); return; } - /* - * Pass 1: estimate space, gather flags. - */ + /* Pass 1: estimate space, gather flags. */ if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; } else { - /* - * We know numElems <= LIST_MAX, so this is safe. - */ - + /* We know numElems <= LIST_MAX, so this is safe. */ flagPtr = (char *)Tcl_Alloc(numElems); } - elemPtrs = listRepPtr->elements; for (i = 0; i < numElems; i++) { flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0); elem = Tcl_GetStringFromObj(elemPtrs[i], &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i); + if (bytesNeeded < 0) { + /* TODO - what is the max #define for Tcl9? */ + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + } + /* TODO - what is the max #define for Tcl9? */ + if (bytesNeeded > INT_MAX - numElems + 1) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } bytesNeeded += numElems - 1; @@ -2146,7 +3327,7 @@ UpdateStringOfList( * Pass 2: copy into string rep buffer. */ - start = dst = Tcl_InitStringRep(listPtr, NULL, bytesNeeded); + start = dst = Tcl_InitStringRep(listObj, NULL, bytesNeeded); TclOOM(dst, bytesNeeded); for (i = 0; i < numElems; i++) { flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0); @@ -2156,7 +3337,7 @@ UpdateStringOfList( } /* Set the string length to what was actually written, the safe choice */ - (void) Tcl_InitStringRep(listPtr, NULL, dst - 1 - start); + (void) Tcl_InitStringRep(listObj, NULL, dst - 1 - start); if (flagPtr != localFlags) { Tcl_Free(flagPtr); diff --git a/tests-perf/comparePerf.tcl b/tests-perf/comparePerf.tcl new file mode 100644 index 0000000..f35da21 --- /dev/null +++ b/tests-perf/comparePerf.tcl @@ -0,0 +1,371 @@ +#!/usr/bin/tclsh +# ------------------------------------------------------------------------ +# +# comparePerf.tcl -- +# +# Script to compare performance data from multiple runs. +# +# ------------------------------------------------------------------------ +# +# See the file "license.terms" for information on usage and redistribution +# of this file. +# +# Usage: +# tclsh comparePerf.tcl [--regexp RE] [--ratio time|rate] [--combine] [--base BASELABEL] PERFFILE ... +# +# The test data from each input file is tabulated so as to compare the results +# of test runs. If a PERFFILE does not exist, it is retried by adding the +# .perf extension. If the --regexp is specified, only test results whose +# id matches RE are examined. +# +# If the --combine option is specified, results of test sets with the same +# label are combined and averaged in the output. +# +# If the --base option is specified, the BASELABEL is used as the label to use +# the base timing. Otherwise, the label of the first data file is used. +# +# If --ratio option is "time" the ratio of test timing vs base test timing +# is shown. If "rate" (default) the inverse is shown. +# +# If --no-header is specified, the header describing test configuration is +# not output. +# +# The format of input files is as follows: +# +# Each line must begin with one of the characters below followed by a space +# followed by a string whose semantics depend on the initial character. +# E - Full path to the Tcl executable that was used to generate the file +# V - The Tcl patchlevel of the implementation +# D - A description for the test run for human consumption +# L - A label used to identify run environment. The --combine option will +# average all measuremets that have the same label. An input file without +# a label is treated as having a unique label and not combined with any other. +# P - A test measurement (see below) +# R - The number of runs made for the each test +# # - A comment, may be an arbitrary string. Usually included in performance +# data to describe the test. This is silently ignored +# +# Any lines not matching one of the above are ignored with a warning to stderr. +# +# A line beginning with the "P" marker is a test measurement. The first word +# following is a floating point number representing the test runtime. +# The remaining line (after trimming of whitespace) is the id of the test. +# Test generators are encouraged to make the id a well-defined machine-parseable +# as well human readable description of the test. The id must not appear more +# than once. An example test measurement line: +# P 2.32280 linsert in unshared L[10000] 1 elems 10000 times at 0 (var) +# Note here the iteration count is not present. +# + +namespace eval perf::compare { + # List of dictionaries, one per input file + variable PerfData +} + +proc perf::compare::warn {message} { + puts stderr "Warning: $message" +} +proc perf::compare::print {text} { + puts stdout $text +} +proc perf::compare::slurp {testrun_path} { + variable PerfData + + set runtimes [dict create] + + set path [file normalize $testrun_path] + set fd [open $path] + array set header {} + while {[gets $fd line] >= 0} { + set line [regsub -all {\s+} [string trim $line] " "] + switch -glob -- $line { + "#*" { + # Skip comments + } + "R *" - + "L *" - + "D *" - + "V *" - + "T *" - + "E *" { + set marker [lindex $line 0] + if {[info exists header($marker)]} { + warn "Ignoring $marker record (duplicate): \"$line\"" + } + set header($marker) [string range $line 2 end] + } + "P *" { + if {[scan $line "P %f %n" runtime id_start] == 2} { + set id [string range $line $id_start end] + if {[dict exists $runtimes $id]} { + warn "Ignoring duplicate test id \"$id\"" + } else { + dict set runtimes $id $runtime + } + } else { + warn "Invalid test result line format: \"$line\"" + } + } + default { + puts stderr "Warning: ignoring unrecognized line \"$line\"" + } + } + } + close $fd + + set result [dict create Input $path Runtimes $runtimes] + foreach {c k} { + L Label + V Version + E Executable + D Description + } { + if {[info exists header($c)]} { + dict set result $k $header($c) + } + } + + return $result +} + +proc perf::compare::burp {test_sets} { + variable Options + + # Print the key for each test run + set header " " + set separator " " + foreach test_set $test_sets { + set test_set_key "\[[incr test_set_num]\]" + if {! $Options(--no-header)} { + print "$test_set_key" + foreach k {Label Executable Version Input Description} { + if {[dict exists $test_set $k]} { + print "$k: [dict get $test_set $k]" + } + } + } + append header $test_set_key $separator + set separator " "; # Expand because later columns have ratio + } + set header [string trimright $header] + + if {! $Options(--no-header)} { + print "" + if {$Options(--ratio) eq "rate"} { + set ratio_description "ratio of baseline to the measurement (higher is faster)." + } else { + set ratio_description "ratio of measurement to the baseline (lower is faster)." + } + print "The first column \[1\] is the baseline measurement." + print "Subsequent columns are pairs of the additional measurement and " + print $ratio_description + print "" + } + + # Print the actual test run data + + print $header + set test_sets [lassign $test_sets base_set] + set fmt {%#10.5f} + set fmt_ratio {%-6.2f} + foreach {id base_runtime} [dict get $base_set Runtimes] { + if {[info exists Options(--regexp)]} { + if {![regexp $Options(--regexp) $id]} { + continue + } + } + if {$Options(--print-test-number)} { + set line "[format %-4s [incr counter].]" + } else { + set line "" + } + append line [format $fmt $base_runtime] + foreach test_set $test_sets { + if {[dict exists $test_set Runtimes $id]} { + set runtime [dict get $test_set Runtimes $id] + if {$Options(--ratio) eq "time"} { + if {$base_runtime != 0} { + set ratio [format $fmt_ratio [expr {$runtime/$base_runtime}]] + } else { + if {$runtime == 0} { + set ratio "NaN " + } else { + set ratio "Inf " + } + } + } else { + if {$runtime != 0} { + set ratio [format $fmt_ratio [expr {$base_runtime/$runtime}]] + } else { + if {$base_runtime == 0} { + set ratio "NaN " + } else { + set ratio "Inf " + } + } + } + append line "|" [format $fmt $runtime] "|" $ratio + } else { + append line [string repeat { } 11] + } + } + append line "|" $id + print $line + } +} + +proc perf::compare::chew {test_sets} { + variable Options + + # Combine test sets that have the same label, averaging the values + set unlabeled_sets {} + array set labeled_sets {} + + foreach test_set $test_sets { + # If there is no label, treat as independent set + if {![dict exists $test_set Label]} { + lappend unlabeled_sets $test_set + } else { + lappend labeled_sets([dict get $test_set Label]) $test_set + } + } + + foreach label [array names labeled_sets] { + set combined_set [lindex $labeled_sets($label) 0] + set runtimes [dict get $combined_set Runtimes] + foreach test_set [lrange $labeled_sets($label) 1 end] { + dict for {id timing} [dict get $test_set Runtimes] { + dict lappend runtimes $id $timing + } + } + dict for {id timings} $runtimes { + set total [tcl::mathop::+ {*}$timings] + dict set runtimes $id [expr {$total/[llength $timings]}] + } + dict set combined_set Runtimes $runtimes + set labeled_sets($label) $combined_set + } + + # Choose the "base" test set + if {![info exists Options(--base)]} { + set first_set [lindex $test_sets 0] + if {[dict exists $first_set Label]} { + # Use label of first as the base + set Options(--base) [dict get $first_set Label] + } + } + + if {[info exists Options(--base)] && $Options(--base) ne ""} { + lappend combined_sets $labeled_sets($Options(--base));# Will error if no such + unset labeled_sets($Options(--base)) + } else { + lappend combined_sets [lindex $unlabeled_sets 0] + set unlabeled_sets [lrange $unlabeled_sets 1 end] + } + foreach label [array names labeled_sets] { + lappend combined_sets $labeled_sets($label) + } + lappend combined_sets {*}$unlabeled_sets + + return $combined_sets +} + +proc perf::compare::setup {argv} { + variable Options + + array set Options { + --ratio rate + --combine 0 + --print-test-number 0 + --no-header 0 + } + while {[llength $argv]} { + set argv [lassign $argv arg] + switch -glob -- $arg { + -r - + --regexp { + if {[llength $argv] == 0} { + error "Missing value for option $arg" + } + set argv [lassign $argv val] + set Options(--regexp) $val + } + --ratio { + if {[llength $argv] == 0} { + error "Missing value for option $arg" + } + set argv [lassign $argv val] + if {$val ni {time rate}} { + error "Value for option $arg must be either \"time\" or \"rate\"" + } + set Options(--ratio) $val + } + --print-test-number - + --combine - + --no-header { + set Options($arg) 1 + } + --base { + if {[llength $argv] == 0} { + error "Missing value for option $arg" + } + set argv [lassign $argv val] + set Options($arg) $val + } + -- { + # Remaining will be passed back to the caller + break + } + --* { + error "Unknown option $arg" + } + -* { + error "Unknown option -[lindex $arg 0]" + } + default { + # Remaining will be passed back to the caller + set argv [linsert $argv 0 $arg] + break; + } + } + } + + set paths {} + foreach path $argv { + set path [file join $path]; # Convert from native else glob fails + if {[file isfile $path]} { + lappend paths $path + continue + } + if {[file isfile $path.perf]} { + lappend paths $path.perf + continue + } + lappend paths {*}[glob -nocomplain $path] + } + return $paths +} +proc perf::compare::main {} { + variable Options + + set paths [setup $::argv] + if {[llength $paths] == 0} { + error "No test data files specified." + } + set test_data [list ] + set seen [dict create] + foreach path $paths { + if {![dict exists $seen $path]} { + lappend test_data [slurp $path] + dict set seen $path "" + } + } + + if {$Options(--combine)} { + set test_data [chew $test_data] + } + + burp $test_data +} + +perf::compare::main diff --git a/tests-perf/listPerf.tcl b/tests-perf/listPerf.tcl new file mode 100644 index 0000000..4472810 --- /dev/null +++ b/tests-perf/listPerf.tcl @@ -0,0 +1,1290 @@ +#!/usr/bin/tclsh +# ------------------------------------------------------------------------ +# +# listPerf.tcl -- +# +# This file provides performance tests for list operations. +# +# ------------------------------------------------------------------------ +# +# See the file "license.terms" for information on usage and redistribution +# of this file. +# +# Note: this file does not use the test-performance.tcl framework as we want +# more direct control over timerate options. + +catch {package require twapi} + +namespace eval perf::list { + variable perfScript [file normalize [info script]] + + # Test for each of these lengths + variable Lengths {10 100 1000 10000} + + variable RunTimes + set RunTimes(command) 0.0 + set RunTimes(total) 0.0 + + variable Options + array set Options { + --print-comments 0 + --print-iterations 0 + } + + # Procs used for calibrating overhead + proc proc2args {a b} {} + proc proc3args {a b c} {} + + proc print {s} { + puts $s + } + proc print_usage {} { + puts stderr "Usage: [file tail [info nameofexecutable]] $::argv0 \[options\] \[command ...\]" + puts stderr "\t--description DESC\tHuman readable description of test run" + puts stderr "\t--label LABEL\tA label used to identify test environment" + puts stderr "\t--print-comments\tPrint comment for each test" + puts stderr "\t--print-iterations\tPrint number of iterations run for each test" + } + + proc setup {argv} { + variable Options + variable Lengths + + while {[llength $argv]} { + set argv [lassign $argv arg] + switch -glob -- $arg { + --print-comments - + --print-iterations { + set Options($arg) 1 + } + --label - + --description { + if {[llength $argv] == 0} { + error "Missing value for option $arg" + } + set argv [lassign $argv val] + set Options($arg) $val + } + --lengths { + if {[llength $argv] == 0} { + error "Missing value for option $arg" + } + set argv [lassign $argv val] + set Lengths $val + } + -- { + # Remaining will be passed back to the caller + break + } + --* { + error "Unknown option $arg" + } + default { + # Remaining will be passed back to the caller + set argv [linsert $argv 0 $arg] + break; + } + } + } + + return $argv + } + proc format_timings {us iters} { + variable Options + if {!$Options(--print-iterations)} { + return "[format {%#10.4f} $us]" + } + return "[format {%#10.4f} $us] [format {%8d} $iters]" + } + proc measure {id script args} { + variable NullOverhead + variable RunTimes + variable Options + + set opts(-overhead) "" + set opts(-runs) 5 + while {[llength $args]} { + set args [lassign $args opt] + if {[llength $args] == 0} { + error "No argument supplied for $opt option. Test: $id" + } + set args [lassign $args val] + switch $opt { + -setup - + -cleanup - + -overhead - + -time - + -runs - + -reps { + set opts($opt) $val + } + default { + error "Unknown option $opt. Test: $id" + } + } + } + + set timerate_args {} + if {[info exists opts(-time)]} { + lappend timerate_args $opts(-time) + } + if {[info exists opts(-reps)]} { + if {[info exists opts(-time)]} { + set timerate_args [list $opts(-time) $opts(-reps)] + } else { + # Force the default for first time option + set timerate_args [list 1000 $opts(-reps)] + } + } elseif {[info exists opts(-time)]} { + set timerate_args [list $opts(-time)] + } + if {[info exists opts(-setup)]} { + uplevel 1 $opts(-setup) + } + # Cache the empty overhead to prevent unnecessary delays. Note if you modify + # to cache other scripts, the cache key must be AFTER substituting the + # overhead script in the caller's context. + if {$opts(-overhead) eq ""} { + if {![info exists NullOverhead]} { + set NullOverhead [lindex [timerate {}] 0] + } + set overhead_us $NullOverhead + } else { + # The overhead measurements might use setup so we need to setup + # first and then cleanup in preparation for setting up again for + # the script to be measured + if {[info exists opts(-setup)]} { + uplevel 1 $opts(-setup) + } + set overhead_us [lindex [uplevel 1 [list timerate $opts(-overhead)]] 0] + if {[info exists opts(-cleanup)]} { + uplevel 1 $opts(-cleanup) + } + } + set timings {} + for {set i 0} {$i < $opts(-runs)} {incr i} { + if {[info exists opts(-setup)]} { + uplevel 1 $opts(-setup) + } + lappend timings [uplevel 1 [list timerate -overhead $overhead_us $script {*}$timerate_args]] + if {[info exists opts(-cleanup)]} { + uplevel 1 $opts(-cleanup) + } + } + set timings [lsort -real -index 0 $timings] + if {$opts(-runs) > 15} { + set ignore [expr {$opts(-runs)/8}] + } elseif {$opts(-runs) >= 5} { + set ignore 2 + } else { + set ignore 0 + } + # Ignore highest and lowest + set timings [lrange $timings 0 end-$ignore] + # Average it out + set us 0 + set iters 0 + foreach timing $timings { + set us [expr {$us + [lindex $timing 0]}] + set iters [expr {$iters + [lindex $timing 2]}] + } + set us [expr {$us/[llength $timings]}] + set iters [expr {$iters/[llength $timings]}] + + set RunTimes(command) [expr {$RunTimes(command) + $us}] + print "P [format_timings $us $iters] $id" + } + proc comment {args} { + variable Options + if {$Options(--print-comments)} { + print "# [join $args { }]" + } + } + proc spanned_list {len} { + # Note - for small len, this will not create a spanned list + set delta [expr {$len/8}] + return [lrange [lrepeat [expr {$len+(2*$delta)}] a] $delta [expr {$delta+$len-1}]] + } + proc print_separator {command} { + comment [string repeat = 80] + comment Command: $command + } + + oo::class create ListPerf { + constructor {args} { + my variable Opts + # Note default Opts can be overridden in construct as well as in measure + set Opts [dict merge { + -setup { + set L [lrepeat $len a] + set Lspan [perf::list::spanned_list $len] + } -cleanup { + unset -nocomplain L + unset -nocomplain Lspan + unset -nocomplain L2 + } + } $args] + } + method measure {comment script locals args} { + my variable Opts + dict with locals {} + ::perf::list::measure $comment $script {*}[dict merge $Opts $args] + } + method option {opt val} { + my variable Opts + dict set Opts $opt $val + } + method option_unset {opt} { + my variable Opts + unset -nocomplain Opts($opt) + } + } + + proc linsert_describe {share_mode len at num iters} { + return "linsert L\[$len\] $share_mode $num elems $iters times at $at" + } + proc linsert_perf {} { + variable Lengths + + print_separator linsert + + ListPerf create perf -overhead {set L {}} -time 1000 + + # Note: Const indices take different path through bytecode than variable + # indices hence separate cases below + + + # Var case + foreach share_mode {shared unshared} { + set idx 0 + if {$share_mode eq "shared"} { + comment == Insert into empty lists + comment Insert one element into empty list + measure [linsert_describe shared 0 "0 (var)" 1 1] {linsert $L $idx ""} -setup {set idx 0; set L {}} + } else { + comment == Insert into empty lists + comment Insert one element into empty list + measure [linsert_describe unshared 0 "0 (var)" 1 1] {linsert {} $idx ""} -setup {set idx 0} + } + foreach idx_str [list 0 1 mid end-1 end] { + foreach len $Lengths { + if {$idx_str eq "mid"} { + set idx [expr {$len/2}] + } else { + set idx $idx_str + } + # perf option -reps $reps + set reps 1000 + if {$share_mode eq "shared"} { + comment Insert once to shared list with variable index + perf measure [linsert_describe shared $len "$idx (var)" 1 1] \ + {linsert $L $idx x} [list len $len idx $idx] -overhead {} -reps 100000 + + comment Insert multiple times to shared list with variable index + perf measure [linsert_describe shared $len "$idx (var)" 1 $reps] { + set L [linsert $L $idx X] + } [list len $len idx $idx] -reps $reps + + comment Insert multiple items multiple times to shared list with variable index + perf measure [linsert_describe shared $len "$idx (var)" 5 $reps] { + set L [linsert $L $idx X X X X X] + } [list len $len idx $idx] -reps $reps + } else { + # NOTE : the Insert once case is left out for unshared lists + # because it requires re-init on every iteration resulting + # in a lot of measurement noise + comment Insert multiple times to unshared list with variable index + perf measure [linsert_describe unshared $len "$idx (var)" 1 $reps] { + set L [linsert $L[set L {}] $idx X] + } [list len $len idx $idx] -reps $reps + comment Insert multiple items multiple times to unshared list with variable index + perf measure [linsert_describe unshared $len "$idx (var)" 5 $reps] { + set L [linsert $L[set L {}] $idx X X X X X] + } [list len $len idx $idx] -reps $reps + } + } + } + } + + # Const index + foreach share_mode {shared unshared} { + if {$share_mode eq "shared"} { + comment == Insert into empty lists + comment Insert one element into empty list + measure [linsert_describe shared 0 "0 (const)" 1 1] {linsert $L 0 ""} -setup {set L {}} + } else { + comment == Insert into empty lists + comment Insert one element into empty list + measure [linsert_describe unshared 0 "0 (const)" 1 1] {linsert {} 0 ""} + } + foreach idx_str [list 0 1 mid end end-1] { + foreach len $Lengths { + # Note end, end-1 explicitly calculated as otherwise they + # are not treated as const + if {$idx_str eq "mid"} { + set idx [expr {$len/2}] + } elseif {$idx_str eq "end"} { + set idx [expr {$len-1}] + } elseif {$idx_str eq "end-1"} { + set idx [expr {$len-2}] + } else { + set idx $idx_str + } + #perf option -reps $reps + set reps 100 + if {$share_mode eq "shared"} { + comment Insert once to shared list with const index + perf measure [linsert_describe shared $len "$idx (const)" 1 1] \ + "linsert \$L $idx x" [list len $len] -overhead {} -reps 10000 + + comment Insert multiple times to shared list with const index + perf measure [linsert_describe shared $len "$idx (const)" 1 $reps] \ + "set L \[linsert \$L $idx X\]" [list len $len] -reps $reps + + comment Insert multiple items multiple times to shared list with const index + perf measure [linsert_describe shared $len "$idx (const)" 5 $reps] \ + "set L \[linsert \$L $idx X X X X X\]" [list len $len] -reps $reps + } else { + comment Insert multiple times to unshared list with const index + perf measure [linsert_describe unshared $len "$idx (const)" 1 $reps] \ + "set L \[linsert \$L\[set L {}\] $idx X]" [list len $len] -reps $reps + + comment Insert multiple items multiple times to unshared list with const index + perf measure [linsert_describe unshared $len "$idx (const)" 5 $reps] \ + "set L \[linsert \$L\[set L {}\] $idx X X X X X]" [list len $len] -reps $reps + } + } + } + } + + # Note: no span tests because the inserts above will themselves create + # spanned lists + + perf destroy + } + + proc list_describe {len text} { + return "list L\[$len\] $text" + } + proc list_perf {} { + variable Lengths + + print_separator list + + ListPerf create perf + foreach len $Lengths { + set s [join [lrepeat $len x]] + comment Create a list from a string + perf measure [list_describe $len "from a string"] {list $s} [list s $s len $len] + } + foreach len $Lengths { + comment Create a list from expansion - single list (special optimal case) + perf measure [list_describe $len "from a {*}list"] {list {*}$L} [list len $len] + comment Create a list from two lists - real test of expansion speed + perf measure [list_describe $len "from a {*}list {*}list"] {list {*}$L {*}$L} [list len [expr {$len/2}]] + } + } + + proc lappend_describe {share_mode len num iters} { + return "lappend L\[$len\] $share_mode $num elems $iters times" + } + proc lappend_perf {} { + variable Lengths + + print_separator lappend + + ListPerf create perf -setup {set L [lrepeat [expr {$len/4}] x]} + + # Shared + foreach len $Lengths { + comment Append to a shared list variable multiple times + perf measure [lappend_describe shared [expr {$len/2}] 1 $len] { + set L2 $L; # Make shared + lappend L x + } [list len $len] -reps $len -overhead {set L2 $L} + } + + # Unshared + foreach len $Lengths { + comment Append to a unshared list variable multiple times + perf measure [lappend_describe unshared [expr {$len/2}] 1 $len] { + lappend L x + } [list len $len] -reps $len + } + + # Span + foreach len $Lengths { + comment Append to a unshared-span list variable multiple times + perf measure [lappend_describe unshared-span [expr {$len/2}] 1 $len] { + lappend Lspan x + } [list len $len] -reps $len + } + + perf destroy + } + + proc lpop_describe {share_mode len at reps} { + return "lpop L\[$len\] $share_mode at $at $reps times" + } + proc lpop_perf {} { + variable Lengths + + print_separator lpop + + ListPerf create perf + + # Shared + perf option -overhead {set L2 $L} + foreach len $Lengths { + set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}] + foreach idx {0 1 end-1 end} { + comment Pop element at position $idx from a shared list variable + perf measure [lpop_describe shared $len $idx $reps] { + set L2 $L + lpop L $idx + } [list len $len idx $idx] -reps $reps + } + } + + # Unshared + perf option -overhead {} + foreach len $Lengths { + set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}] + foreach idx {0 1 end-1 end} { + comment Pop element at position $idx from an unshared list variable + perf measure [lpop_describe unshared $len $idx $reps] { + lpop L $idx + } [list len $len idx $idx] -reps $reps + } + } + + perf destroy + + # Nested + ListPerf create perf -setup { + set L [lrepeat $len [list a b]] + } + + # Shared, nested index + perf option -overhead {set L2 $L; set L L2} + foreach len $Lengths { + set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}] + foreach idx {0 1 end-1 end} { + perf measure [lpop_describe shared $len "{$idx 0}" $reps] { + set L2 $L + lpop L $idx 0 + set L $L2 + } [list len $len idx $idx] -reps $reps + } + } + + # TODO - Nested Unshared + # Not sure how to measure performance. When unshared there is no copy + # so deleting a nested index repeatedly is not feasible + + perf destroy + } + + proc lassign_describe {share_mode len num reps} { + return "lassign L\[$len\] $share_mode $num elems $reps times" + } + proc lassign_perf {} { + variable Lengths + + print_separator lassign + + ListPerf create perf + + foreach share_mode {shared unshared} { + foreach len $Lengths { + if {$share_mode eq "shared"} { + set reps 1000 + comment Reflexive lassign - shared + perf measure [lassign_describe shared $len 1 $reps] { + set L2 $L + set L2 [lassign $L2 v] + } [list len $len] -overhead {set L2 $L} -reps $reps + + comment Reflexive lassign - shared, multiple + perf measure [lassign_describe shared $len 5 $reps] { + set L2 $L + set L2 [lassign $L2 a b c d e] + } [list len $len] -overhead {set L2 $L} -reps $reps + } else { + set reps [expr {($len >= 1000 ? ($len/2) : $len) - 2}] + comment Reflexive lassign - unshared + perf measure [lassign_describe unshared $len 1 $reps] { + set L [lassign $L v] + } [list len $len] -reps $reps + } + } + } + perf destroy + } + + proc lrepeat_describe {len num} { + return "lrepeat L\[$len\] $num elems at a time" + } + proc lrepeat_perf {} { + variable Lengths + + print_separator lrepeat + + ListPerf create perf -reps 100000 + foreach len $Lengths { + comment Generate a list from a single repeated element + perf measure [lrepeat_describe $len 1] { + lrepeat $len a + } [list len $len] + + comment Generate a list from multiple repeated elements + perf measure [lrepeat_describe $len 5] { + lrepeat $len a b c d e + } [list len $len] + } + + perf destroy + } + + proc lreverse_describe {share_mode len} { + return "lreverse L\[$len\] $share_mode" + } + proc lreverse_perf {} { + variable Lengths + + print_separator lreverse + + ListPerf create perf -reps 10000 + + foreach share_mode {shared unshared} { + foreach len $Lengths { + if {$share_mode eq "shared"} { + comment Reverse a shared list + perf measure [lreverse_describe shared $len] { + lreverse $L + } [list len $len] + + if {$len > 100} { + comment Reverse a shared-span list + perf measure [lreverse_describe shared-span $len] { + lreverse $Lspan + } [list len $len] + } + } else { + comment Reverse a unshared list + perf measure [lreverse_describe unshared $len] { + set L [lreverse $L[set L {}]] + } [list len $len] -overhead {set L $L; set L {}} + + if {$len >= 100} { + comment Reverse a unshared-span list + perf measure [lreverse_describe unshared-span $len] { + set Lspan [lreverse $Lspan[set Lspan {}]] + } [list len $len] -overhead {set Lspan $Lspan; set Lspan {}} + } + } + } + } + + perf destroy + } + + proc llength_describe {share_mode len} { + return "llength L\[$len\] $share_mode" + } + proc llength_perf {} { + variable Lengths + + print_separator llength + + ListPerf create perf -reps 100000 + + foreach len $Lengths { + comment Length of a list + perf measure [llength_describe shared $len] { + llength $L + } [list len $len] + + if {$len >= 100} { + comment Length of a span list + perf measure [llength_describe shared-span $len] { + llength $Lspan + } [list len $len] + } + } + + perf destroy + } + + proc lindex_describe {share_mode len at} { + return "lindex L\[$len\] $share_mode at $at" + } + proc lindex_perf {} { + variable Lengths + + print_separator lindex + + ListPerf create perf -reps 100000 + + foreach len $Lengths { + comment Index into a list + set idx [expr {$len/2}] + perf measure [lindex_describe shared $len $idx] { + lindex $L $idx + } [list len $len idx $idx] + + if {$len >= 100} { + comment Index into a span list + perf measure [lindex_describe shared-span $len $idx] { + lindex $Lspan $idx + } [list len $len idx $idx] + } + } + + perf destroy + } + + proc lrange_describe {share_mode len range} { + return "lrange L\[$len\] $share_mode range $range" + } + + proc lrange_perf {} { + variable Lengths + + print_separator lrange + + ListPerf create perf -time 1000 -reps 100000 + + foreach share_mode {shared unshared} { + foreach len $Lengths { + set eighth [expr {$len/8}] + set ranges [list \ + [list 0 0] [list 0 end-1] \ + [list $eighth [expr {3*$eighth}]] \ + [list $eighth [expr {7*$eighth}]] \ + [list 1 end] [list end-1 end] \ + ] + foreach range $ranges { + comment Range $range in $share_mode list of length $len + if {$share_mode eq "shared"} { + perf measure [lrange_describe shared $len $range] \ + "lrange \$L $range" [list len $len range $range] + } else { + perf measure [lrange_describe unshared $len $range] \ + "lrange \[lrepeat \$len\ a] $range" \ + [list len $len range $range] -overhead {lrepeat $len a} + } + } + + if {$len >= 100} { + foreach range $ranges { + comment Range $range in ${share_mode}-span list of length $len + if {$share_mode eq "shared"} { + perf measure [lrange_describe shared-span $len $range] \ + "lrange \$Lspan {*}$range" [list len $len range $range] + } else { + perf measure [lrange_describe unshared-span $len $range] \ + "lrange \[perf::list::spanned_list \$len\] $range" \ + [list len $len range $range] -overhead {perf::list::spanned_list $len} + } + } + } + } + } + + perf destroy + } + + proc lset_describe {share_mode len at} { + return "lset L\[$len\] $share_mode at $at" + } + proc lset_perf {} { + variable Lengths + + print_separator lset + + ListPerf create perf -reps 10000 + + # Shared + foreach share_mode {shared unshared} { + foreach len $Lengths { + foreach idx {0 1 end-1 end end+1} { + comment lset at position $idx in a $share_mode list variable + if {$share_mode eq "shared"} { + perf measure [lset_describe shared $len $idx] { + set L2 $L + lset L $idx X + } [list len $len idx $idx] -overhead {set L2 $L} + } else { + perf measure [lset_describe unshared $len $idx] { + lset L $idx X + } [list len $len idx $idx] + } + } + } + } + + perf destroy + + # Nested + ListPerf create perf -setup { + set L [lrepeat $len [list a b]] + } + + foreach share_mode {shared unshared} { + foreach len $Lengths { + foreach idx {0 1 end-1 end} { + comment lset at position $idx in a $share_mode list variable + if {$share_mode eq "shared"} { + perf measure [lset_describe shared $len "{$idx 0}"] { + set L2 $L + lset L $idx 0 X + } [list len $len idx $idx] -overhead {set L2 $L} + } else { + perf measure [lset_describe unshared $len "{$idx 0}"] { + lset L $idx 0 {X Y} + } [list len $len idx $idx] + } + } + } + } + + perf destroy + } + + proc lremove_describe {share_mode len at nremoved} { + return "lremove L\[$len\] $share_mode $nremoved elements at $at" + } + proc lremove_perf {} { + variable Lengths + + print_separator lremove + + ListPerf create perf -reps 10000 + + foreach share_mode {shared unshared} { + foreach len $Lengths { + foreach idx [list 0 1 [expr {$len/2}] end-1 end] { + if {$share_mode eq "shared"} { + comment Remove one element from shared list + perf measure [lremove_describe shared $len $idx 1] \ + {lremove $L $idx} [list len $len idx $idx] + + } else { + comment Remove one element from unshared list + set reps [expr {$len >= 1000 ? ($len/8) : ($len-2)}] + perf measure [lremove_describe unshared $len $idx 1] \ + {set L [lremove $L[set L {}] $idx]} [list len $len idx $idx] \ + -overhead {set L $L; set L {}} -reps $reps + } + } + if {$share_mode eq "shared"} { + comment Remove multiple elements from shared list + perf measure [lremove_describe shared $len [list 0 1 [expr {$len/2}] end-1 end] 5] { + lremove $L 0 1 [expr {$len/2}] end-1 end + } [list len $len] + } + } + # Span + foreach len $Lengths { + foreach idx [list 0 1 [expr {$len/2}] end-1 end] { + if {$share_mode eq "shared"} { + comment Remove one element from shared-span list + perf measure [lremove_describe shared-span $len $idx 1] \ + {lremove $Lspan $idx} [list len $len idx $idx] + } else { + comment Remove one element from unshared-span list + set reps [expr {$len >= 1000 ? ($len/8) : ($len-2)}] + perf measure [lremove_describe unshared-span $len $idx 1] \ + {set Lspan [lremove $Lspan[set Lspan {}] $idx]} [list len $len idx $idx] \ + -overhead {set Lspan $Lspan; set Lspan {}} -reps $reps + } + } + if {$share_mode eq "shared"} { + comment Remove multiple elements from shared-span list + perf measure [lremove_describe shared-span $len [list 0 1 [expr {$len/2}] end-1 end] 5] { + lremove $Lspan 0 1 [expr {$len/2}] end-1 end + } [list len $len] + } + } + } + + perf destroy + } + + proc lreplace_describe {share_mode len first last ninsert {times 1}} { + if {$last < $first} { + return "lreplace L\[$len\] $share_mode 0 ($first:$last) elems at $first with $ninsert elems $times times." + } + return "lreplace L\[$len\] $share_mode $first:$last with $ninsert elems $times times." + } + proc lreplace_perf {} { + variable Lengths + + print_separator lreplace + + set default_reps 10000 + ListPerf create perf -reps $default_reps + + foreach share_mode {shared unshared} { + # Insert only + foreach len $Lengths { + set reps [expr {$len <= 100 ? ($len-2) : ($len/8)}] + foreach first [list 0 1 [expr {$len/2}] end-1 end] { + if {$share_mode eq "shared"} { + comment Insert one to shared list + perf measure [lreplace_describe shared $len $first -1 1] { + lreplace $L $first -1 x + } [list len $len first $first] + + comment Insert multiple to shared list + perf measure [lreplace_describe shared $len $first -1 10] { + lreplace $L $first -1 X X X X X X X X X X + } [list len $len first $first] + + comment Insert one to shared list repeatedly + perf measure [lreplace_describe shared $len $first -1 1 $reps] { + set L [lreplace $L $first -1 x] + } [list len $len first $first] -reps $reps + + comment Insert multiple to shared list repeatedly + perf measure [lreplace_describe shared $len $first -1 10 $reps] { + set L [lreplace $L $first -1 X X X X X X X X X X] + } [list len $len first $first] -reps $reps + + } else { + comment Insert one to unshared list + perf measure [lreplace_describe unshared $len $first -1 1] { + set L [lreplace $L[set L {}] $first -1 x] + } [list len $len first $first] -overhead { + set L $L; set L {} + } -reps $reps + + comment Insert multiple to unshared list + perf measure [lreplace_describe unshared $len $first -1 10] { + set L [lreplace $L[set L {}] $first -1 X X X X X X X X X X] + } [list len $len first $first] -overhead { + set L $L; set L {} + } -reps $reps + } + } + } + + # Delete only + foreach len $Lengths { + set reps [expr {$len <= 100 ? ($len-2) : ($len/8)}] + foreach first [list 0 1 [expr {$len/2}] end-1 end] { + if {$share_mode eq "shared"} { + comment Delete one from shared list + perf measure [lreplace_describe shared $len $first $first 0] { + lreplace $L $first $first + } [list len $len first $first] + } else { + comment Delete one from unshared list + perf measure [lreplace_describe unshared $len $first $first 0] { + set L [lreplace $L[set L {}] $first $first x] + } [list len $len first $first] -overhead { + set L $L; set L {} + } -reps $reps + } + } + } + + # Insert + delete + foreach len $Lengths { + set reps [expr {$len <= 100 ? ($len-2) : ($len/8)}] + foreach range [list {0 1} {1 2} {end-2 end-1} {end-1 end}] { + lassign $range first last + if {$share_mode eq "shared"} { + comment Insertions more than deletions from shared list + perf measure [lreplace_describe shared $len $first $last 3] { + lreplace $L $first $last X Y Z + } [list len $len first $first last $last] + + comment Insertions same as deletions from shared list + perf measure [lreplace_describe shared $len $first $last 2] { + lreplace $L $first $last X Y + } [list len $len first $first last $last] + + comment Insertions fewer than deletions from shared list + perf measure [lreplace_describe shared $len $first $last 1] { + lreplace $L $first $last X + } [list len $len first $first last $last] + } else { + comment Insertions more than deletions from unshared list + perf measure [lreplace_describe unshared $len $first $last 3] { + set L [lreplace $L[set L {}] $first $last X Y Z] + } [list len $len first $first last $last] -overhead { + set L $L; set L {} + } -reps $reps + + comment Insertions same as deletions from unshared list + perf measure [lreplace_describe unshared $len $first $last 2] { + set L [lreplace $L[set L {}] $first $last X Y ] + } [list len $len first $first last $last] -overhead { + set L $L; set L {} + } -reps $reps + + comment Insertions fewer than deletions from unshared list + perf measure [lreplace_describe unshared $len $first $last 1] { + set L [lreplace $L[set L {}] $first $last X] + } [list len $len first $first last $last] -overhead { + set L $L; set L {} + } -reps $reps + } + } + } + # Spanned Insert + delete + foreach len $Lengths { + set reps [expr {$len <= 100 ? ($len-2) : ($len/8)}] + foreach range [list {0 1} {1 2} {end-2 end-1} {end-1 end}] { + lassign $range first last + if {$share_mode eq "shared"} { + comment Insertions more than deletions from shared-span list + perf measure [lreplace_describe shared-span $len $first $last 3] { + lreplace $Lspan $first $last X Y Z + } [list len $len first $first last $last] + + comment Insertions same as deletions from shared-span list + perf measure [lreplace_describe shared-span $len $first $last 2] { + lreplace $Lspan $first $last X Y + } [list len $len first $first last $last] + + comment Insertions fewer than deletions from shared-span list + perf measure [lreplace_describe shared-span $len $first $last 1] { + lreplace $Lspan $first $last X + } [list len $len first $first last $last] + } else { + comment Insertions more than deletions from unshared-span list + perf measure [lreplace_describe unshared-span $len $first $last 3] { + set Lspan [lreplace $Lspan[set Lspan {}] $first $last X Y Z] + } [list len $len first $first last $last] -overhead { + set Lspan $Lspan; set Lspan {} + } -reps $reps + + comment Insertions same as deletions from unshared-span list + perf measure [lreplace_describe unshared-span $len $first $last 2] { + set Lspan [lreplace $Lspan[set Lspan {}] $first $last X Y ] + } [list len $len first $first last $last] -overhead { + set Lspan $Lspan; set Lspan {} + } -reps $reps + + comment Insertions fewer than deletions from unshared-span list + perf measure [lreplace_describe unshared-span $len $first $last 1] { + set Lspan [lreplace $Lspan[set Lspan {}] $first $last X] + } [list len $len first $first last $last] -overhead { + set Lspan $Lspan; set Lspan {} + } -reps $reps + } + } + } + } + + perf destroy + } + + proc split_describe {len} { + return "split L\[$len\]" + } + proc split_perf {} { + variable Lengths + print_separator split + + ListPerf create perf -setup {set S [string repeat "x " $len]} + foreach len $Lengths { + comment Split a string + perf measure [split_describe $len] { + split $S " " + } [list len $len] + } + } + + proc join_describe {share_mode len} { + return "join L\[$len\] $share_mode" + } + proc join_perf {} { + variable Lengths + + print_separator join + + ListPerf create perf -reps 10000 + foreach len $Lengths { + comment Join a list + perf measure [join_describe shared $len] { + join $L + } [list len $len] + } + foreach len $Lengths { + comment Join a spanned list + perf measure [join_describe shared-span $len] { + join $Lspan + } [list len $len] + } + perf destroy + } + + proc lsearch_describe {share_mode len} { + return "lsearch L\[$len\] $share_mode" + } + proc lsearch_perf {} { + variable Lengths + + print_separator lsearch + + ListPerf create perf -reps 100000 + foreach len $Lengths { + comment Search a list + perf measure [lsearch_describe shared $len] { + lsearch $L needle + } [list len $len] + } + foreach len $Lengths { + comment Search a spanned list + perf measure [lsearch_describe shared-span $len] { + lsearch $Lspan needle + } [list len $len] + } + perf destroy + } + + proc foreach_describe {share_mode len} { + return "foreach L\[$len\] $share_mode" + } + proc foreach_perf {} { + variable Lengths + + print_separator foreach + + ListPerf create perf -reps 10000 + foreach len $Lengths { + comment Iterate through a list + perf measure [foreach_describe shared $len] { + foreach e $L {} + } [list len $len] + } + foreach len $Lengths { + comment Iterate a spanned list + perf measure [foreach_describe shared-span $len] { + foreach e $Lspan {} + } [list len $len] + } + perf destroy + } + + proc lmap_describe {share_mode len} { + return "lmap L\[$len\] $share_mode" + } + proc lmap_perf {} { + variable Lengths + + print_separator lmap + + ListPerf create perf -reps 10000 + foreach len $Lengths { + comment Iterate through a list + perf measure [lmap_describe shared $len] { + lmap e $L {} + } [list len $len] + } + foreach len $Lengths { + comment Iterate a spanned list + perf measure [lmap_describe shared-span $len] { + lmap e $Lspan {} + } [list len $len] + } + perf destroy + } + + proc get_sort_sample {{spanned 0}} { + variable perfScript + variable sortSampleText + + if {![info exists sortSampleText]} { + set fd [open $perfScript] + set sortSampleText [split [read $fd] ""] + close $fd + } + set sortSampleText [string range $sortSampleText 0 9999] + + # NOTE: do NOT cache list result in a variable as we need it unshared + if {$spanned} { + return [lrange [split $sortSampleText ""] 1 end-1] + } else { + return [split $sortSampleText ""] + } + } + proc lsort_describe {share_mode len} { + return "lsort L\[$len] $share_mode" + } + proc lsort_perf {} { + print_separator lsort + + ListPerf create perf -setup {} + + comment Sort a shared list + perf measure [lsort_describe shared [llength [perf::list::get_sort_sample]]] { + lsort $L + } {} -setup {set L [perf::list::get_sort_sample]} + + comment Sort a shared-span list + perf measure [lsort_describe shared-span [llength [perf::list::get_sort_sample 1]]] { + lsort $L + } {} -setup {set L [perf::list::get_sort_sample 1]} + + comment Sort an unshared list + perf measure [lsort_describe unshared [llength [perf::list::get_sort_sample]]] { + lsort [perf::list::get_sort_sample] + } {} -overhead {perf::list::get_sort_sample} + + comment Sort an unshared-span list + perf measure [lsort_describe unshared-span [llength [perf::list::get_sort_sample 1]]] { + lsort [perf::list::get_sort_sample 1] + } {} -overhead {perf::list::get_sort_sample 1} + + perf destroy + } + + proc concat_describe {canonicality len elemlen} { + return "concat L\[$len\] $canonicality with elements of length $elemlen" + } + proc concat_perf {} { + variable Lengths + + print_separator concat + + ListPerf create perf -reps 100000 + + foreach len $Lengths { + foreach elemlen {1 100} { + comment Pure lists (no string representation) + perf measure [concat_describe "pure lists" $len $elemlen] { + concat $L $L + } [list len $len elemlen $elemlen] -setup { + set L [lrepeat $len [string repeat a $elemlen]] + } + + comment Canonical lists (with string representation) + perf measure [concat_describe "canonical lists" $len $elemlen] { + concat $L $L + } [list len $len elemlen $elemlen] -setup { + set L [lrepeat $len [string repeat a $elemlen]] + append x x $L; # Generate string while keeping internal rep list + unset x + } + + comment Non-canonical lists + perf measure [concat_describe "non-canonical lists" $len $elemlen] { + concat $L $L + } [list len $len elemlen $elemlen] -setup { + set L [string repeat "[string repeat a $elemlen] " $len] + llength $L + } + } + } + + # Span version + foreach len $Lengths { + foreach elemlen {1 100} { + comment Pure span lists (no string representation) + perf measure [concat_describe "pure spanned lists" $len $elemlen] { + concat $L $L + } [list len $len elemlen $elemlen] -setup { + set L [lrange [lrepeat [expr {$len+2}] [string repeat a $elemlen]] 1 end-1] + } + + comment Canonical span lists (with string representation) + perf measure [concat_describe "canonical spanned lists" $len $elemlen] { + concat $L $L + } [list len $len elemlen $elemlen] -setup { + set L [lrange [lrepeat [expr {$len+2}] [string repeat a $elemlen]] 1 end-1] + append x x $L; # Generate string while keeping internal rep list + unset x + } + } + } + + perf destroy + } + + proc test {} { + variable RunTimes + variable Options + + set selections [perf::list::setup $::argv] + if {[llength $selections] == 0} { + set commands [info commands ::perf::list::*_perf] + } else { + set commands [lmap sel $selections { + if {$sel eq "help"} { + print_usage + continue + } + set cmd ::perf::list::${sel}_perf + if {$cmd ni [info commands ::perf::list::*_perf]} { + puts stderr "Error: command $sel is not known or supported. Skipping." + continue + } + set cmd + }] + } + comment Setting up + timerate -calibrate {} + if {[info exists Options(--label)]} { + print "L $Options(--label)" + } + print "V [info patchlevel]" + print "E [info nameofexecutable]" + if {[info exists Options(--description)]} { + print "D $Options(--description)" + } + set twapi_keys {-privatebytes -workingset -workingsetpeak} + if {[info commands ::twapi::get_process_memory_info] ne ""} { + set twapi_vm_pre [::twapi::get_process_memory_info] + } + foreach cmd [lsort -dictionary $commands] { + set RunTimes(command) 0.0 + $cmd + set RunTimes(total) [expr {$RunTimes(total)+$RunTimes(command)}] + print "P [format_timings $RunTimes(command) 1] [string range $cmd 14 end-5] total run time" + } + # Print total runtime in same format as timerate output + print "P [format_timings $RunTimes(total) 1] Total run time" + + if {[info exists twapi_vm_pre]} { + set twapi_vm_post [::twapi::get_process_memory_info] + set MB 1048576.0 + foreach key $twapi_keys { + set pre [expr {[dict get $twapi_vm_pre $key]/$MB}] + set post [expr {[dict get $twapi_vm_post $key]/$MB}] + print "P [format_timings $pre 1] Memory (MB) $key pre-test" + print "P [format_timings $post 1] Memory (MB) $key post-test" + print "P [format_timings [expr {$post-$pre}] 1] Memory (MB) delta $key" + } + } + if {[info commands memory] ne ""} { + foreach line [split [memory info] \n] { + if {$line eq ""} continue + set line [split $line] + set val [expr {[lindex $line end]/1000.0}] + set line [string trim [join [lrange $line 0 end-1]]] + print "P [format_timings $val 1] memdbg $line (in thousands)" + } + print "# Allocations not freed on exit written to the lost-memory.tmp file." + print "# These will have to be manually compared." + # env TCL_FINALIZE_ON_EXIT must be set to 1 for this. + # DO NOT SET HERE - set ::env(TCL_FINALIZE_ON_EXIT) 1 + # Must be set in environment before starting tclsh else bogus results + if {[info exists Options(--label)]} { + set dump_file list-memory-$Options(--label).memdmp + } else { + set dump_file list-memory-[pid].memdmp + } + memory onexit $dump_file + } + } +} + + +if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} { + ::perf::list::test +} diff --git a/tests/lrepeat.test b/tests/lrepeat.test index c1c8b02..6734281 100644 --- a/tests/lrepeat.test +++ b/tests/lrepeat.test @@ -61,7 +61,7 @@ test lrepeat-1.7 {Accept zero repetitions (TIP 323)} { } -result {} } -test lrepeat-1.8 {Do not build enormous lists - Bug 2130992} -body { +test lrepeat-1.8 {Do not build enormous lists - Bug 2130992} -constraints knownBug -body { lrepeat 0x10000000 a b c d e f g h } -returnCodes error -match glob -result * -- cgit v0.12 From 41c87a4bf59377b2fcccc1d36a2812032e7a56e3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 14 Jul 2022 15:25:47 +0000 Subject: More progress --- generic/tclCmdIL.c | 2 +- generic/tclInt.h | 12 ++--- generic/tclListObj.c | 127 +++++++++++++++++++++++---------------------------- 3 files changed, 64 insertions(+), 77 deletions(-) diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index f0969fe..031168f 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2886,7 +2886,7 @@ Tcl_LrepeatObjCmd( /* Final sanity check. Do not exceed limits on max list length. */ - if (elementCount && objc > LIST_MAX/elementCount) { + if (elementCount && (size_t)objc > LIST_MAX/elementCount) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "max length of a Tcl list (%" TCL_Z_MODIFIER "u elements) exceeded", LIST_MAX)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); diff --git a/generic/tclInt.h b/generic/tclInt.h index 5a59e39..03b2f12 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2381,18 +2381,18 @@ typedef enum TclEolTranslation { #define TCL_INVOKE_NO_TRACEBACK (1<<2) /* - * TclListSizeT is the type for holding list element counts. It's defined + * ListSizeT is the type for holding list element counts. It's defined * simplify sharing source between Tcl8 and Tcl9. */ #if TCL_MAJOR_VERSION > 8 -typedef ptrdiff_t ListSizeT; /* TODO - may need to fix to match Tcl9's API */ +typedef size_t ListSizeT; /* * SSIZE_MAX, NOT SIZE_MAX as negative differences need to be expressed * between values of the ListSizeT type so limit the range to signed */ -#define ListSizeT_MAX PTRDIFF_MAX +#define ListSizeT_MAX ((ListSizeT)PTRDIFF_MAX) #else @@ -2441,11 +2441,11 @@ typedef struct ListStore { /* Max number of elements that can be contained in a list */ #define LIST_MAX \ - ((ListSizeT)(((size_t)ListSizeT_MAX - offsetof(ListStore, slots)) \ - / sizeof(Tcl_Obj *))) + ((ListSizeT_MAX - offsetof(ListStore, slots)) \ + / sizeof(Tcl_Obj *)) /* Memory size needed for a ListStore to hold numSlots_ elements */ #define LIST_SIZE(numSlots_) \ - ((int)(offsetof(ListStore, slots) + ((numSlots_) * sizeof(Tcl_Obj *)))) + (offsetof(ListStore, slots) + ((numSlots_) * sizeof(Tcl_Obj *))) /* * ListSpan -- diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 95f2d61..f0597b9 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -45,13 +45,13 @@ #define LIST_INDEX_ASSERT(idxarg_) \ do { \ ListSizeT idx_ = (idxarg_); /* To guard against ++ etc. */ \ - LIST_ASSERT(idx_ >= 0 && idx_ < LIST_MAX); \ + LIST_ASSERT(idx_ != TCL_INDEX_NONE && idx_ < LIST_MAX); \ } while (0) /* Ditto for counts except upper limit is different */ #define LIST_COUNT_ASSERT(countarg_) \ do { \ ListSizeT count_ = (countarg_); /* To guard against ++ etc. */ \ - LIST_ASSERT(count_ >= 0 && count_ <= LIST_MAX); \ + LIST_ASSERT(count_ != TCL_INDEX_NONE && count_ <= LIST_MAX); \ } while (0) #else @@ -114,7 +114,7 @@ /* * Prototypes for non-inline static functions defined later in this file: */ -static int MemoryAllocationError(Tcl_Interp *, size_t size); +static int MemoryAllocationError(Tcl_Interp *, ListSizeT size); static int ListLimitExceededError(Tcl_Interp *); static ListStore * ListStoreNew(ListSizeT objc, Tcl_Obj *const objv[], int flags); @@ -508,7 +508,7 @@ ObjArrayCopy( static int MemoryAllocationError( Tcl_Interp *interp, /* Interpreter for error message. May be NULL */ - size_t size) /* Size of attempted allocation that failed */ + ListSizeT size) /* Size of attempted allocation that failed */ { if (interp != NULL) { Tcl_SetObjResult( @@ -773,7 +773,7 @@ ListStoreNew( } if (storePtr == NULL) { if (flags & LISTREP_PANIC_ON_FAIL) { - Tcl_Panic("list creation failed: unable to alloc %u bytes", + Tcl_Panic("list creation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", LIST_SIZE(objc)); } return NULL; @@ -893,14 +893,6 @@ ListRepInit( { ListStore *storePtr; - /* - * The whole list implementation has an implicit assumption that lenths - * and indices used a signed integer type. Tcl9 API's currently use - * unsigned types. This assert is to remind that need to review code - * when adapting for Tcl9. - */ - LIST_ASSERT(((ListSizeT)-1) < 0); - storePtr = ListStoreNew(objc, objv, flags); if (storePtr) { repPtr->storePtr = storePtr; @@ -1100,7 +1092,7 @@ Tcl_NewListObj( Tcl_Obj * Tcl_NewListObj( - size_t objc, /* Count of objects referenced by objv. */ + ListSizeT objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ { ListRep listRep; @@ -1164,7 +1156,7 @@ Tcl_DbNewListObj( TclDbNewObj(listObj, file, line); - if (objc <= 0) { + if (objc + 1 <= 1) { return listObj; } @@ -1178,7 +1170,7 @@ Tcl_DbNewListObj( Tcl_Obj * Tcl_DbNewListObj( - size_t objc, /* Count of objects referenced by objv. */ + ListSizeT objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[], /* An array of pointers to Tcl objects. */ TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) @@ -1312,7 +1304,7 @@ TclListObjGetRep( void Tcl_SetListObj( Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - size_t objc, /* Count of objects referenced by objv. */ + ListSizeT objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ { if (Tcl_IsShared(objPtr)) { @@ -1427,13 +1419,13 @@ ListRepRange( ListRepFreeUnreferenced(srcRepPtr); } - if (rangeStart < 0) { + if (rangeStart == TCL_INDEX_NONE) { rangeStart = 0; } - if (rangeEnd >= numSrcElems) { + if ((rangeEnd != TCL_INDEX_NONE) && (rangeEnd >= numSrcElems)) { rangeEnd = numSrcElems - 1; } - if (rangeStart > rangeEnd) { + if (rangeStart + 1 > rangeEnd + 1) { /* Empty list of capacity 1. */ ListRepInit(1, NULL, LISTREP_PANIC_ON_FAIL, rangeRepPtr); return; @@ -1563,8 +1555,8 @@ ListRepRange( Tcl_Obj * TclListObjRange( Tcl_Obj *listObj, /* List object to take a range from. */ - size_t rangeStart, /* Index of first element to include. */ - size_t rangeEnd) /* Index of last element to include. */ + ListSizeT rangeStart, /* Index of first element to include. */ + ListSizeT rangeEnd) /* Index of last element to include. */ { ListRep listRep; ListRep resultRep; @@ -1620,7 +1612,7 @@ Tcl_ListObjGetElements( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *objPtr, /* List object for which an element array is * to be returned. */ - size_t *objcPtr, /* Where to store the count of objects + ListSizeT *objcPtr, /* Where to store the count of objects * referenced by objv. */ Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of * pointers to the list's objects. */ @@ -1662,7 +1654,7 @@ Tcl_ListObjAppendList( Tcl_Obj *toObj, /* List object to append elements to. */ Tcl_Obj *fromObj) /* List obj with elements to append. */ { - size_t objc; + ListSizeT objc; Tcl_Obj **objv; if (Tcl_IsShared(toObj)) { @@ -1706,13 +1698,13 @@ Tcl_ListObjAppendList( int TclListObjAppendElements ( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *toObj, /* List object to append */ - size_t elemCount, /* Number of elements in elemObjs[] */ + ListSizeT elemCount, /* Number of elements in elemObjs[] */ Tcl_Obj * const elemObjv[]) /* Objects to append to toObj's list. */ { ListRep listRep; Tcl_Obj **toObjv; - size_t toLen; - size_t finalLen; + ListSizeT toLen; + ListSizeT finalLen; if (Tcl_IsShared(toObj)) { Tcl_Panic("%s called with shared object", "TclListObjAppendElements"); @@ -1737,7 +1729,7 @@ Tcl_ListObjAppendList( * reference counts on the elements which is a substantial cost * if the list is not small. */ - size_t numTailFree; + ListSizeT numTailFree; ListRepFreeUnreferenced(&listRep); /* Collect garbage before checking room */ @@ -1745,7 +1737,7 @@ Tcl_ListObjAppendList( LIST_ASSERT(ListRepLength(&listRep) == listRep.storePtr->numUsed); LIST_ASSERT(toLen == listRep.storePtr->numUsed); - if (finalLen > (size_t)listRep.storePtr->numAllocated) { + if (finalLen > listRep.storePtr->numAllocated) { ListStore *newStorePtr; newStorePtr = ListStoreReallocate(listRep.storePtr, finalLen); if (newStorePtr == NULL) { @@ -1892,11 +1884,11 @@ int Tcl_ListObjIndex( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *listObj, /* List object to index into. */ - size_t index, /* Index of element to return. */ + ListSizeT index, /* Index of element to return. */ Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */ { Tcl_Obj **elemObjs; - size_t numElems; + ListSizeT numElems; /* * TODO @@ -1945,7 +1937,7 @@ int Tcl_ListObjLength( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *listObj, /* List object whose #elements to return. */ - size_t *lenPtr) /* The resulting int is stored here. */ + ListSizeT *lenPtr) /* The resulting int is stored here. */ { ListRep listRep; @@ -2004,19 +1996,19 @@ int Tcl_ListObjReplace( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *listObj, /* List object whose elements to replace. */ - size_t first, /* Index of first element to replace. */ - size_t numToDelete, /* Number of elements to replace. */ - size_t numToInsert, /* Number of objects to insert. */ + ListSizeT first, /* Index of first element to replace. */ + ListSizeT numToDelete, /* Number of elements to replace. */ + ListSizeT numToInsert, /* Number of objects to insert. */ Tcl_Obj *const insertObjs[])/* Tcl objects to insert */ { ListRep listRep; ListSizeT origListLen; - ListSizeT lenChange; - ListSizeT leadSegmentLen; - ListSizeT tailSegmentLen; + ptrdiff_t lenChange; + ptrdiff_t leadSegmentLen; + ptrdiff_t tailSegmentLen; ListSizeT numFreeSlots; - ListSizeT leadShift; - ListSizeT tailShift; + ptrdiff_t leadShift; + ptrdiff_t tailShift; Tcl_Obj **listObjs; if (Tcl_IsShared(listObj)) { @@ -2033,13 +2025,13 @@ Tcl_ListObjReplace( if (first == TCL_INDEX_NONE) { first = 0; } - if (first > (size_t)origListLen) { + if (first > origListLen) { first = origListLen; /* So we'll insert after last element. */ } if (numToDelete == TCL_INDEX_NONE) { numToDelete = 0; } else if (first > ListSizeT_MAX - numToDelete /* Handle integer overflow */ - || (size_t)origListLen < first + numToDelete) { + || origListLen < first + numToDelete) { numToDelete = origListLen - first; } @@ -2079,7 +2071,7 @@ Tcl_ListObjReplace( ListRepRange(&listRep, numToDelete, origListLen-1, 0, &tailRep); ListObjReplaceRepAndInvalidate(listObj, &tailRep); return TCL_OK; - } else if ((first+numToDelete) >= (size_t)origListLen) { + } else if ((first+numToDelete) >= origListLen) { /* Delete from tail, so return head */ ListRep headRep; ListRepRange(&listRep, 0, first-1, 0, &headRep); @@ -2097,7 +2089,7 @@ Tcl_ListObjReplace( */ if (numToDelete == 0) { /* Case (2a) - Append to list */ - if (first == (size_t)origListLen) { + if (first == origListLen) { return TclListObjAppendElements( interp, listObj, numToInsert, insertObjs); } @@ -2112,7 +2104,7 @@ Tcl_ListObjReplace( */ if (first == 0 && /* (i) */ ListRepStart(&listRep) == listRep.storePtr->firstUsed && /* (ii) */ - numToInsert <= (size_t)listRep.storePtr->firstUsed /* (iii) */ + numToInsert <= listRep.storePtr->firstUsed /* (iii) */ ) { ListSizeT newLen; LIST_ASSERT(numToInsert); /* Else would have returned above */ @@ -2153,7 +2145,7 @@ Tcl_ListObjReplace( * later by not having to go through the ListRepInit and * ListObjReplaceAndInvalidate below. */ - if (numFreeSlots < lenChange && !ListRepIsShared(&listRep)) { + if ((ptrdiff_t)numFreeSlots < lenChange && !ListRepIsShared(&listRep)) { ListStore *newStorePtr = ListStoreReallocate(listRep.storePtr, origListLen + lenChange); if (newStorePtr == NULL) { @@ -2179,7 +2171,7 @@ Tcl_ListObjReplace( * TODO - for unshared case ONLY, consider a "move" based implementation */ if (ListRepIsShared(&listRep) || /* 3a */ - numFreeSlots < lenChange || /* 3b */ + (ptrdiff_t)numFreeSlots < lenChange || /* 3b */ (origListLen + lenChange) < (listRep.storePtr->numAllocated / 4) /* 3c */ ) { ListRep newRep; @@ -2281,9 +2273,9 @@ Tcl_ListObjReplace( * or need to shift both. In the former case, favor shifting the * smaller segment. */ - ListSizeT leadSpace = ListRepNumFreeHead(&listRep); - ListSizeT tailSpace = ListRepNumFreeTail(&listRep); - ListSizeT finalFreeSpace = leadSpace + tailSpace - lenChange; + ptrdiff_t leadSpace = ListRepNumFreeHead(&listRep); + ptrdiff_t tailSpace = ListRepNumFreeTail(&listRep); + ptrdiff_t finalFreeSpace = leadSpace + tailSpace - lenChange; LIST_ASSERT((leadSpace + tailSpace) >= lenChange); if (leadSpace >= lenChange @@ -2299,7 +2291,7 @@ Tcl_ListObjReplace( * insertions. */ if (finalFreeSpace > 1 && (tailSpace == 0 || tailSegmentLen == 0)) { - ListSizeT postShiftLeadSpace = leadSpace - lenChange; + ptrdiff_t postShiftLeadSpace = leadSpace - lenChange; if (postShiftLeadSpace > (finalFreeSpace/2)) { ListSizeT extraShift = postShiftLeadSpace - (finalFreeSpace / 2); leadShift -= extraShift; @@ -2315,7 +2307,7 @@ Tcl_ListObjReplace( * See comments above. This is analogous. */ if (finalFreeSpace > 1 && (leadSpace == 0 || leadSegmentLen == 0)) { - ListSizeT postShiftTailSpace = tailSpace - lenChange; + ptrdiff_t postShiftTailSpace = tailSpace - lenChange; if (postShiftTailSpace > (finalFreeSpace/2)) { ListSizeT extraShift = postShiftTailSpace - (finalFreeSpace / 2); tailShift += extraShift; @@ -2445,7 +2437,7 @@ TclLindexList( Tcl_Obj *listObj, /* List being unpacked. */ Tcl_Obj *argObj) /* Index or index list. */ { - size_t index; /* Index into the list. */ + ListSizeT index; /* Index into the list. */ Tcl_Obj *indexListCopy; Tcl_Obj **indexObjs; ListSizeT numIndexObjs; @@ -2523,16 +2515,16 @@ Tcl_Obj * TclLindexFlat( Tcl_Interp *interp, /* Tcl interpreter. */ Tcl_Obj *listObj, /* Tcl object representing the list. */ - size_t indexCount, /* Count of indices. */ + ListSizeT indexCount, /* Count of indices. */ Tcl_Obj *const indexArray[])/* Array of pointers to Tcl objects that * represent the indices in the list. */ { - size_t i; + ListSizeT i; Tcl_IncrRefCount(listObj); for (i=0 ; i SIZE_MAX - numElems) { + Tcl_Panic("max size for a Tcl value (%" TCL_Z_MODIFIER "u bytes) exceeded", SIZE_MAX); } } - /* TODO - what is the max #define for Tcl9? */ - if (bytesNeeded > INT_MAX - numElems + 1) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } bytesNeeded += numElems - 1; /* -- cgit v0.12 From 4e9c7a9ae0adaee122394db9ebf41650340fe023 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 30 Jul 2022 21:47:58 +0000 Subject: Undo knownBug constraint: no longer necessary --- tests/apply.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/apply.test b/tests/apply.test index 47fcb67..a5f1f8f 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -261,7 +261,7 @@ test apply-9.1 {leaking internal rep} -setup { lindex $lines 3 3 } set lam [list {} {set a 1}] -} -constraints {memory knownBug} -body { +} -constraints memory -body { set end [getbytes] for {set i 0} {$i < 5} {incr i} { ::apply [lrange $lam 0 end] -- cgit v0.12 From 515f8ab0440b2d4cb6411790c2c08210cadfee6a Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 31 Jul 2022 11:54:14 +0000 Subject: Add 'file home' command --- generic/tclCmdAH.c | 1 + generic/tclFCmd.c | 39 +++++++++++++ generic/tclInt.h | 5 +- generic/tclPathObj.c | 161 +++++++++++++++++++++++++++++---------------------- 4 files changed, 137 insertions(+), 69 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 41ab339..48b90bc 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -1042,6 +1042,7 @@ TclInitFileCmd( {"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"home", TclFileHomeCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"join", PathJoinCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index c19623d..c786395 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -1653,6 +1653,45 @@ TclFileTempDirCmd( } /* + *---------------------------------------------------------------------- + * + * TclFileHomeCmd -- + * + * This function is invoked to process the "file home" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclFileHomeCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *homeDirObj; + Tcl_DString dirString; + + if (objc != 1 && objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?user?"); + return TCL_ERROR; + } + if (TclGetHomeDir(interp, objc == 1 ? NULL : Tcl_GetString(objv[1]), &dirString) != TCL_OK) { + return TCL_ERROR; + } + homeDirObj = TclDStringToObj(&dirString); + Tcl_SetObjResult(interp, homeDirObj); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclInt.h b/generic/tclInt.h index 69b18b1..b09ef8f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2912,6 +2912,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclFileReadLinkCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileTempDirCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileHomeCmd; MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc, void *clientData); MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc, @@ -3020,8 +3021,10 @@ MODULE_SCOPE int TclIsDigitProc(int byte); MODULE_SCOPE int TclIsBareword(int byte); MODULE_SCOPE Tcl_Obj * TclJoinPath(size_t elements, Tcl_Obj * const objv[], int forceRelative); +MODULE_SCOPE int TclGetHomeDir(Tcl_Interp *interp, const char *user, + Tcl_DString *dsPtr); MODULE_SCOPE Tcl_Obj * TclResolveTildePath(Tcl_Interp *interp, - Tcl_Obj *pathsObj); + Tcl_Obj *pathObj); MODULE_SCOPE Tcl_Obj * TclResolveTildePathList(Tcl_Obj *pathsObj); MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 7efd14e..d9fccb7 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -25,7 +25,7 @@ static void DupFsPathInternalRep(Tcl_Obj *srcPtr, static void FreeFsPathInternalRep(Tcl_Obj *pathPtr); static void UpdateStringOfFsPath(Tcl_Obj *pathPtr); static int SetFsPathFromAny(Tcl_Interp *interp, Tcl_Obj *pathPtr); -static size_t FindSplitPos(const char *path, int separator); +static size_t FindSplitPos(const char *path, int separator); static int IsSeparatorOrNull(int ch); static Tcl_Obj * GetExtension(Tcl_Obj *pathPtr); static int MakePathFromNormalized(Tcl_Interp *interp, @@ -2571,12 +2571,72 @@ TclNativePathInFilesystem( /* *---------------------------------------------------------------------- * + * TclGetHomeDir -- + * + * Returns the home directory of a user. Note there is a difference + * between not specifying a user and explicitly specifying the current + * user. This mimics Tcl8's tilde expansion. + * + * Results: + * Returns TCL_OK on success with home directory path in *dsPtr + * and TCL_ERROR on failure with error message in interp if non-NULL. + * + *---------------------------------------------------------------------- + */ +int +TclGetHomeDir( + Tcl_Interp *interp, /* May be NULL. Only used for error messages */ + const char *user, /* User name. NULL -> current user */ + Tcl_DString *dsPtr) /* Output. Is initialized by the function. Must be + freed on success */ +{ + const char *dir; + Tcl_DString nativeString; + + Tcl_DStringInit(dsPtr); + Tcl_DStringInit(&nativeString); + + if (user == NULL || user[0] == 0) { + /* No user name specified -> current user */ + + dir = TclGetEnv("HOME", &nativeString); + if (dir == NULL) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't find HOME environment variable to" + " expand path", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", + "HOMELESS", NULL); + } + return TCL_ERROR; + } + } else { + /* User name specified - ~user */ + dir = TclpGetUserHome(user, &nativeString); + if (dir == NULL) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "user \"%s\" doesn't exist", user)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER", + NULL); + } + return TCL_ERROR; + } + } + Tcl_JoinPath(1, &dir, dsPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclResolveTildePath -- * - * If the passed Tcl_Obj is begins with a tilde, does tilde resolution + * If the passed path is begins with a tilde, does tilde resolution * and returns a Tcl_Obj containing the resolved path. If the tilde * component cannot be resolved, returns NULL. If the path does not - * begin with a tilde, returns unmodified. + * begin with a tilde, returns as is. * * The trailing components of the path are returned verbatim. No * processing is done on them. Moreover, no assumptions should be @@ -2585,9 +2645,11 @@ TclNativePathInFilesystem( * used by caller if desired. * * Results: - * Returns a Tcl_Obj with resolved path and reference count 0, or the - * original Tcl_Obj if it does not begin with a tilde. Returns NULL - * if the path begins with a ~ that cannot be resolved. + * Returns a Tcl_Obj with resolved path. This may be a new Tcl_Obj + * with ref count 0 or that pathObj that was passed in without its + * ref count modified. + * Returns NULL if the path begins with a ~ that cannot be resolved + * and stores an error message in interp if non-NULL. * *---------------------------------------------------------------------- */ @@ -2596,59 +2658,30 @@ TclResolveTildePath( Tcl_Interp *interp, /* May be NULL. Only used for error messages */ Tcl_Obj *pathObj) { + const char *path; size_t len; Tcl_Obj *resolvedObj; - const char *name; Tcl_DString dirString; size_t split; - char separator = '/'; - /* - * Copied almost verbatim from the corresponding SetFsPathFromAny fragment - * in 8.7. - * - * First step is to translate the filename. This is similar to - * Tcl_TranslateFilename, but shouldn't convert everything to windows - * backslashes on that platform. The current implementation of this piece - * is a slightly optimised version of the various Tilde/Split/Join stuff - * to avoid multiple split/join operations. - * - * We remove any trailing directory separator. - * - * However, the split/join routines are quite complex, and one has to make - * sure not to break anything on Unix or Win (fCmd.test, fileName.test and - * cmdAH.test exercise most of the code). - */ - - name = Tcl_GetStringFromObj(pathObj, &len); - if (name[0] != '~') { - return pathObj; /* No tilde prefix, no need to resolve */ + path = Tcl_GetStringFromObj(pathObj, &len); + if (path[0] != '~') { + return pathObj; } /* * We have multiple cases '~/foo/bar...', '~user/foo/bar...', etc. - * split becomes value 1 for '~/...' as well as for '~'. + * split becomes value 1 for '~/...' as well as for '~'. Note on + * Windows FindSplitPos will implicitly check for '\' as separator + * in addition to what is passed. */ - split = FindSplitPos(name, separator); + split = FindSplitPos(path, '/'); if (split == 1) { /* No user name specified -> current user */ - - const char *dir; - Tcl_DString dirString; - - Tcl_DStringInit(&dirString); - dir = TclGetEnv("HOME", &dirString); - if (dir == NULL) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "couldn't find HOME environment variable to" - " expand path", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", - "HOMELESS", NULL); - } - return NULL; - } + if (TclGetHomeDir(interp, NULL, &dirString) != TCL_OK) { + return NULL; + } } else { /* User name specified - ~user */ @@ -2656,28 +2689,20 @@ TclResolveTildePath( Tcl_DString userName; Tcl_DStringInit(&userName); - Tcl_DStringAppend(&userName, name+1, split-1); + Tcl_DStringAppend(&userName, path+1, split-1); expandedUser = Tcl_DStringValue(&userName); - Tcl_DStringInit(&dirString); - if (TclpGetUserHome(expandedUser, &dirString) == NULL) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "user \"%s\" doesn't exist", expandedUser)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER", - NULL); - } + if (TclGetHomeDir(interp, expandedUser, &dirString) != TCL_OK) { Tcl_DStringFree(&userName); - Tcl_DStringFree(&dirString); - return NULL; - } + return NULL; + } Tcl_DStringFree(&userName); } resolvedObj = TclDStringToObj(&dirString); if (split < len) { /* If any trailer, append it verbatim */ - Tcl_AppendToObj(resolvedObj, split + name, len-split); + Tcl_AppendToObj(resolvedObj, split + path, len-split); } return resolvedObj; @@ -2740,16 +2765,16 @@ TclResolveTildePathList( resolvedPaths = Tcl_NewListObj(objc, NULL); for (i = 0; i < objc; ++i) { - Tcl_Obj *resolvedPath; - + Tcl_Obj *resolvedPath; path = Tcl_GetString(objv[i]); - if (path[0] == 0) { - continue; /* Skip empty strings */ - } - resolvedPath = TclResolveTildePath(NULL, objv[i]); - if (resolvedPath) { - Tcl_ListObjAppendElement(NULL, resolvedPaths, resolvedPath); - } + if (path[0] == 0) { + continue; /* Skip empty strings */ + } + resolvedPath = TclResolveTildePath(NULL, objv[i]); + if (resolvedPath) { + /* Paths that cannot be resolved are skipped */ + Tcl_ListObjAppendElement(NULL, resolvedPaths, resolvedPath); + } } return resolvedPaths; -- cgit v0.12 From 7754129cabaa2aa7f6a487106c0551d0c5f2c2d3 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 1 Aug 2022 17:07:54 +0000 Subject: Update tests for TIP 602 --- generic/tclCmdAH.c | 5 +- generic/tclFCmd.c | 5 +- generic/tclInt.h | 1 + generic/tclPathObj.c | 26 ++++++ tests/chanio.test | 21 ++--- tests/cmdAH.test | 74 +++++++---------- tests/exec.test | 16 ++-- tests/fCmd.test | 220 ++++++++++++++++++++++++++++++++++++++++++-------- tests/fileName.test | 138 ++++++++++++++----------------- tests/fileSystem.test | 24 +++--- tests/io.test | 2 +- tests/safe.test | 8 +- tests/winFile.test | 2 +- 13 files changed, 345 insertions(+), 197 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 48b90bc..eec3e0f 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -271,7 +271,10 @@ Tcl_CdObjCmd( if (objc == 2) { dir = objv[1]; } else { - TclNewLiteralStringObj(dir, "~"); + dir = TclGetHomeDirObj(interp, NULL); + if (dir == NULL) { + return TCL_ERROR; + } Tcl_IncrRefCount(dir); } if (Tcl_FSConvertToPathType(interp, dir) != TCL_OK) { diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index c786395..9a107da 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -1677,16 +1677,15 @@ TclFileHomeCmd( Tcl_Obj *const objv[]) { Tcl_Obj *homeDirObj; - Tcl_DString dirString; if (objc != 1 && objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "?user?"); return TCL_ERROR; } - if (TclGetHomeDir(interp, objc == 1 ? NULL : Tcl_GetString(objv[1]), &dirString) != TCL_OK) { + homeDirObj = TclGetHomeDirObj(interp, objc == 1 ? NULL : Tcl_GetString(objv[1])); + if (homeDirObj == NULL) { return TCL_ERROR; } - homeDirObj = TclDStringToObj(&dirString); Tcl_SetObjResult(interp, homeDirObj); return TCL_OK; } diff --git a/generic/tclInt.h b/generic/tclInt.h index b09ef8f..51f7e75 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3023,6 +3023,7 @@ MODULE_SCOPE Tcl_Obj * TclJoinPath(size_t elements, Tcl_Obj * const objv[], int forceRelative); MODULE_SCOPE int TclGetHomeDir(Tcl_Interp *interp, const char *user, Tcl_DString *dsPtr); +MODULE_SCOPE Tcl_Obj * TclGetHomeDirObj(Tcl_Interp *interp, const char *user); MODULE_SCOPE Tcl_Obj * TclResolveTildePath(Tcl_Interp *interp, Tcl_Obj *pathObj); MODULE_SCOPE Tcl_Obj * TclResolveTildePathList(Tcl_Obj *pathsObj); diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index d9fccb7..c123613 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -2631,6 +2631,32 @@ TclGetHomeDir( /* *---------------------------------------------------------------------- * + * TclGetHomeDirObj -- + * + * Wrapper around TclGetHomeDir. See that function. + * + * Results: + * Returns a Tcl_Obj containing the home directory of a user + * or NULL on failure with error message in interp if non-NULL. + * + *---------------------------------------------------------------------- + */ +Tcl_Obj * +TclGetHomeDirObj( + Tcl_Interp *interp, /* May be NULL. Only used for error messages */ + const char *user) /* User name. NULL -> current user */ +{ + Tcl_DString dirString; + + if (TclGetHomeDir(interp, user, &dirString) != TCL_OK) { + return NULL; + } + return TclDStringToObj(&dirString); +} + +/* + *---------------------------------------------------------------------- + * * TclResolveTildePath -- * * If the passed path is begins with a tilde, does tilde resolution diff --git a/tests/chanio.test b/tests/chanio.test index 8d922a2..c1085f4 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -61,7 +61,7 @@ namespace eval ::tcl::test::io { set umaskValue 0 testConstraint umask [expr {![catch {set umaskValue [scan [exec /bin/sh -c umask] %o]}]}] - testConstraint makeFileInHome [expr {![file exists ~/_test_] && [file writable ~]}] + testConstraint makeFileInHome [expr {![file exists $::env(HOME)/_test_] && [file writable $::env(HOME)]}] # set up a long data file for some of the following tests @@ -5488,21 +5488,16 @@ test chan-io-40.15 {POSIX open access modes: RDWR} { chan close $f lappend x [viewFile test3] } {zzy abzzy} -test chan-io-40.16 {tilde substitution in open} -constraints makeFileInHome -setup { - makeFile {Some text} _test_ ~ +test chan-io-40.16 {verify no tilde substitution in open} -setup { + set curdir [pwd] + cd [temporaryDirectory] } -body { - file exists [file join $::env(HOME) _test_] + close [open ~ w] + list [file isfile ~] } -cleanup { - removeFile _test_ ~ + file delete ./~ ;# ./ because don't want to delete home in case of bugs! + cd $curdir } -result 1 -test chan-io-40.17 {tilde substitution in open} -setup { - set home $::env(HOME) -} -body { - unset ::env(HOME) - open ~/foo -} -returnCodes error -cleanup { - set ::env(HOME) $home -} -result {couldn't find HOME environment variable to expand path} test chan-io-41.1 {Tcl_FileeventCmd: errors} -constraints fileevent -body { chan event foo diff --git a/tests/cmdAH.test b/tests/cmdAH.test index fb74b7f..3c78842 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -100,7 +100,7 @@ test cmdAH-2.3 {Tcl_CdObjCmd} -setup { set env(HOME) $oldpwd file mkdir $foodir cd $foodir - cd ~ + cd [file home] string equal [pwd] $oldpwd } -cleanup { cd $oldpwd @@ -124,8 +124,21 @@ test cmdAH-2.4 {Tcl_CdObjCmd} -setup { set env(HOME) $temp } -result 1 test cmdAH-2.5 {Tcl_CdObjCmd} -returnCodes error -body { - cd ~~ -} -result {user "~" doesn't exist} + cd ~ +} -result {couldn't change working directory to "~": no such file or directory} +test cmdAH-2.5.1 {Tcl_CdObjCmd} -setup { + set oldpwd [pwd] + cd [temporaryDirectory] + file delete ./~ + file mkdir ~ +} -body { + cd ~ + pwd +} -cleanup { + cd [temporaryDirectory] + file delete ./~ + cd $oldpwd +} -result [file join [temporaryDirectory] ~] test cmdAH-2.6 {Tcl_CdObjCmd} -returnCodes error -body { cd _foobar } -result {couldn't change working directory to "_foobar": no such file or directory} @@ -349,7 +362,7 @@ test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { } -result {wrong # args: should be "file subcommand ?arg ...?"} test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body { file x -} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, home, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body { file exists } -result {wrong # args: should be "file exists name"} @@ -496,7 +509,7 @@ test cmdAH-8.43 {Tcl_FileObjCmd: dirname} -setup { } -constraints testsetplatform -body { set env(HOME) "/homewontexist/test" testsetplatform unix - file dirname ~ + file dirname [file home] } -cleanup { set env(HOME) $temp } -result /homewontexist @@ -506,19 +519,13 @@ test cmdAH-8.44 {Tcl_FileObjCmd: dirname} -setup { } -constraints testsetplatform -body { set env(HOME) "~" testsetplatform unix - file dirname ~ + file dirname [file home] } -cleanup { set env(HOME) $temp -} -result ~ -test cmdAH-8.45 {Tcl_FileObjCmd: dirname} -setup { - set temp $::env(HOME) -} -constraints {win testsetplatform} -match regexp -body { - set ::env(HOME) "/homewontexist/test" - testsetplatform windows +} -result . +test cmdAH-8.45 {Tcl_FileObjCmd: dirname ~} -body { file dirname ~ -} -cleanup { - set ::env(HOME) $temp -} -result {([a-zA-Z]:?)/homewontexist} +} -result . test cmdAH-8.46 {Tcl_FileObjCmd: dirname} { set f [file normalize [info nameof]] file exists $f @@ -626,36 +633,19 @@ test cmdAH-9.26 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform windows file tail {//foo/bar} } {} -test cmdAH-9.42 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup { - global env - set temp $env(HOME) -} -body { - set env(HOME) "/home/test" - testsetplatform unix +test cmdAH-9.42 {Tcl_FileObjCmd: tail ~} -body { file tail ~ -} -cleanup { - set env(HOME) $temp -} -result test +} -result ~ test cmdAH-9.43 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup { global env set temp $env(HOME) } -body { set env(HOME) "~" testsetplatform unix - file tail ~ -} -cleanup { - set env(HOME) $temp -} -result {} -test cmdAH-9.44 {Tcl_FileObjCmd: tail} -constraints testsetplatform -setup { - global env - set temp $env(HOME) -} -body { - set env(HOME) "/home/test" - testsetplatform windows - file tail ~ + file tail [file home] } -cleanup { set env(HOME) $temp -} -result test +} -result ~ test cmdAH-9.46 {Tcl_FileObjCmd: tail} testsetplatform { testsetplatform unix file tail {f.oo\bar/baz.bat} @@ -686,7 +676,7 @@ test cmdAH-9.52 {Tcl_FileObjCmd: tail / normalize, bug 7a9dc52b29} { [file tail {~/test/~foo}] \ [file tail [file normalize {~/~foo}]] \ [file tail [file normalize {~/test/~foo}]] -} [lrepeat 4 ./~foo] +} [lrepeat 4 ~foo] # rootname test cmdAH-10.1 {Tcl_FileObjCmd: rootname} -returnCodes error -body { @@ -940,7 +930,7 @@ test cmdAH-14.3 {Tcl_FileObjCmd: join} testsetplatform { test cmdAH-15.1 {Tcl_FileObjCmd} -constraints testsetplatform -body { testsetplatform unix file atime ~_bad_user -} -returnCodes error -result {user "_bad_user" doesn't exist} +} -returnCodes error -result {could not read "~_bad_user": no such file or directory} catch {testsetplatform $platform} @@ -1063,9 +1053,8 @@ test cmdAH-19.9 {Tcl_FileObjCmd: ~ : exists} { file exists ~nOsUcHuSeR } 0 test cmdAH-19.10 {Tcl_FileObjCmd: ~ : nativename} -body { - # should probably be a non-error in fact... file nativename ~nOsUcHuSeR -} -returnCodes error -match glob -result * +} -result ~nOsUcHuSeR # The test below has to be done in /tmp rather than the current directory in # order to guarantee (?) a local file system: some NFS file systems won't do # the stuff below correctly. @@ -1680,7 +1669,7 @@ test cmdAH-29.6.1 { # Error conditions test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file gorp x -} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, home, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file ex x } -match glob -result {unknown or ambiguous subcommand "ex": must be *} @@ -1699,9 +1688,6 @@ test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file t x } -match glob -result {unknown or ambiguous subcommand "t": must be *} -test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { - file dirname ~woohgy -} -result {user "woohgy" doesn't exist} # channels # In testing 'file channels', we need to make sure that a channel created in diff --git a/tests/exec.test b/tests/exec.test index 6e4718a..5ecfcac 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -440,15 +440,21 @@ test exec-10.19 {errors in exec invocation} -constraints {exec} -body { exec cat >@ $f } -returnCodes error -result "channel \"$f\" wasn't opened for writing" close $f -test exec-10.20 {errors in exec invocation} -constraints {exec notValgrind} -body { +test exec-10.20.1 {errors in exec invocation} -constraints {unix exec notValgrind} -body { exec ~non_existent_user/foo/bar -} -returnCodes error -result {user "non_existent_user" doesn't exist} -test exec-10.21 {errors in exec invocation} -constraints {exec notValgrind} -body { +} -returnCodes error -result {couldn't execute "~non_existent_user/foo/bar": no such file or directory} +test exec-10.20.1 {errors in exec invocation} -constraints {win exec notValgrind} -body { + exec ~non_existent_user/foo/bar +} -returnCodes error -result {couldn't execute "~non_existent_user\foo\bar": no such file or directory} +test exec-10.21.1 {errors in exec invocation} -constraints {unix exec notValgrind} -body { + exec [interpreter] true | ~xyzzy_bad_user/x | false +} -returnCodes error -result {couldn't execute "~xyzzy_bad_user/x": no such file or directory} +test exec-10.21.2 {errors in exec invocation} -constraints {win exec notValgrind} -body { exec [interpreter] true | ~xyzzy_bad_user/x | false -} -returnCodes error -result {user "xyzzy_bad_user" doesn't exist} +} -returnCodes error -result {couldn't execute "~xyzzy_bad_user\x": no such file or directory} test exec-10.22 {errors in exec invocation} -constraints {exec notValgrind} -body { exec echo test > ~non_existent_user/foo/bar -} -returnCodes error -result {user "non_existent_user" doesn't exist} +} -returnCodes error -result {couldn't write file "~non_existent_user/foo/bar": no such file or directory} # Commands in background. test exec-11.1 {commands in background} {exec} { diff --git a/tests/fCmd.test b/tests/fCmd.test index 13f3720..e9d7667 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -96,6 +96,14 @@ if {[testConstraint unix]} { set user "root" } } +if {[testConstraint win]} { + catch { + set user $::env(USERNAME) + } + if {$user eq ""} { + set user Administrator + } +} proc createfile {file {string a}} { set f [open $file w] @@ -122,6 +130,10 @@ proc checkcontent {file matchString} { } proc openup {path} { + # Double check for inadvertent ~ -> home directory mapping + if {[string match ~* $path]} { + set file ./$path + } testchmod 0o777 $path if {[file isdirectory $path]} { catch { @@ -137,9 +149,13 @@ proc cleanup {args} { foreach p [concat $wd $args] { set x "" catch { - set x [glob -directory $p tf* td*] + set x [glob -directory $p tf* td* ~*] } foreach file $x { + # Double check for inadvertent ~ -> home directory mapping + if {[string match ~* $file]} { + set file ./$file + } if { [catch {file delete -force -- $file}] && [testConstraint testchmod] @@ -179,6 +195,43 @@ test fCmd-1.1 {TclFileRenameCmd} -constraints {notRoot} -setup { file rename tf1 tf2 glob tf* } -result {tf2} +test fCmd-1.2 {TclFileRenameCmd when target is ~} -setup { + cleanup + createfile tf1 +} -cleanup { + file delete ./~ +} -body { + file rename tf1 ~ + file isfile ~ +} -result 1 +test fCmd-1.3 {TclFileRenameCmd when target is ~user} -setup { + cleanup + createfile tf1 +} -cleanup { + file delete ./~$user +} -body { + file rename tf1 ~$user + file isfile ~$user +} -result 1 +test fCmd-1.4 {TclFileRenameCmd when source is ~} -setup { + cleanup + createfile ./~ +} -cleanup { + file delete ./~ +} -body { + file rename ~ tf1 + list [file exists ~] [file exists tf1] +} -result {0 1} +test fCmd-1.5 {TclFileRenameCmd when source is ~user} -setup { + cleanup + createfile ./~$user +} -cleanup { + file delete ./~$user +} -body { + file rename ~$user tf1 + list [file exists ~$user] [file exists tf1] +} -result {0 1} + test fCmd-2.1 {TclFileCopyCmd} -constraints {notRoot} -setup { cleanup @@ -187,6 +240,42 @@ test fCmd-2.1 {TclFileCopyCmd} -constraints {notRoot} -setup { file copy tf1 tf2 lsort [glob tf*] } -result {tf1 tf2} +test fCmd-2.2 {TclFileCopyCmd when target is ~} -setup { + cleanup + createfile tf1 +} -cleanup { + file delete ./~ +} -body { + file copy tf1 ~ + list [file exists tf1] [file exists ~] +} -result {1 1} +test fCmd-2.3 {TclFileCopyCmd when target is ~user} -setup { + cleanup + createfile tf1 +} -cleanup { + file delete ./~$user +} -body { + file copy tf1 ~$user + list [file exists tf1] [file exists ~$user] +} -result {1 1} +test fCmd-2.4 {TclFileCopyCmd when source is ~} -setup { + cleanup + createfile ./~ +} -cleanup { + file delete ./~ +} -body { + file copy ~ tf1 + list [file exists ~] [file exists tf1] +} -result {1 1} +test fCmd-2.5 {TclFileCopyCmd when source is ~user} -setup { + cleanup + createfile ./~$user +} -cleanup { + file delete ./~$user +} -body { + file copy ~$user tf1 + list [file exists ~$user] [file exists tf1] +} -result {1 1} test fCmd-3.1 {FileCopyRename: FileForceOption fails} -constraints {notRoot} -body { file rename -xyz @@ -196,7 +285,7 @@ test fCmd-3.2 {FileCopyRename: not enough args} -constraints {notRoot} -body { } -returnCodes error -result {wrong # args: should be "file rename ?-option value ...? source ?source ...? target"} test fCmd-3.3 {FileCopyRename: Tcl_TranslateFileName fails} -constraints {notRoot} -body { file rename xyz ~_totally_bogus_user -} -returnCodes error -result {user "_totally_bogus_user" doesn't exist} +} -returnCodes error -result {error renaming "xyz": no such file or directory} test fCmd-3.4 {FileCopyRename: Tcl_TranslateFileName passes} -setup { cleanup } -constraints {notRoot} -returnCodes error -body { @@ -270,7 +359,7 @@ test fCmd-3.14 {FileCopyRename: FileBasename fails} -setup { } -constraints {notRoot} -returnCodes error -body { file mkdir td1 file rename ~_totally_bogus_user td1 -} -result {user "_totally_bogus_user" doesn't exist} +} -result {error renaming "~_totally_bogus_user": no such file or directory} test fCmd-3.15 {FileCopyRename: source[0] == '\x00'} -setup { cleanup } -constraints {notRoot unixOrWin} -returnCodes error -body { @@ -308,11 +397,17 @@ test fCmd-4.3 {TclFileMakeDirsCmd: stops on first error} -setup { catch {file mkdir td1 td2 tf1 td3 td4} glob td1 td2 tf1 td3 td4 } -result {td1 td2 tf1} -test fCmd-4.4 {TclFileMakeDirsCmd: Tcl_TranslateFileName fails} -setup { +test fCmd-4.4 {TclFileMakeDirsCmd: Tcl_TranslateFileName treats ~ as normal char} -setup { cleanup -} -constraints {notRoot} -returnCodes error -body { +} -constraints {notRoot} -body { + list [file isdir ~] [file mkdir ~] [file isdir ~] +} -result {0 {} 1} +test fCmd-4.4.1 {TclFileMakeDirsCmd: Tcl_TranslateFileName treats ~ as normal char} -setup { + cleanup +} -constraints {notRoot} -body { file mkdir ~_totally_bogus_user -} -result {user "_totally_bogus_user" doesn't exist} + file isdir ~_totally_bogus_user +} -result 1 test fCmd-4.5 {TclFileMakeDirsCmd: Tcl_SplitPath returns 0: *name == '\x00'} -setup { cleanup } -constraints {notRoot} -returnCodes error -body { @@ -420,15 +515,16 @@ test fCmd-5.5 {TclFileDeleteCmd: stop at first error} -setup { catch {file delete tf1 td1 $root tf2} list [file exists tf1] [file exists tf2] [file exists td1] } -cleanup {cleanup} -result {0 1 0} -test fCmd-5.6 {TclFileDeleteCmd: Tcl_TranslateFileName fails} -constraints {notRoot} -body { +test fCmd-5.6 { + TclFileDeleteCmd: Tcl_TranslateFileName treats ~user as normal char +} -constraints {notRoot} -body { file delete ~_totally_bogus_user -} -returnCodes error -result {user "_totally_bogus_user" doesn't exist} -test fCmd-5.7 {TclFileDeleteCmd: Tcl_TranslateFileName succeeds} -setup { - catch {file delete ~/tf1} +} -result {} +test fCmd-5.7 { + TclFileDeleteCmd: Tcl_TranslateFileName treats ~ as normal char } -constraints {notRoot} -body { createfile ~/tf1 - file delete ~/tf1 -} -result {} +} -returnCodes error -result {couldn't open "~/tf1": no such file or directory} test fCmd-5.8 {TclFileDeleteCmd: file doesn't exist: lstat(name) != 0} -setup { cleanup } -constraints {notRoot} -body { @@ -627,37 +723,37 @@ test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} -setup { test fCmd-6.24 {CopyRenameOneFile: error uses original name} -setup { cleanup } -constraints {unix notRoot} -body { - file mkdir ~/td1/td2 - set td1name [file join [file dirname ~] [file tail ~] td1] + file mkdir [file home]/td1/td2 + set td1name [file join [file dirname [file home]] [file tail [file home]] td1] file attributes $td1name -permissions 0 - file copy ~/td1 td1 + file copy [file home]/td1 td1 } -returnCodes error -cleanup { file attributes $td1name -permissions 0o755 - file delete -force ~/td1 -} -result {error copying "~/td1": permission denied} + file delete -force [file home]/td1 +} -result "error copying \"[file home]/td1\": permission denied" test fCmd-6.25 {CopyRenameOneFile: error uses original name} -setup { cleanup } -constraints {unix notRoot} -body { file mkdir td2 - file mkdir ~/td1 - set td1name [file join [file dirname ~] [file tail ~] td1] + file mkdir [file home]/td1 + set td1name [file join [file dirname [file home]] [file tail [file home]] td1] file attributes $td1name -permissions 0 - file copy td2 ~/td1 + file copy td2 [file home]/td1 } -returnCodes error -cleanup { file attributes $td1name -permissions 0o755 - file delete -force ~/td1 -} -result {error copying "td2" to "~/td1/td2": permission denied} + file delete -force [file home]/td1 +} -result "error copying \"td2\" to \"[file home]/td1/td2\": permission denied" test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} -setup { cleanup } -constraints {unix notRoot} -body { - file mkdir ~/td1/td2 - set td2name [file join [file dirname ~] [file tail ~] td1 td2] + file mkdir [file home]/td1/td2 + set td2name [file join [file dirname [file home]] [file tail [file home]] td1 td2] file attributes $td2name -permissions 0 - file copy ~/td1 td1 + file copy [file home]/td1 td1 } -returnCodes error -cleanup { file attributes $td2name -permissions 0o755 - file delete -force ~/td1 -} -result "error copying \"~/td1\" to \"td1\": \"[file join $::env(HOME) td1 td2]\": permission denied" + file delete -force [file home]/td1 +} -result "error copying \"[file home]/td1\" to \"td1\": \"[file join $::env(HOME) td1 td2]\": permission denied" test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} -setup { cleanup $tmpspace } -constraints {notRoot xdev} -returnCodes error -body { @@ -741,7 +837,7 @@ test fCmd-7.5 {FileForceOption: multiple times through loop} -setup { } -result {no files matched glob patterns "-- -force"} test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} \ - -constraints {unix notRoot knownBug} -body { + -constraints {unix notRoot knownBug tildeexpansion} -body { # Labelled knownBug because it is dangerous [Bug: 3881] file mkdir td1 file attr td1 -perm 0o40000 @@ -752,11 +848,11 @@ test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} \ test fCmd-8.2 {FileBasename: basename of ~user: argc == 1 && *path == ~} \ -constraints {unix notRoot} -body { string equal [file tail ~$user] ~$user -} -result 0 +} -result 1 test fCmd-8.3 {file copy and path translation: ensure correct error} -body { - file copy ~ [file join this file doesnt exist] + file copy [file home] [file join this file doesnt exist] } -returnCodes error -result [subst \ - {error copying "~" to "[file join this file doesnt exist]": no such file or directory}] + {error copying "[file home]" to "[file join this file doesnt exist]": no such file or directory}] test fCmd-9.1 {file rename: comprehensive: EACCES} -setup { cleanup @@ -1498,15 +1594,17 @@ test fCmd-14.8 {copyfile: copy directory failing} -setup { # # Coverage tests for TclMkdirCmd() # + +# ~ is no longer a special char. Need a test case where translation fails. test fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} -setup { set temp $::env(HOME) -} -constraints {notRoot} -body { +} -constraints {notRoot TODO} -body { global env unset env(HOME) catch {file mkdir ~/tfa} } -cleanup { set ::env(HOME) $temp -} -result {1} +} -result 1 # # Can Tcl_SplitPath return argc == 0? If so them we need a test for that code. # @@ -1599,9 +1697,10 @@ test fCmd-16.4 {accept zero files (TIP 323)} -body { test fCmd-16.5 {accept zero files (TIP 323)} -body { file delete -- } -result {} +# ~ is no longer a special char. Need a test case where translation fails. test fCmd-16.6 {delete: source filename translation failing} -setup { set temp $::env(HOME) -} -constraints {notRoot} -body { +} -constraints {notRoot TODO} -body { global env unset env(HOME) catch {file delete ~/tfa} @@ -2227,7 +2326,7 @@ test fCmd-27.2 {TclFileAttrsCmd - Tcl_TranslateFileName fails} -setup { file attributes ~_totally_bogus_user } -returnCodes error -cleanup { testsetplatform $platform -} -result {user "_totally_bogus_user" doesn't exist} +} -result {could not read "~_totally_bogus_user": no such file or directory} test fCmd-27.3 {TclFileAttrsCmd - all attributes} -setup { catch {file delete -force -- foo.tmp} } -body { @@ -2556,6 +2655,57 @@ test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {win notInCIenv} - } return $r } -result {exists 1 readable 0 stat 0 {}} + +test fCmd-31.1 {file home} -body { + file home +} -result [file join $::env(HOME)] +test fCmd-31.2 {file home - obeys env} -setup { + set ::env(HOME) $::env(HOME)/xxx +} -cleanup { + set ::env(HOME) [file dirname $::env(HOME)] +} -body { + file home +} -result [file join $::env(HOME) xxx] +test fCmd-31.3 {file home - \ -> /} -constraints win -setup { + set saved $::env(HOME) + set ::env(HOME) C:\\backslash\\path +} -cleanup { + set ::env(HOME) $saved +} -body { + file home +} -result C:/backslash/path +test fCmd-31.4 {file home - error} -setup { + set saved $::env(HOME) + unset ::env(HOME) +} -cleanup { + set ::env(HOME) $saved +} -body { + file home +} -returnCodes error -result {couldn't find HOME environment variable to expand path} +test fCmd-31.5 { + file home - relative path. Following 8.x ~ expansion behavior, relative + paths are not made absolute +} -setup { + set saved $::env(HOME) + set ::env(HOME) relative/path +} -cleanup { + set ::env(HOME) $saved +} -body { + file home +} -result relative/path +test fCmd-31.6 {file home USER} -body { + # Note - as in 8.x this form does NOT necessarily give same result as + # env(HOME) even when user is current user. Assume result contains user + # name, else not sure how to check + file home $::tcl_platform(user) +} -match glob -result "*$::tcl_platform(user)*" +test fCmd-31.6 {file home UNKNOWNUSER} -body { + file home nosuchuser +} -returnCodes error -result {user "nosuchuser" doesn't exist} +test fCmd-31.7 {file home extra arg} -body { + file home $::tcl_platform(user) arg +} -returnCodes error -result {wrong # args: should be "file home ?user?"} + # cleanup cleanup diff --git a/tests/fileName.test b/tests/fileName.test index 04273d7..0dd6f86 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -71,15 +71,15 @@ test filename-1.4 {Tcl_GetPathType: unix} {testsetplatform} { test filename-1.5 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype ~ -} absolute +} relative test filename-1.6 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype ~/foo -} absolute +} relative test filename-1.7 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype ~foo -} absolute +} relative test filename-1.8 {Tcl_GetPathType: unix} {testsetplatform} { testsetplatform unix file pathtype ./~foo @@ -136,15 +136,15 @@ test filename-3.12 {Tcl_GetPathType: windows} {testsetplatform} { test filename-3.13 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype ~foo -} absolute +} relative test filename-3.14 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype ~ -} absolute +} relative test filename-3.15 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype ~/foo -} absolute +} relative test filename-3.16 {Tcl_GetPathType: windows} {testsetplatform} { testsetplatform windows file pathtype ./~foo @@ -213,11 +213,11 @@ test filename-4.15 {Tcl_SplitPath: unix} {testsetplatform} { test filename-4.16 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split ~foo/~bar -} {~foo ./~bar} +} {~foo ~bar} test filename-4.17 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split ~foo/~bar/~baz -} {~foo ./~bar ./~baz} +} {~foo ~bar ~baz} test filename-4.18 {Tcl_SplitPath: unix} {testsetplatform} { testsetplatform unix file split foo/bar~/baz @@ -357,11 +357,11 @@ test filename-6.26 {Tcl_SplitPath: win} {testsetplatform} { test filename-6.27 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split ~foo/~bar -} {~foo ./~bar} +} {~foo ~bar} test filename-6.28 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split ~foo/~bar/~baz -} {~foo ./~bar ./~baz} +} {~foo ~bar ~baz} test filename-6.29 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split foo/bar~/baz @@ -369,7 +369,7 @@ test filename-6.29 {Tcl_SplitPath: win} {testsetplatform} { test filename-6.30 {Tcl_SplitPath: win} {testsetplatform} { testsetplatform win file split c:~foo -} {c: ./~foo} +} {c: ~foo} test filename-7.1 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix @@ -414,7 +414,7 @@ test filename-7.10 {Tcl_JoinPath: unix} {testsetplatform} { test filename-7.11 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ~a ~b -} {~b} +} {~a/~b} test filename-7.12 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ./~a b @@ -422,11 +422,11 @@ test filename-7.12 {Tcl_JoinPath: unix} {testsetplatform} { test filename-7.13 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ./~a ~b -} {~b} +} {./~a/~b} test filename-7.14 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join ./~a ./~b -} {./~a/~b} +} {./~a/./~b} test filename-7.15 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join a . b @@ -434,7 +434,7 @@ test filename-7.15 {Tcl_JoinPath: unix} {testsetplatform} { test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join a . ./~b -} {a/./~b} +} {a/././~b} test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} { testsetplatform unix file join //a b @@ -490,11 +490,11 @@ test filename-9.10 {Tcl_JoinPath: win} {testsetplatform} { test filename-9.11 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join ~ ./~foo -} {~/~foo} +} {~/./~foo} test filename-9.12 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join / ~foo -} {~foo} +} {/~foo} test filename-9.13 {Tcl_JoinPath: win} {testsetplatform} { testsetplatform win file join ./a/ b c @@ -600,7 +600,7 @@ test filename-10.6 {Tcl_TranslateFileName} -setup { testtranslatefilename ~/foo } -cleanup { set env(HOME) $temp -} -result {/home/test/foo} +} -result {~/foo} test filename-10.7 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -608,9 +608,9 @@ test filename-10.7 {Tcl_TranslateFileName} -setup { unset env(HOME) testsetplatform unix testtranslatefilename ~/foo -} -returnCodes error -cleanup { +} -cleanup { set env(HOME) $temp -} -result {couldn't find HOME environment variable to expand path} +} -result {~/foo} test filename-10.8 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -620,7 +620,7 @@ test filename-10.8 {Tcl_TranslateFileName} -setup { testtranslatefilename ~ } -cleanup { set env(HOME) $temp -} -result {/home/test} +} -result {~} test filename-10.9 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -630,7 +630,7 @@ test filename-10.9 {Tcl_TranslateFileName} -setup { testtranslatefilename ~ } -cleanup { set env(HOME) $temp -} -result {/home/test} +} -result {~} test filename-10.10 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -640,7 +640,7 @@ test filename-10.10 {Tcl_TranslateFileName} -setup { testtranslatefilename ~/foo } -cleanup { set env(HOME) $temp -} -result {/home/test/foo} +} -result {~/foo} test filename-10.17 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -650,7 +650,7 @@ test filename-10.17 {Tcl_TranslateFileName} -setup { testtranslatefilename ~/foo } -cleanup { set env(HOME) $temp -} -result {\home\foo} +} -result {~\foo} test filename-10.18 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -660,7 +660,7 @@ test filename-10.18 {Tcl_TranslateFileName} -setup { testtranslatefilename ~/foo\\bar } -cleanup { set env(HOME) $temp -} -result {\home\foo\bar} +} -result {~\foo\bar} test filename-10.19 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -670,11 +670,11 @@ test filename-10.19 {Tcl_TranslateFileName} -setup { testtranslatefilename ~/foo } -cleanup { set env(HOME) $temp -} -result {c:foo} -test filename-10.20 {Tcl_TranslateFileName} -returnCodes error -body { +} -result {~\foo} +test filename-10.20 {Tcl_TranslateFileName} -body { testtranslatefilename ~blorp/foo } -constraints {testtranslatefilename testtranslatefilename} \ - -result {user "blorp" doesn't exist} + -result {~blorp\foo} test filename-10.21 {Tcl_TranslateFileName} -setup { global env set temp $env(HOME) @@ -684,7 +684,7 @@ test filename-10.21 {Tcl_TranslateFileName} -setup { testtranslatefilename ~/foo } -cleanup { set env(HOME) $temp -} -result {c:\foo} +} -result {~\foo} test filename-10.22 {Tcl_TranslateFileName} -body { testsetplatform windows testtranslatefilename foo//bar @@ -713,12 +713,13 @@ test filename-11.3 {Tcl_GlobCmd} -body { test filename-11.4 {Tcl_GlobCmd} -body { glob -nocomplain } -result {} -test filename-11.5 {Tcl_GlobCmd} -returnCodes error -body { - glob -nocomplain * ~xyqrszzz -} -result {user "xyqrszzz" doesn't exist} +test filename-11.5 {Tcl_GlobCmd} -body { + # Should not error out because of ~ + catch {glob -nocomplain * ~xyqrszzz} +} -result 0 test filename-11.6 {Tcl_GlobCmd} -returnCodes error -body { glob ~xyqrszzz -} -result {user "xyqrszzz" doesn't exist} +} -result {no files matched glob pattern "~xyqrszzz"} test filename-11.7 {Tcl_GlobCmd} -returnCodes error -body { glob -- -nocomplain } -result {no files matched glob pattern "-nocomplain"} @@ -728,15 +729,15 @@ test filename-11.8 {Tcl_GlobCmd} -body { test filename-11.9 {Tcl_GlobCmd} -constraints {testsetplatform} -body { testsetplatform unix glob ~\\xyqrszzz/bar -} -returnCodes error -result {user "\xyqrszzz" doesn't exist} +} -returnCodes error -result {no files matched glob pattern "~\xyqrszzz/bar"} test filename-11.10 {Tcl_GlobCmd} -constraints {testsetplatform} -body { testsetplatform unix glob -nocomplain ~\\xyqrszzz/bar -} -returnCodes error -result {user "\xyqrszzz" doesn't exist} +} -result {} test filename-11.11 {Tcl_GlobCmd} -constraints {testsetplatform} -body { testsetplatform unix glob ~xyqrszzz\\/\\bar -} -returnCodes error -result {user "xyqrszzz" doesn't exist} +} -returnCodes error -result {no files matched glob pattern "~xyqrszzz\/\bar"} test filename-11.12 {Tcl_GlobCmd} -constraints {testsetplatform} -setup { testsetplatform unix set home $env(HOME) @@ -745,13 +746,13 @@ test filename-11.12 {Tcl_GlobCmd} -constraints {testsetplatform} -setup { glob ~/* } -returnCodes error -cleanup { set env(HOME) $home -} -result {couldn't find HOME environment variable to expand path} +} -result {no files matched glob pattern "~/*"} if {[testConstraint testsetplatform]} { testsetplatform $platform } -test filename-11.13 {Tcl_GlobCmd} { +test filename-11.13 {Tcl_GlobCmd} -body { file join [lindex [glob ~] 0] -} [file join $env(HOME)] +} -returnCodes error -result {no files matched glob pattern "~"} set oldpwd [pwd] set oldhome $env(HOME) catch {cd [makeDirectory tcl[pid]]} @@ -769,12 +770,12 @@ touch globTest/a1/b1/x2.c touch globTest/a1/b2/y2.c touch globTest/.1 touch globTest/x,z1.c -test filename-11.14 {Tcl_GlobCmd} { +test filename-11.14 {Tcl_GlobCmd} -body { glob ~/globTest -} [list [file join $env(HOME) globTest]] -test filename-11.15 {Tcl_GlobCmd} { +} -returnCodes error -result {no files matched glob pattern "~/globTest"} +test filename-11.15 {Tcl_GlobCmd} -body { glob ~\\/globTest -} [list [file join $env(HOME) globTest]] +} -returnCodes error -result {no files matched glob pattern "~\/globTest"} test filename-11.16 {Tcl_GlobCmd} { glob globTest } {globTest} @@ -1252,7 +1253,7 @@ test filename-14.17 {asterisks, question marks, and brackets} -setup { set temp $env(HOME) } -body { set env(HOME) [file join $env(HOME) globTest] - glob ~/z* + glob [file home]/z* } -cleanup { set env(HOME) $temp } -result [list [file join $env(HOME) globTest z1.c]] @@ -1349,11 +1350,10 @@ test filename-15.4 {unix specific no complain: no errors, good result} \ glob -nocomplain ~ouster ~foo ~welch } {/home/ouster /home/welch} test filename-15.4.1 {no complain: errors, sequencing} { - # test used to fail because if an error occurs, the interp's result is - # reset... But, the sequence means we throw a different error first. + # ~xxx no longer expanded so errors about unknown users should not occur list [catch {glob -nocomplain ~wontexist ~blahxyz ~} res1] $res1 \ [catch {glob -nocomplain ~ ~blahxyz ~wontexist} res2] $res2 -} {1 {user "wontexist" doesn't exist} 1 {user "blahxyz" doesn't exist}} +} {0 {} 0 {}} test filename-15.4.2 {no complain: errors, sequencing} -body { # test used to fail because if an error occurs, the interp's result is # reset... @@ -1363,20 +1363,12 @@ test filename-15.4.2 {no complain: errors, sequencing} -body { test filename-15.5 {unix specific globbing} {unix nonPortable} { glob ~ouster/.csh* } "/home/ouster/.cshrc" -touch globTest/odd\\\[\]*?\{\}name -test filename-15.6 {unix specific globbing} -constraints {unix} -setup { - global env - set temp $env(HOME) -} -body { - set env(HOME) $env(HOME)/globTest/odd\\\[\]*?\{\}name - glob ~ -} -cleanup { - set env(HOME) $temp -} -result [list [lindex [glob ~] 0]/globTest/odd\\\[\]*?\{\}name] -catch {file delete -force globTest/odd\\\[\]*?\{\}name} -test filename-15.7 {win specific globbing} -constraints {win} -body { +# 15.6 removed. It checked if glob ~ returned valid information if +# home directory contained glob chars. Since ~ expansion is no longer +# supported, the test was meaningless +test filename-15.7 {glob tilde} -body { glob ~ -} -match regexp -result {[^/]$} +} -returnCodes error -result {no files matched glob pattern "~"} test filename-15.8 {win and unix specific globbing} -constraints {unixOrWin} -setup { global env set temp $env(HOME) @@ -1387,7 +1379,7 @@ test filename-15.8 {win and unix specific globbing} -constraints {unixOrWin} -se } -cleanup { set env(HOME) $temp catch {file delete -force $env(HOME)/globTest/anyname} -} -result [list [lindex [glob ~] 0]/globTest/anyname] +} -returnCodes error -result {no files matched glob pattern "~"} # The following tests are only valid for Windows systems. set oldDir [pwd] @@ -1566,7 +1558,7 @@ test fileName-20.5 {Bug 2837800} -setup { test fileName-20.6 {Bug 2837800} -setup { # Recall that we have $env(HOME) set so that references # to ~ point to [temporaryDirectory] - makeFile {} test ~ + makeFile {} test [file home] set dd [makeDirectory isolate] set d [makeDirectory ./~ $dd] set savewd [pwd] @@ -1602,33 +1594,21 @@ test fileName-20.8 {Bug 2806250} -setup { removeFile ./~test $d removeDirectory isolate cd $savewd -} -result ./~test -test fileName-20.9 {globbing for special chars} -setup { - makeFile {} test ~ - set d [makeDirectory isolate] - set savewd [pwd] - cd $d -} -body { - glob -nocomplain -directory ~ test -} -cleanup { - cd $savewd - removeDirectory isolate - removeFile test ~ -} -result ~/test +} -result ~test test fileName-20.10 {globbing for special chars} -setup { - set s [makeDirectory sub ~] + set s [makeDirectory sub [file home]] makeFile {} fileName-20.10 $s set d [makeDirectory isolate] set savewd [pwd] cd $d } -body { - glob -nocomplain -directory ~ -join * fileName-20.10 + glob -nocomplain -directory [file home] -join * fileName-20.10 } -cleanup { cd $savewd removeDirectory isolate removeFile fileName-20.10 $s - removeDirectory sub ~ -} -result ~/sub/fileName-20.10 + removeDirectory sub [file home] +} -result [file home]/sub/fileName-20.10 # cleanup catch {file delete -force C:/globTest} diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 0b53be5..462b61e 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -267,15 +267,14 @@ file delete -force [file join dir.dir dirinside.link] removeFile [file join dir.dir inside.file] removeDirectory [file join dir.dir dirinside.dir] removeDirectory dir.dir -test filesystem-1.30 {normalisation of nonexistent user} -body { +test filesystem-1.30 { + normalisation of nonexistent user - verify no tilde expansion +} -body { file normalize ~noonewiththisname -} -returnCodes error -result {user "noonewiththisname" doesn't exist} +} -result [file join [pwd] ~noonewiththisname] test filesystem-1.30.1 {normalisation of existing user} -body { - catch {file normalize ~$::tcl_platform(user)} -} -result {0} -test filesystem-1.30.2 {normalisation of nonexistent user specified as user@domain} -body { - file normalize ~nonexistentuser@nonexistentdomain -} -returnCodes error -result {user "nonexistentuser@nonexistentdomain" doesn't exist} + file normalize ~$::tcl_platform(user) +} -result [file join [pwd] ~$::tcl_platform(user)] test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} { testsetplatform unix file normalize /foo/../bar @@ -473,7 +472,10 @@ test filesystem-4.3 {testfilesystem} -constraints testfilesystem -body { return $filesystemReport } -match glob -result {*{matchindirectory *}*} -test filesystem-5.1 {cache and ~} -constraints testfilesystem -setup { +# This test is meaningless if there is no tilde expansion +test filesystem-5.1 {cache and ~} -constraints { + testfilesystem tildeexpansion +} -setup { set orig $::env(HOME) } -body { set ::env(HOME) /foo/bar/blah @@ -939,7 +941,7 @@ test filesystem-9.7 {path objects and glob and file tail and tilde} -setup { cd [tcltest::temporaryDirectory] file delete -force tilde cd $origdir -} -result {0 1 {user "testNotExist" doesn't exist} ~testNotExist 0 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}} +} -result {1 0 ~testNotExist ~testNotExist 1 0 ~testNotExist 0 ~testNotExist} test filesystem-9.8 {path objects and glob and file tail and tilde} -setup { set res {} set origdir [pwd] @@ -957,7 +959,7 @@ test filesystem-9.8 {path objects and glob and file tail and tilde} -setup { cd [tcltest::temporaryDirectory] file delete -force tilde cd $origdir -} -result {~testNotExist ~testNotExist 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}} +} -result {~testNotExist ~testNotExist 0 ~testNotExist 0 ~testNotExist} test filesystem-9.9 {path objects and glob and file tail and tilde} -setup { set res {} set origdir [pwd] @@ -975,7 +977,7 @@ test filesystem-9.9 {path objects and glob and file tail and tilde} -setup { cd [tcltest::temporaryDirectory] file delete -force tilde cd $origdir -} -result {0 0 0 0 1} +} -result {0 1 0 1 1} # ---------------------------------------------------------------------- diff --git a/tests/io.test b/tests/io.test index dca88a4..c4a6b5a 100644 --- a/tests/io.test +++ b/tests/io.test @@ -5956,7 +5956,7 @@ test io-40.17 {tilde substitution in open} { set x [list [catch {open ~/foo} msg] $msg] set ::env(HOME) $home set x -} {1 {couldn't find HOME environment variable to expand path}} +} {1 {couldn't open "~/foo": no such file or directory}} test io-41.1 {Tcl_FileeventCmd: errors} {fileevent} { list [catch {fileevent foo} msg] $msg diff --git a/tests/safe.test b/tests/safe.test index c355171..6fc4fbe 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1621,7 +1621,7 @@ test safe-16.5 {Bug 3529949: defang ~ in paths used by AliasGlob (1)} -setup { safe::interpDelete $i set env(HOME) $savedHOME unset savedHOME -} -result {~} +} -result {$p(:0:)/~} test safe-16.6 {Bug 3529949: defang ~ in paths used by AliasGlob (2)} -setup { set savedHOME $env(HOME) set env(HOME) /foo/bar @@ -1635,7 +1635,7 @@ test safe-16.6 {Bug 3529949: defang ~ in paths used by AliasGlob (2)} -setup { safe::interpDelete $i set env(HOME) $savedHOME unset savedHOME -} -result {~} +} -result {$p(:0:)/foo/bar/~} test safe-16.7 {Bug 3529949: defang ~user in paths used by AliasGlob (1)} -setup { set i [safe::interpCreate] set user $tcl_platform(user) @@ -1644,7 +1644,7 @@ test safe-16.7 {Bug 3529949: defang ~user in paths used by AliasGlob (1)} -setup } -cleanup { safe::interpDelete $i unset user -} -result {~USER} +} -result {$p(:0:)/~USER} test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup { set i [safe::interpCreate] set user $tcl_platform(user) @@ -1653,7 +1653,7 @@ test safe-16.8 {Bug 3529949: defang ~user in paths used by AliasGlob (2)} -setup } -cleanup { safe::interpDelete $i unset user -} -result {~USER} +} -result {$p(:0:)/foo/bar/~USER} # cleanup set ::auto_path $SaveAutoPath diff --git a/tests/winFile.test b/tests/winFile.test index 0c13a0e..38f6954 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -28,7 +28,7 @@ testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] test winFile-1.1 {TclpGetUserHome} -constraints {win} -body { glob ~nosuchuser -} -returnCodes error -result {user "nosuchuser" doesn't exist} +} -returnCodes error -result {no files matched glob pattern "~nosuchuser"} test winFile-1.2 {TclpGetUserHome} -constraints {win nonPortable} -body { # The administrator account should always exist. glob ~administrator -- cgit v0.12 From b4eda6649fc4011ca9c9693ee8752f1ba2c24437 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 7 Aug 2022 10:11:42 +0000 Subject: Remove code that was ifdef'ed out --- generic/tclEnv.c | 12 -- generic/tclFCmd.c | 11 -- generic/tclFileName.c | 295 +++++++++++--------------------------------------- generic/tclIOUtil.c | 14 +-- generic/tclPathObj.c | 157 +-------------------------- library/safe.tcl | 5 - unix/tclUnixInit.c | 3 +- win/tclWinFCmd.c | 15 --- 8 files changed, 70 insertions(+), 442 deletions(-) diff --git a/generic/tclEnv.c b/generic/tclEnv.c index e469fe9..07cdbb0 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -364,18 +364,6 @@ TclSetEnv( } Tcl_MutexUnlock(&envMutex); - -#ifdef TCL_TILDE_EXPAND - if (!strcmp(name, "HOME")) { - /* - * If the user's home directory has changed, we must invalidate the - * filesystem cache, because '~' expansions will now be incorrect. - */ - - Tcl_FSMountsChanged(NULL); - } -#endif - } /* diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 9a107da..d7fa750 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -882,17 +882,6 @@ FileBasename( Tcl_IncrRefCount(splitPtr); if (objc != 0) { -#ifdef TCL_TILDE_EXPAND - if ((objc == 1) && (*TclGetString(pathPtr) == '~')) { - Tcl_DecrRefCount(splitPtr); - if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { - return NULL; - } - splitPtr = Tcl_FSSplitPath(pathPtr, &objc); - Tcl_IncrRefCount(splitPtr); - } -#endif - /* * Return the last component, unless it is the only component, and it * is the root of an absolute path. diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 3ffdede..d560710 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -362,13 +362,6 @@ Tcl_GetPathType( * file). The exported function Tcl_FSGetPathType should be used by * extensions. * - * If TCL_TILDE_EXPAND defined: - * Note that '~' paths are always considered TCL_PATH_ABSOLUTE, even - * though expanding the '~' could lead to any possible path type. This - * function should therefore be considered a low-level, string - * manipulation function only -- it doesn't actually do any expansion in - * making its determination. - * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or * TCL_PATH_VOLUME_RELATIVE. @@ -389,85 +382,66 @@ TclpGetNativePathType( Tcl_PathType type = TCL_PATH_ABSOLUTE; const char *path = TclGetString(pathPtr); - if (path[0] == '~') { -#ifdef TCL_TILDE_EXPAND - /* - * This case is common to all platforms. Paths that begin with ~ are - * absolute. - */ - - if (driveNameLengthPtr != NULL) { - const char *end = path + 1; - while ((*end != '\0') && (*end != '/')) { - end++; - } - *driveNameLengthPtr = end - path; - } -#else - type = TCL_PATH_RELATIVE; -#endif - } else { - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: { - const char *origPath = path; + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: { + const char *origPath = path; - /* - * Paths that begin with / are absolute. - */ + /* + * Paths that begin with / are absolute. + */ - if (path[0] == '/') { - ++path; + if (path[0] == '/') { + ++path; #if defined(__CYGWIN__) || defined(__QNX__) - /* - * Check for "//" network path prefix - */ - if ((*path == '/') && path[1] && (path[1] != '/')) { - path += 2; - while (*path && *path != '/') { - ++path; - } + /* + * Check for "//" network path prefix + */ + if ((*path == '/') && path[1] && (path[1] != '/')) { + path += 2; + while (*path && *path != '/') { + ++path; + } #if defined(__CYGWIN__) - /* UNC paths need to be followed by a share name */ - if (*path++ && (*path && *path != '/')) { - ++path; - while (*path && *path != '/') { - ++path; - } - } else { - path = origPath + 1; - } + /* UNC paths need to be followed by a share name */ + if (*path++ && (*path && *path != '/')) { + ++path; + while (*path && *path != '/') { + ++path; + } + } else { + path = origPath + 1; + } #endif - } + } #endif - if (driveNameLengthPtr != NULL) { - /* - * We need this addition in case the QNX or Cygwin code was used. - */ - - *driveNameLengthPtr = (path - origPath); - } - } else { - type = TCL_PATH_RELATIVE; - } - break; - } - case TCL_PLATFORM_WINDOWS: { - Tcl_DString ds; - const char *rootEnd; - - Tcl_DStringInit(&ds); - rootEnd = ExtractWinRoot(path, &ds, 0, &type); - if ((rootEnd != path) && (driveNameLengthPtr != NULL)) { - *driveNameLengthPtr = rootEnd - path; - if (driveNameRef != NULL) { - *driveNameRef = TclDStringToObj(&ds); - Tcl_IncrRefCount(*driveNameRef); - } - } - Tcl_DStringFree(&ds); - break; - } - } + if (driveNameLengthPtr != NULL) { + /* + * We need this addition in case the QNX or Cygwin code was used. + */ + + *driveNameLengthPtr = (path - origPath); + } + } else { + type = TCL_PATH_RELATIVE; + } + break; + } + case TCL_PLATFORM_WINDOWS: { + Tcl_DString ds; + const char *rootEnd; + + Tcl_DStringInit(&ds); + rootEnd = ExtractWinRoot(path, &ds, 0, &type); + if ((rootEnd != path) && (driveNameLengthPtr != NULL)) { + *driveNameLengthPtr = rootEnd - path; + if (driveNameRef != NULL) { + *driveNameRef = TclDStringToObj(&ds); + Tcl_IncrRefCount(*driveNameRef); + } + } + Tcl_DStringFree(&ds); + break; + } } return type; } @@ -702,16 +676,7 @@ SplitUnixPath( length = path - elementStart; if (length > 0) { Tcl_Obj *nextElt; -#ifdef TCL_TILDE_EXPAND - if ((elementStart[0] == '~') && (elementStart != origPath)) { - TclNewLiteralStringObj(nextElt, "./"); - Tcl_AppendToObj(nextElt, elementStart, length); - } else { - nextElt = Tcl_NewStringObj(elementStart, length); - } -#else nextElt = Tcl_NewStringObj(elementStart, length); -#endif Tcl_ListObjAppendElement(NULL, result, nextElt); } if (*path++ == '\0') { @@ -775,12 +740,9 @@ SplitWinPath( length = p - elementStart; if (length > 0) { Tcl_Obj *nextElt; - if ((elementStart != path) && - ( -#ifdef TCL_TILDE_EXPAND - (elementStart[0] == '~') || -#endif - (isalpha(UCHAR(elementStart[0])) && elementStart[1] == ':'))) { + if ((elementStart != path) && + isalpha(UCHAR(elementStart[0])) && + (elementStart[1] == ':')) { TclNewLiteralStringObj(nextElt, "./"); Tcl_AppendToObj(nextElt, elementStart, length); } else { @@ -885,14 +847,10 @@ TclpNativeJoinPath( if (length != 0) { if ((p[0] == '.') && (p[1] == '/') && - ( -#ifdef TCL_TILDE_EXPAND - (p[2] == '~') || -#endif - (tclPlatform==TCL_PLATFORM_WINDOWS && - isalpha(UCHAR(p[2])) && - (p[3] == ':')))) { - p += 2; + (tclPlatform==TCL_PLATFORM_WINDOWS) && + isalpha(UCHAR(p[2])) && + (p[3] == ':')) { + p += 2; } } if (*p == '\0') { @@ -1164,67 +1122,6 @@ TclGetExtension( return p; } -#ifdef TCL_TILDE_EXPAND -/* - *---------------------------------------------------------------------- - * - * DoTildeSubst -- - * - * Given a string following a tilde, this routine returns the - * corresponding home directory. - * - * Results: - * The result is a pointer to a static string containing the home - * directory in native format. If there was an error in processing the - * substitution, then an error message is left in the interp's result and - * the return value is NULL. On success, the results are appended to - * resultPtr, and the contents of resultPtr are returned. - * - * Side effects: - * Information may be left in resultPtr. - * - *---------------------------------------------------------------------- - */ - -static const char * -DoTildeSubst( - Tcl_Interp *interp, /* Interpreter in which to store error message - * (if necessary). */ - const char *user, /* Name of user whose home directory should be - * substituted, or "" for current user. */ - Tcl_DString *resultPtr) /* Initialized DString filled with name after - * tilde substitution. */ -{ - const char *dir; - - if (*user == '\0') { - Tcl_DString dirString; - - dir = TclGetEnv("HOME", &dirString); - if (dir == NULL) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "couldn't find HOME environment " - "variable to expand path", -1)); - Tcl_SetErrorCode(interp, "TCL", "FILENAME", "NO_HOME", NULL); - } - return NULL; - } - Tcl_JoinPath(1, &dir, resultPtr); - Tcl_DStringFree(&dirString); - } else if (TclpGetUserHome(user, resultPtr) == NULL) { - if (interp) { - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "user \"%s\" doesn't exist", user)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "USER", user, NULL); - } - return NULL; - } - return Tcl_DStringValue(resultPtr); -} -#endif /* TCL_TILDE_EXPAND */ - /* *---------------------------------------------------------------------- * @@ -1749,7 +1646,7 @@ TclGlob( * NULL. */ { const char *separators; - char *tail, *start; + char *tail; int result; Tcl_Obj *filenamesObj, *savedResultObj; @@ -1763,65 +1660,10 @@ TclGlob( break; } - if (pathPrefix == NULL) { - Tcl_DString buffer; - Tcl_DStringInit(&buffer); - - start = pattern; - - /* - * Perform tilde substitution, if needed. - */ - -#ifdef TCL_TILDE_EXPAND - if (start[0] == '~') { - const char *head; - char c; - /* - * Find the first path separator after the tilde. - */ - - for (tail = start; *tail != '\0'; tail++) { - if (*tail == '\\') { - if (strchr(separators, tail[1]) != NULL) { - break; - } - } else if (strchr(separators, *tail) != NULL) { - break; - } - } - - /* - * Determine the home directory for the specified user. - */ - - c = *tail; - *tail = '\0'; - head = DoTildeSubst(interp, start+1, &buffer); - *tail = c; - if (head == NULL) { - return TCL_ERROR; - } - if (head != Tcl_DStringValue(&buffer)) { - Tcl_DStringAppend(&buffer, head, -1); - } - pathPrefix = TclDStringToObj(&buffer); - Tcl_IncrRefCount(pathPrefix); - globFlags |= TCL_GLOBMODE_DIR; - if (c != '\0') { - tail++; - } - Tcl_DStringFree(&buffer); - } else { - tail = pattern; - } -#else - tail = pattern; -#endif /* TCL_TILDE_EXPAND */ - } else { + if (pathPrefix != NULL) { Tcl_IncrRefCount(pathPrefix); - tail = pattern; } + tail = pattern; /* * Handling empty path prefixes with glob patterns like 'C:' or @@ -2375,15 +2217,6 @@ DoGlob( for (i=0; result==TCL_OK && i 0) { Tcl_Obj *nextElt; - -#ifdef TCL_TILDE_EXPAND - if (elementStart[0] == '~') { - TclNewLiteralStringObj(nextElt, "./"); - Tcl_AppendToObj(nextElt, elementStart, length); - } else { - nextElt = Tcl_NewStringObj(elementStart, length); - } -#else nextElt = Tcl_NewStringObj(elementStart, length); -#endif /* TCL_TILDE_EXPAND */ Tcl_ListObjAppendElement(NULL, result, nextElt); } if (*p++ == '\0') { diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index c123613..82b79f5 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -699,19 +699,7 @@ TclPathPart( splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements); Tcl_IncrRefCount(splitPtr); -#ifdef TCL_TILDE_EXPAND - if (splitElements == 1 && TclGetString(pathPtr)[0] == '~') { - Tcl_Obj *norm; - TclDecrRefCount(splitPtr); - norm = Tcl_FSGetNormalizedPath(interp, pathPtr); - if (norm == NULL) { - return NULL; - } - splitPtr = Tcl_FSSplitPath(norm, &splitElements); - Tcl_IncrRefCount(splitPtr); - } -#endif /* TCL_TILDE_EXPAND */ if (portion == TCL_PATH_TAIL) { /* * Return the last component, unless it is the only component, and @@ -1040,18 +1028,6 @@ TclJoinPath( } ptr = Tcl_GetStringFromObj(res, &length); -#ifdef TCL_TILDE_EXPAND - /* - * Strip off any './' before a tilde, unless this is the beginning of - * the path. - */ - - if (length > 0 && strEltLen > 0 && (strElt[0] == '.') && - (strElt[1] == '/') && (strElt[2] == '~')) { - strElt += 2; - } -#endif /* TCL_TILDE_EXPAND */ - /* * A NULL value for fsPtr at this stage basically means we're trying * to join a relative path onto something which is also relative (or @@ -1250,8 +1226,10 @@ TclNewFSPathObj( const char *p; int state = 0, count = 0; -#ifdef TCL_TILDE_EXPAND - /* [Bug 2806250] - this is only a partial solution of the problem. + /* + * This comment is kept from the days of tilde expansion because + * it is illustrative of a more general problem. + * [Bug 2806250] - this is only a partial solution of the problem. * The PATHFLAGS != 0 representation assumes in many places that * the "tail" part stored in the normPathPtr field is itself a * relative path. Strings that begin with "~" are not relative paths, @@ -1267,14 +1245,6 @@ TclNewFSPathObj( * that by mounting on path prefixes like foo:// which cannot be the * name of a file or directory read from a native [glob] operation. */ - if (addStrRep[0] == '~') { - Tcl_Obj *tail = Tcl_NewStringObj(addStrRep, len); - - pathPtr = AppendPath(dirPtr, tail); - Tcl_DecrRefCount(tail); - return pathPtr; - } -#endif /* TCL_TILDE_EXPAND */ TclNewObj(pathPtr); fsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath)); @@ -2231,126 +2201,7 @@ SetFsPathFromAny( */ name = Tcl_GetStringFromObj(pathPtr, &len); - - /* - * Handle tilde substitutions, if needed. - */ - -#ifdef TCL_TILDE_EXPAND - if (len && name[0] == '~') { - Tcl_DString temp; - size_t split; - char separator = '/'; - - /* - * We have multiple cases '~/foo/bar...', '~user/foo/bar...', etc. - * split becomes value 1 for '~/...' as well as for '~'. - */ - split = FindSplitPos(name, separator); - - /* - * Do some tilde substitution. - */ - - if (split == 1) { - /* - * We have just '~' (or '~/...') - */ - - const char *dir; - Tcl_DString dirString; - - dir = TclGetEnv("HOME", &dirString); - if (dir == NULL) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "couldn't find HOME environment variable to" - " expand path", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", - "HOMELESS", NULL); - } - 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); - expandedUser = Tcl_DStringValue(&userName); - - Tcl_DStringInit(&temp); - if (TclpGetUserHome(expandedUser, &temp) == NULL) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "user \"%s\" doesn't exist", expandedUser)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER", - NULL); - } - Tcl_DStringFree(&userName); - Tcl_DStringFree(&temp); - return TCL_ERROR; - } - Tcl_DStringFree(&userName); - } - - transPtr = TclDStringToObj(&temp); - - if (split != len) { - /* - * Join up the tilde substitution with the rest. - */ - - if (name[split+1] == separator) { - /* - * Somewhat tricky case like ~//foo/bar. Make use of - * Split/Join machinery to get it right. Assumes all paths - * beginning with ~ are part of the native filesystem. - */ - - size_t objc; - Tcl_Obj **objv; - Tcl_Obj *parts = TclpNativeSplitPath(pathPtr, NULL); - - TclListObjGetElementsM(NULL, parts, &objc, &objv); - - /* - * Skip '~'. It's replaced by its expansion. - */ - - objc--; objv++; - while (objc--) { - TclpNativeJoinPath(transPtr, TclGetString(*objv)); - objv++; - } - TclDecrRefCount(parts); - } else { - Tcl_Obj *pair[2]; - - pair[0] = transPtr; - pair[1] = Tcl_NewStringObj(name+split+1, -1); - transPtr = TclJoinPath(2, pair, 1); - if (transPtr != pair[0]) { - Tcl_DecrRefCount(pair[0]); - } - if (transPtr != pair[1]) { - Tcl_DecrRefCount(pair[1]); - } - } - } - } else { - transPtr = TclJoinPath(1, &pathPtr, 1); - } -#else transPtr = TclJoinPath(1, &pathPtr, 1); -#endif /* TCL_TILDE_EXPAND */ /* * Now we have a translated filename in 'transPtr'. This will have forward diff --git a/library/safe.tcl b/library/safe.tcl index 09c82e5..c082c33 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -733,11 +733,6 @@ proc ::safe::CheckFileName {child file} { # prevent discovery of what home directories exist. proc ::safe::AliasFileSubcommand {child subcommand name} { - # TODO - if TIP602 is accepted for Tcl9, this check could be removed. - # The check is required if TCL_TILDE_EXPAND is defined. - if {[string match ~* $name]} { - set name ./$name - } tailcall ::interp invokehidden $child tcl:file:$subcommand $name } diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index cb74630..148caa0 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -863,8 +863,8 @@ TclpSetVariables( Tcl_SetVar2(interp, "tcl_pkgPath", NULL, pkgPath, TCL_GLOBAL_ONLY); } -#ifndef TCL_TILDE_EXPAND { + /* Some platforms build configure scripts expect ~ expansion so do that */ Tcl_Obj *origPaths; Tcl_Obj *resolvedPaths; origPaths = Tcl_GetVar2Ex(interp, "tcl_pkgPath", NULL, TCL_GLOBAL_ONLY); @@ -874,7 +874,6 @@ TclpSetVariables( resolvedPaths, TCL_GLOBAL_ONLY); } } -#endif #ifdef DJGPP Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY); diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 5f55354..e52874e 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -1715,22 +1715,7 @@ ConvertFileNameFormat( Tcl_WCharToUtfDString(nativeName, TCL_INDEX_NONE, &dsTemp); Tcl_DStringFree(&ds); - /* - * Deal with issues of tildes being absolute. - */ - -#ifdef TCL_TILDE_EXPAND - if (Tcl_DStringValue(&dsTemp)[0] == '~') { - TclNewLiteralStringObj(tempPath, "./"); - Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp), - Tcl_DStringLength(&dsTemp)); - Tcl_DStringFree(&dsTemp); - } else { - tempPath = TclDStringToObj(&dsTemp); - } -#else tempPath = TclDStringToObj(&dsTemp); -#endif /* TCL_TILDE_EXPAND */ Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath); FindClose(handle); } -- cgit v0.12 From dc113d8f285f5b53a9fa035527abe05704027ab4 Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 18 Aug 2022 20:16:05 +0000 Subject: TIP633 fconfigure -tolerantencoding: start command arguments --- generic/tclIO.c | 27 ++++++++++++++++++++++++++- generic/tclIO.h | 2 ++ 2 files changed, 28 insertions(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 5313eed..4e3e41c 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -7905,7 +7905,20 @@ Tcl_GetChannelOption( return TCL_OK; } } - if (len == 0 || HaveOpt(1, "-translation")) { + if (len == 0 || HaveOpt(2, "-tolerantencoding")) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-tolerantencoding"); + } + Tcl_DStringAppendElement(dsPtr, + (flags & CHANNEL_TOLERANT_ENCODING) ? "1" : "0"); + if (len > 0) { + return TCL_OK; + } + if (len > 0) { + return TCL_OK; + } + } + if (len == 0 || HaveOpt(2, "-translation")) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-translation"); } @@ -8158,6 +8171,18 @@ Tcl_SetChannelOption( ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_STICKY_EOF|CHANNEL_BLOCKED); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; return TCL_OK; + } else if (HaveOpt(2, "-tolerantencoding")) { + int newMode; + + if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { + return TCL_ERROR; + } + if (newMode) { + statePtr->flags |= CHANNEL_TOLERANT_ENCODING; + } else { + statePtr->flags &= ~CHANNEL_TOLERANT_ENCODING; + } + return TCL_OK; } else if (HaveOpt(1, "-translation")) { const char *readMode, *writeMode; diff --git a/generic/tclIO.h b/generic/tclIO.h index 54aa5af..1d63c0b 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -271,6 +271,8 @@ typedef struct ChannelState { * changes. */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ +#define CHANNEL_TOLERANT_ENCODING (1<<17) /* set if option -tolerantencoding + * is set to 1 */ #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. * Its structures are still live and -- cgit v0.12 From 9a1e8d3202a29dcc11dc8c54e01a02e1f6565fd1 Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 18 Aug 2022 20:20:10 +0000 Subject: Correct option shortcut value --- generic/tclIO.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 4e3e41c..6d9798e 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8183,7 +8183,7 @@ Tcl_SetChannelOption( statePtr->flags &= ~CHANNEL_TOLERANT_ENCODING; } return TCL_OK; - } else if (HaveOpt(1, "-translation")) { + } else if (HaveOpt(2, "-translation")) { const char *readMode, *writeMode; if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { -- cgit v0.12 From e52c7c3a41a6fb4a3deeade3447de39ee569f0fd Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 19 Aug 2022 16:52:07 +0000 Subject: Implement file tildeexpand --- generic/tclCmdAH.c | 3 +- generic/tclFCmd.c | 38 +++++++++++++++++++++++++ generic/tclInt.h | 5 ++-- generic/tclPathObj.c | 80 +++++++++++++++++++++++++++++----------------------- tests/fCmd.test | 79 +++++++++++++++++++++++++++++++++++++++++++++++++-- 5 files changed, 164 insertions(+), 41 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index eec3e0f..bf7a9cd 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -1045,7 +1045,7 @@ TclInitFileCmd( {"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"home", TclFileHomeCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"home", TclFileHomeCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, {"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"join", PathJoinCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, @@ -1069,6 +1069,7 @@ TclInitFileCmd( {"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"tempdir", TclFileTempDirCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, {"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 1}, + {"tildeexpand", TclFileTildeExpandCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, {"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index d7fa750..6bf34d8 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -1680,6 +1680,44 @@ TclFileHomeCmd( } /* + *---------------------------------------------------------------------- + * + * TclFileTildeExpandCmd -- + * + * This function is invoked to process the "file tildeexpand" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclFileTildeExpandCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *expandedPathObj; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "path"); + return TCL_ERROR; + } + expandedPathObj = TclResolveTildePath(interp, objv[1]); + if (expandedPathObj == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, expandedPathObj); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclInt.h b/generic/tclInt.h index 51f7e75..183838d 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2913,6 +2913,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileTempDirCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileHomeCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileTildeExpandCmd; MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc, void *clientData); MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc, @@ -3021,8 +3022,8 @@ MODULE_SCOPE int TclIsDigitProc(int byte); MODULE_SCOPE int TclIsBareword(int byte); MODULE_SCOPE Tcl_Obj * TclJoinPath(size_t elements, Tcl_Obj * const objv[], int forceRelative); -MODULE_SCOPE int TclGetHomeDir(Tcl_Interp *interp, const char *user, - Tcl_DString *dsPtr); +MODULE_SCOPE int MakeTildeRelativePath(Tcl_Interp *interp, const char *user, + const char *subPath, Tcl_DString *dsPtr); MODULE_SCOPE Tcl_Obj * TclGetHomeDirObj(Tcl_Interp *interp, const char *user); MODULE_SCOPE Tcl_Obj * TclResolveTildePath(Tcl_Interp *interp, Tcl_Obj *pathObj); diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 82b79f5..2fbeea3 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -2422,11 +2422,17 @@ TclNativePathInFilesystem( /* *---------------------------------------------------------------------- * - * TclGetHomeDir -- + * MakeTildeRelativePath -- * - * Returns the home directory of a user. Note there is a difference - * between not specifying a user and explicitly specifying the current - * user. This mimics Tcl8's tilde expansion. + * Returns a path relative to the home directory of a user. + * Note there is a difference between not specifying a user and + * explicitly specifying the current user. This mimics Tcl8's tilde + * expansion. + * + * The subPath argument is joined to the expanded home directory + * as in Tcl_JoinPath. This means if it is not relative, it will + * returned as the result with the home directory only checked + * for user name validity. * * Results: * Returns TCL_OK on success with home directory path in *dsPtr @@ -2435,22 +2441,23 @@ TclNativePathInFilesystem( *---------------------------------------------------------------------- */ int -TclGetHomeDir( - Tcl_Interp *interp, /* May be NULL. Only used for error messages */ - const char *user, /* User name. NULL -> current user */ - Tcl_DString *dsPtr) /* Output. Is initialized by the function. Must be +MakeTildeRelativePath( + Tcl_Interp *interp, /* May be NULL. Only used for error messages */ + const char *user, /* User name. NULL -> current user */ + const char *subPath, /* Rest of path. May be NULL */ + Tcl_DString *dsPtr) /* Output. Is initialized by the function. Must be freed on success */ { const char *dir; - Tcl_DString nativeString; + Tcl_DString dirString; Tcl_DStringInit(dsPtr); - Tcl_DStringInit(&nativeString); + Tcl_DStringInit(&dirString); if (user == NULL || user[0] == 0) { /* No user name specified -> current user */ - dir = TclGetEnv("HOME", &nativeString); + dir = TclGetEnv("HOME", &dirString); if (dir == NULL) { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -2463,7 +2470,7 @@ TclGetHomeDir( } } else { /* User name specified - ~user */ - dir = TclpGetUserHome(user, &nativeString); + dir = TclpGetUserHome(user, &dirString); if (dir == NULL) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2474,7 +2481,16 @@ TclGetHomeDir( return TCL_ERROR; } } - Tcl_JoinPath(1, &dir, dsPtr); + if (subPath) { + const char *parts[2]; + parts[0] = dir; + parts[1] = subPath; + Tcl_JoinPath(2, parts, dsPtr); + } else { + Tcl_JoinPath(1, &dir, dsPtr); + } + + Tcl_DStringFree(&dirString); return TCL_OK; } @@ -2484,7 +2500,7 @@ TclGetHomeDir( * * TclGetHomeDirObj -- * - * Wrapper around TclGetHomeDir. See that function. + * Wrapper around MakeTildeRelativePath. See that function. * * Results: * Returns a Tcl_Obj containing the home directory of a user @@ -2499,7 +2515,7 @@ TclGetHomeDirObj( { Tcl_DString dirString; - if (TclGetHomeDir(interp, user, &dirString) != TCL_OK) { + if (MakeTildeRelativePath(interp, user, NULL, &dirString) != TCL_OK) { return NULL; } return TclDStringToObj(&dirString); @@ -2515,12 +2531,6 @@ TclGetHomeDirObj( * component cannot be resolved, returns NULL. If the path does not * begin with a tilde, returns as is. * - * The trailing components of the path are returned verbatim. No - * processing is done on them. Moreover, no assumptions should be - * made about the separators in the returned path. They may be / - * or native. Appropriate path manipulations functions should be - * used by caller if desired. - * * Results: * Returns a Tcl_Obj with resolved path. This may be a new Tcl_Obj * with ref count 0 or that pathObj that was passed in without its @@ -2537,9 +2547,8 @@ TclResolveTildePath( { const char *path; size_t len; - Tcl_Obj *resolvedObj; - Tcl_DString dirString; size_t split; + Tcl_DString resolvedPath; path = Tcl_GetStringFromObj(pathObj, &len); if (path[0] != '~') { @@ -2556,12 +2565,13 @@ TclResolveTildePath( if (split == 1) { /* No user name specified -> current user */ - if (TclGetHomeDir(interp, NULL, &dirString) != TCL_OK) { + if (MakeTildeRelativePath( + interp, NULL, path[1] ? 2 + path : NULL, &resolvedPath) + != TCL_OK) { return NULL; } } else { /* User name specified - ~user */ - const char *expandedUser; Tcl_DString userName; @@ -2569,20 +2579,18 @@ TclResolveTildePath( Tcl_DStringAppend(&userName, path+1, split-1); expandedUser = Tcl_DStringValue(&userName); - if (TclGetHomeDir(interp, expandedUser, &dirString) != TCL_OK) { - Tcl_DStringFree(&userName); + /* path[split] is / or \0 */ + if (MakeTildeRelativePath(interp, + expandedUser, + path[split] ? &path[split+1] : NULL, + &resolvedPath) + != TCL_OK) { + Tcl_DStringFree(&userName); return NULL; } - Tcl_DStringFree(&userName); - } - resolvedObj = TclDStringToObj(&dirString); - - if (split < len) { - /* If any trailer, append it verbatim */ - Tcl_AppendToObj(resolvedObj, split + path, len-split); + Tcl_DStringFree(&userName); } - - return resolvedObj; + return TclDStringToObj(&resolvedPath); } /* diff --git a/tests/fCmd.test b/tests/fCmd.test index e9d7667..dbbc154 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -2699,13 +2699,88 @@ test fCmd-31.6 {file home USER} -body { # name, else not sure how to check file home $::tcl_platform(user) } -match glob -result "*$::tcl_platform(user)*" -test fCmd-31.6 {file home UNKNOWNUSER} -body { +test fCmd-31.7 {file home UNKNOWNUSER} -body { file home nosuchuser } -returnCodes error -result {user "nosuchuser" doesn't exist} -test fCmd-31.7 {file home extra arg} -body { +test fCmd-31.8 {file home extra arg} -body { file home $::tcl_platform(user) arg } -returnCodes error -result {wrong # args: should be "file home ?user?"} +test fCmd-32.1 {file tildeexpand ~} -body { + file tildeexpand ~ +} -result [file join $::env(HOME)] +test fCmd-32.2 {file tildeexpand ~ - obeys env} -setup { + set ::env(HOME) $::env(HOME)/xxx +} -cleanup { + set ::env(HOME) [file dirname $::env(HOME)] +} -body { + file tildeexpand ~ +} -result [file join $::env(HOME) xxx] +test fCmd-32.3 {file tildeexpand ~ - error} -setup { + set saved $::env(HOME) + unset ::env(HOME) +} -cleanup { + set ::env(HOME) $saved +} -body { + file tildeexpand ~ +} -returnCodes error -result {couldn't find HOME environment variable to expand path} +test fCmd-32.4 { + file tildeexpand ~ - relative path. Following 8.x ~ expansion behavior, relative + paths are not made absolute +} -setup { + set saved $::env(HOME) + set ::env(HOME) relative/path +} -cleanup { + set ::env(HOME) $saved +} -body { + file tildeexpand ~ +} -result relative/path +test fCmd-32.5 {file tildeexpand ~USER} -body { + # Note - as in 8.x this form does NOT necessarily give same result as + # env(HOME) even when user is current user. Assume result contains user + # name, else not sure how to check + file tildeexpand ~$::tcl_platform(user) +} -match glob -result "*$::tcl_platform(user)*" +test fCmd-32.6 {file tildeexpand ~UNKNOWNUSER} -body { + file tildeexpand ~nosuchuser +} -returnCodes error -result {user "nosuchuser" doesn't exist} +test fCmd-32.7 {file tildeexpand ~extra arg} -body { + file tildeexpand ~ arg +} -returnCodes error -result {wrong # args: should be "file tildeexpand path"} +test fCmd-32.8 {file tildeexpand ~/path} -body { + file tildeexpand ~/foo +} -result [file join $::env(HOME)/foo] +test fCmd-32.9 {file tildeexpand ~USER/bar} -body { + # Note - as in 8.x this form does NOT necessarily give same result as + # env(HOME) even when user is current user. Assume result contains user + # name, else not sure how to check + file tildeexpand ~$::tcl_platform(user)/bar +} -match glob -result "*$::tcl_platform(user)*/bar" +test fCmd-32.10 {file tildeexpand ~UNKNOWNUSER} -body { + file tildeexpand ~nosuchuser/foo +} -returnCodes error -result {user "nosuchuser" doesn't exist} +test fCmd-32.11 {file tildeexpand /~/path} -body { + file tildeexpand /~/foo +} -result /~/foo +test fCmd-32.12 {file tildeexpand /~user/path} -body { + file tildeexpand /~$::tcl_platform(user)/foo +} -result /~$::tcl_platform(user)/foo +test fCmd-32.13 {file tildeexpand ./~} -body { + file tildeexpand ./~ +} -result ./~ +test fCmd-32.14 {file tildeexpand relative/path} -body { + file tildeexpand relative/path +} -result relative/path +test fCmd-32.15 {file tildeexpand ~\\path} -body { + file tildeexpand ~\\foo +} -constraints win -result [file join $::env(HOME)/foo] +test fCmd-32.16 {file tildeexpand ~USER\\bar} -body { + # Note - as in 8.x this form does NOT necessarily give same result as + # env(HOME) even when user is current user. Assume result contains user + # name, else not sure how to check + file tildeexpand ~$::tcl_platform(user)\\bar +} -constraints win -match glob -result "*$::tcl_platform(user)*/bar" + # cleanup cleanup -- cgit v0.12 From de7a5967d0f8c2bf87801e4ee9d95355997df774 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 19 Aug 2022 17:02:47 +0000 Subject: Do tilde expansion when initializing from TCLLIBPATH and TM env vars --- library/init.tcl | 10 +++++++++- library/tm.tcl | 5 ++++- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/library/init.tcl b/library/init.tcl index 31139dd..d2e3624 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -47,7 +47,15 @@ package require -exact tcl 9.0a4 if {![info exists auto_path]} { if {[info exists env(TCLLIBPATH)] && (![interp issafe])} { - set auto_path $env(TCLLIBPATH) + set auto_path [apply {{} { + lmap path $::env(TCLLIBPATH) { + # Paths relative to unresolvable home dirs are ignored + if {[catch {file tildeexpand $path} expanded_path]} { + continue + } + set expanded_path + } + }}] } else { set auto_path "" } diff --git a/library/tm.tcl b/library/tm.tcl index c1a8f8a..88ce4af 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -338,7 +338,10 @@ proc ::tcl::tm::Defaults {} { ] { if {![info exists env($ev)]} continue foreach p [split $env($ev) $sep] { - path add $p + # Paths relative to unresolvable home dirs are ignored + if {![catch {file tildeexpand $p} expanded_path]} { + path add $expanded_path + } } } } -- cgit v0.12 From 6203b90b2add5d428b8e204ed930aad592d490c7 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 22 Aug 2022 04:24:08 +0000 Subject: Merge 8.7 winConsole fixes. --- win/tclWinConsole.c | 52 ++++++++++++++++++++++++++++++---------------------- 1 file changed, 30 insertions(+), 22 deletions(-) diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 6956135..6296f89 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -19,8 +19,8 @@ #include /* - * A general note on the design: The console channel driver differs from most - * other drivers in the following respects: + * A general note on the design: The console channel driver differs from + * most other drivers in the following respects: * * - There can be at most 3 console handles at any time since Windows does * support allocation of more than one console (with three handles @@ -35,9 +35,10 @@ * std* channels are shared amongst threads which means there can be * multiple Tcl channels corresponding to a single console handle. * - * - Even with multiple threads, more than one file event handler is unlikely. - * It does not make sense for multiple threads to register handlers for - * stdin because the input would be randomly fragmented amongst the threads. + * - Even with multiple threads, more than one file event handler is + * unlikely. It does not make sense for multiple threads to register + * handlers for stdin because the input would be randomly fragmented amongst + * the threads. * * Various design factors are driven by the above, e.g. use of lists instead * of hash tables (at most 3 console handles) and use of global instead of @@ -55,9 +56,9 @@ * because an interpreter may (for example) turn off echo for passwords and * the read ahead would come in the way of that. * - * If multiple threads are reading from stdin, the input is sprayed in random - * fashion. This is not good application design and hence no plan to address - * this (not clear what should be done even in theory) + * If multiple threads are reading from stdin, the input is sprayed in + * random fashion. This is not good application design and hence no plan to + * address this (not clear what should be done even in theory) * * For output, we do not restrict all output to the console writer threads. * See ConsoleOutputProc for the conditions. @@ -152,7 +153,7 @@ typedef struct ConsoleHandleInfo { * only from the thread owning channel EXCEPT when a console traverses it * looking for a channel that is watching for events on the console. Even * in that case, no locking is required because that access is only under - * the consoleLock lock which prevents the channel from being removed from + * the gConsoleLock lock which prevents the channel from being removed from * the gWatchingChannelList which in turn means it will not be deallocated * from under the console thread. Access to individual fields does not need * to be controlled because @@ -1115,12 +1116,6 @@ ConsoleInputProc( * buffered data, we will pass it up. */ if (numRead != 0) { - /* If console thread was blocked, awaken it */ - if (chanInfoPtr->flags & CONSOLE_ASYNC) { - /* Async channels always want read ahead */ - handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; - WakeConditionVariable(&handleInfoPtr->consoleThreadCV); - } break; } /* @@ -1211,7 +1206,9 @@ ConsoleInputProc( /* Lock is reacquired, loop back to try again */ } - if (chanInfoPtr->flags & CONSOLE_ASYNC) { + /* We read data. Ask for more if either async or watching for reads */ + if ((chanInfoPtr->flags & CONSOLE_ASYNC) + || (chanInfoPtr->watchMask & TCL_READABLE)) { handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; WakeConditionVariable(&handleInfoPtr->consoleThreadCV); } @@ -1345,7 +1342,7 @@ ConsoleOutputProc( } } - /* Lock is reacquired. Continue loop */ + /* Lock must have been reacquired before continuing loop */ } WakeConditionVariable(&handleInfoPtr->consoleThreadCV); ReleaseSRWLockExclusive(&handleInfoPtr->lock); @@ -1511,8 +1508,10 @@ ConsoleWatchProc( ConsoleHandleInfo *handleInfoPtr; handleInfoPtr = FindConsoleInfo(chanInfoPtr); if (handleInfoPtr) { + AcquireSRWLockExclusive(&handleInfoPtr->lock); handleInfoPtr->flags |= CONSOLE_DATA_AWAITED; WakeConditionVariable(&handleInfoPtr->consoleThreadCV); + ReleaseSRWLockExclusive(&handleInfoPtr->lock); } ReleaseSRWLockExclusive(&gConsoleLock); } @@ -1520,6 +1519,7 @@ ConsoleWatchProc( } else if (oldMask) { /* Remove from list of watched channels */ + AcquireSRWLockExclusive(&gConsoleLock); for (nextPtrPtr = &gWatchingChannelList, ptr = *nextPtrPtr; ptr != NULL; nextPtrPtr = &ptr->nextWatchingChannelPtr, ptr = *nextPtrPtr) { @@ -1528,6 +1528,7 @@ ConsoleWatchProc( break; } } + ReleaseSRWLockExclusive(&gConsoleLock); } } @@ -1583,7 +1584,7 @@ ConsoleGetHandleProc( static int ConsoleDataAvailable (HANDLE consoleHandle) { - INPUT_RECORD input[5]; + INPUT_RECORD input[10]; DWORD count; DWORD i; @@ -1595,11 +1596,17 @@ ConsoleGetHandleProc( == FALSE) { return -1; } + /* + * Even if windows size and mouse events are disabled, can still have + * events other than keyboard, like focus events. Look for at least one + * keydown event because a trailing LF keyup is always present from the + * last input. However, if our buffer is full, assume there is a key + * down somewhere in the unread buffer. I suppose we could expand the + * buffer but not worth... + */ + if (count == (sizeof(input)/sizeof(input[0]))) + return 1; for (i = 0; i < count; ++i) { - /* - * Event must be a keydown because a trailing LF keyup event is always - * present for line based input. - */ if (input[i].EventType == KEY_EVENT && input[i].Event.KeyEvent.bKeyDown) { return 1; @@ -1996,6 +2003,7 @@ AllocateConsoleHandleInfo( handleInfoPtr = (ConsoleHandleInfo *)Tcl_Alloc(sizeof(*handleInfoPtr)); + memset(handleInfoPtr, 0, sizeof(*handleInfoPtr)); handleInfoPtr->console = consoleHandle; InitializeSRWLock(&handleInfoPtr->lock); InitializeConditionVariable(&handleInfoPtr->consoleThreadCV); -- cgit v0.12 From 529ef6feb2f0e3db14385328bb4f7a84cbef375d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 23 Aug 2022 07:03:31 +0000 Subject: Fix [d052d2a1b01ba2c8]: avoid leak in TestsetbytearraylengthObjCmd() --- generic/tclTest.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index ac0c210..919e020 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -5130,7 +5130,10 @@ TestsetbytearraylengthObjCmd( obj = objv[1]; } if (NULL == Tcl_SetByteArrayLength(obj, n)) { - Tcl_SetResult(interp, "expected bytes", TCL_STATIC); + if (Tcl_IsShared(objv[1])) { + Tcl_DecrRefCount(obj); + } + Tcl_AppendResult(interp, "expected bytes", NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, obj); -- cgit v0.12 From 29dd9092810a129dfa04b7f9b3f150e91ab12e98 Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 23 Aug 2022 10:22:25 +0000 Subject: small amend to [d052d2a1b01ba2c8], code review --- generic/tclTest.c | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 919e020..eb6b589 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -5124,13 +5124,12 @@ TestsetbytearraylengthObjCmd( if (TCL_OK != Tcl_GetIntFromObj(interp, objv[2], &n)) { return TCL_ERROR; } - if (Tcl_IsShared(objv[1])) { - obj = Tcl_DuplicateObj(objv[1]); - } else { - obj = objv[1]; + obj = objv[1]; + if (Tcl_IsShared(obj)) { + obj = Tcl_DuplicateObj(obj); } - if (NULL == Tcl_SetByteArrayLength(obj, n)) { - if (Tcl_IsShared(objv[1])) { + if (Tcl_SetByteArrayLength(obj, n) == NULL) { + if (obj != objv[1]) { Tcl_DecrRefCount(obj); } Tcl_AppendResult(interp, "expected bytes", NULL); -- cgit v0.12 From abe4d4223da114bb82cca35dc22618f25847668f Mon Sep 17 00:00:00 2001 From: bch Date: Tue, 23 Aug 2022 20:29:58 +0000 Subject: fix(?) stray ckalloc()/ckfree(); ref TIP 494. --- generic/tclBasic.c | 10 +++++----- generic/tclTrace.c | 4 ++-- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 77756a4..eb3889d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -2652,7 +2652,7 @@ static void cmdWrapperDeleteProc(void *clientData) { clientData = info->clientData; Tcl_CmdDeleteProc *deleteProc = info->deleteProc; - ckfree(info); + Tcl_Free(info); if (deleteProc != NULL) { deleteProc(clientData); } @@ -2675,7 +2675,7 @@ Tcl_CreateObjCommand2( * this command is deleted. */ ) { - CmdWrapperInfo *info = (CmdWrapperInfo *)ckalloc(sizeof(CmdWrapperInfo)); + CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo)); info->proc = proc; info->deleteProc = deleteProc; info->clientData = clientData; @@ -8410,7 +8410,7 @@ int wrapperNRObjProc( CmdWrapperInfo *info = (CmdWrapperInfo *)clientData; clientData = info->clientData; Tcl_ObjCmdProc2 *proc = info->proc; - ckfree(info); + Tcl_Free(info); return proc(clientData, interp, objc, objv); } @@ -8423,7 +8423,7 @@ Tcl_NRCallObjProc2( Tcl_Obj *const objv[]) { NRE_callback *rootPtr = TOP_CB(interp); - CmdWrapperInfo *info = (CmdWrapperInfo *)ckalloc(sizeof(CmdWrapperInfo)); + CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo)); info->clientData = clientData; info->proc = objProc; @@ -8489,7 +8489,7 @@ Tcl_NRCreateCommand2( /* If not NULL, gives a function to call when * this command is deleted. */ { - CmdWrapperInfo *info = (CmdWrapperInfo *)ckalloc(sizeof(CmdWrapperInfo)); + CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo)); info->proc = proc; info->nreProc = nreProc; info->deleteProc = deleteProc; diff --git a/generic/tclTrace.c b/generic/tclTrace.c index c837e92..f830a77 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -2152,7 +2152,7 @@ static void traceWrapperDelProc(void *clientData) if (info->delProc) { info->delProc(clientData); } - ckfree(info); + Tcl_Free(info); } Tcl_Trace @@ -2165,7 +2165,7 @@ Tcl_CreateObjTrace2( Tcl_CmdObjTraceDeleteProc *delProc) /* Function to call when trace is deleted */ { - TraceWrapperInfo *info = (TraceWrapperInfo *)ckalloc(sizeof(TraceWrapperInfo)); + TraceWrapperInfo *info = (TraceWrapperInfo *)Tcl_Alloc(sizeof(TraceWrapperInfo)); info->proc = proc; info->delProc = delProc; info->clientData = clientData; -- cgit v0.12 From 2d455c75b957f96586b3ca1d1b83b4b9a3283c55 Mon Sep 17 00:00:00 2001 From: sbron Date: Wed, 24 Aug 2022 11:18:28 +0000 Subject: Start TIP #634 implementation using modified patch from ticket #2969488 by ferrieux. --- doc/upvar.n | 6 ------ generic/tclInt.h | 40 +++++++++++++++++++++++++++++----------- generic/tclVar.c | 9 +++++++++ 3 files changed, 38 insertions(+), 17 deletions(-) diff --git a/doc/upvar.n b/doc/upvar.n index 91defe6..6ad1237 100644 --- a/doc/upvar.n +++ b/doc/upvar.n @@ -97,12 +97,6 @@ set originalVar 1 trace variable originalVar w \fItraceproc\fR \fIsetByUpvar\fR originalVar 2 .CE -.PP -If \fIotherVar\fR refers to an element of an array, then variable -traces set for the entire array will not be invoked when \fImyVar\fR -is accessed (but traces on the particular element will still be -invoked). In particular, if the array is \fBenv\fR, then changes -made to \fImyVar\fR will not be passed to subprocesses correctly. .SH EXAMPLE A \fBdecr\fR command that works like \fBincr\fR except it subtracts the value from the variable instead of adding it: diff --git a/generic/tclInt.h b/generic/tclInt.h index 527572e..f5b25dc 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -215,15 +215,16 @@ typedef struct Tcl_Ensemble Tcl_Ensemble; typedef struct NamespacePathEntry NamespacePathEntry; /* - * Special hashtable for variables: this is just a Tcl_HashTable with an nsPtr - * field added at the end: in this way variables can find their namespace - * without having to copy a pointer in their struct: they can access it via - * their hPtr->tablePtr. + * Special hashtable for variables: this is just a Tcl_HashTable with nsPtr + * and arrayPtr fields added at the end: in this way variables can find their + * namespace and possibly containing array without having to copy a pointer in + * their struct: they can access them via their hPtr->tablePtr. */ typedef struct TclVarHashTable { Tcl_HashTable table; struct Namespace *nsPtr; + struct Var *arrayPtr; } TclVarHashTable; /* @@ -813,6 +814,14 @@ typedef struct VarInHash { * MODULE_SCOPE int TclIsVarResolved(Var *varPtr); */ +#define TclVarFindHiddenArray(varPtr,arrayPtr) \ + do { \ + if ((arrayPtr == NULL) && TclIsVarInHash(varPtr) && \ + (TclVarParentArray(varPtr) != NULL)) { \ + arrayPtr = TclVarParentArray(varPtr); \ + } \ + } while(0) + #define TclIsVarScalar(varPtr) \ !((varPtr)->flags & (VAR_ARRAY|VAR_LINK)) @@ -857,6 +866,9 @@ typedef struct VarInHash { ? ((TclVarHashTable *) ((((VarInHash *) (varPtr))->entry.tablePtr)))->nsPtr \ : NULL) +#define TclVarParentArray(varPtr) \ + ((TclVarHashTable *) ((VarInHash *) (varPtr))->entry.tablePtr)->arrayPtr + #define VarHashRefCount(varPtr) \ ((VarInHash *) (varPtr))->refCount @@ -864,19 +876,25 @@ typedef struct VarInHash { * Macros for direct variable access by TEBC. */ -#define TclIsVarDirectReadable(varPtr) \ - ( !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ)) \ - && (varPtr)->value.objPtr) +#define TclIsVarTricky(varPtr,trickyFlags) \ + ( ((varPtr)->flags & (VAR_ARRAY|VAR_LINK|trickyFlags)) \ + || (TclIsVarInHash(varPtr) \ + && (TclVarParentArray(varPtr) != NULL) \ + && (TclVarParentArray(varPtr)->flags & (trickyFlags)))) + +#define TclIsVarDirectReadable(varPtr) \ + ( (!TclIsVarTricky(varPtr,VAR_TRACED_READ)) \ + && (varPtr)->value.objPtr) #define TclIsVarDirectWritable(varPtr) \ - !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_WRITE|VAR_DEAD_HASH)) + (!TclIsVarTricky(varPtr,VAR_TRACED_WRITE|VAR_DEAD_HASH)) #define TclIsVarDirectUnsettable(varPtr) \ - !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_UNSET|VAR_DEAD_HASH)) + (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_UNSET|VAR_DEAD_HASH)) #define TclIsVarDirectModifyable(varPtr) \ - ( !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ|VAR_TRACED_WRITE)) \ - && (varPtr)->value.objPtr) + ( (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE)) \ + && (varPtr)->value.objPtr) #define TclIsVarDirectReadable2(varPtr, arrayPtr) \ (TclIsVarDirectReadable(varPtr) &&\ diff --git a/generic/tclVar.c b/generic/tclVar.c index e0f46e7..c88144f 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -998,6 +998,7 @@ TclLookupSimpleVar( if (tablePtr == NULL) { tablePtr = (TclVarHashTable *)Tcl_Alloc(sizeof(TclVarHashTable)); TclInitVarHashTable(tablePtr, NULL); + tablePtr->arrayPtr = varPtr; varFramePtr->varTablePtr = tablePtr; } varPtr = VarHashCreateVar(tablePtr, varNamePtr, &isNew); @@ -1390,6 +1391,8 @@ TclPtrGetVarIdx( Interp *iPtr = (Interp *) interp; const char *msg; + TclVarFindHiddenArray(varPtr, arrayPtr); + /* * Invoke any read traces that have been set for the variable. */ @@ -1952,6 +1955,8 @@ TclPtrSetVarIdx( goto earlyError; } + TclVarFindHiddenArray(varPtr, arrayPtr); + /* * Invoke any read traces that have been set for the variable if it is * requested. This was done for INST_LAPPEND_* but that was inconsistent @@ -2454,6 +2459,8 @@ TclPtrUnsetVarIdx( VarHashRefCount(varPtr)++; } + TclVarFindHiddenArray(varPtr, arrayPtr); + UnsetVarStruct(varPtr, arrayPtr, iPtr, part1Ptr, part2Ptr, flags, index); /* @@ -6340,6 +6347,7 @@ TclInitVarHashTable( Tcl_InitCustomHashTable(&tablePtr->table, TCL_CUSTOM_TYPE_KEYS, &tclVarHashKeyType); tablePtr->nsPtr = nsPtr; + tablePtr->arrayPtr = NULL; } static Tcl_HashEntry * @@ -6594,6 +6602,7 @@ TclInitArrayVar( arrayPtr->value.tablePtr = (TclVarHashTable *) tablePtr; TclInitVarHashTable(arrayPtr->value.tablePtr, TclGetVarNsPtr(arrayPtr)); + arrayPtr->value.tablePtr->arrayPtr = arrayPtr; /* * Default value initialization. -- cgit v0.12 From 42dd6088a6a1dd034174d0f9ec84f2f22c9a6e4d Mon Sep 17 00:00:00 2001 From: sbron Date: Wed, 24 Aug 2022 11:19:14 +0000 Subject: Add tests for the TIP #634 functionality. --- tests/upvar.test | 45 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) diff --git a/tests/upvar.test b/tests/upvar.test index c31eaa1..268bb17 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -207,6 +207,51 @@ test upvar-5.3 {traces involving upvars} { p1 foo bar set x } {{x1 {} u} x1} +test upvar-5.4 {read trace on upvar array element} -body { + proc p1 {a b} { + array set foo {c 22 d 33} + trace add variable foo {read write unset} tproc + p2 + trace remove variable foo {read write unset} tproc + } + proc p2 {} { + upvar foo(c) x1 + set x1 + } + set x --- + p1 foo bar + set x +} -result {{x1 {} read} x1} +test upvar-5.5 {write trace on upvar array element} -body { + proc p1 {a b} { + array set foo {c 22 d 33} + trace add variable foo {read write unset} tproc + p2 + trace remove variable foo {read write unset} tproc + } + proc p2 {} { + upvar foo(c) x1 + set x1 22 + } + set x --- + p1 foo bar + set x +} -result {{x1 {} write} x1} +test upvar-5.6 {unset trace on upvar array element} -body { + proc p1 {a b} { + array set foo {c 22 d 33} + trace add variable foo {read write unset} tproc + p2 + trace remove variable foo {read write unset} tproc + } + proc p2 {} { + upvar foo(c) x1 + unset x1 + } + set x --- + p1 foo bar + set x +} -result {{x1 {} unset} x1} test upvar-6.1 {retargeting an upvar} { proc p1 {} { -- cgit v0.12 From 10cc2ae8fdb18bd0408ff5d1a440cea2e85e55c4 Mon Sep 17 00:00:00 2001 From: sbron Date: Wed, 24 Aug 2022 11:28:19 +0000 Subject: Fix error message, so trace tests 16.2, 16.9, and 16.16 pass again. --- generic/tclInt.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index f5b25dc..7599f8f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -816,8 +816,8 @@ typedef struct VarInHash { #define TclVarFindHiddenArray(varPtr,arrayPtr) \ do { \ - if ((arrayPtr == NULL) && TclIsVarInHash(varPtr) && \ - (TclVarParentArray(varPtr) != NULL)) { \ + if (!arrayPtr && !TclIsVarUndefined(varPtr) && \ + TclIsVarInHash(varPtr) && TclVarParentArray(varPtr)) { \ arrayPtr = TclVarParentArray(varPtr); \ } \ } while(0) -- cgit v0.12 From 66ebfaa06df00e3e2870e724a9e7adcb30d0a417 Mon Sep 17 00:00:00 2001 From: sbron Date: Wed, 24 Aug 2022 11:53:24 +0000 Subject: Fix env array access through upvar to a single element. --- generic/tclEnv.c | 23 +++++++++++++++++++++-- tests/env.test | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 53 insertions(+), 2 deletions(-) diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 73a8b84..2c6f8e3 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -60,6 +60,10 @@ static struct { #define tNTL sizeof(techar) +/* Copied from tclVar.c - should possibly be moved to tclInt.h */ +#define VarHashGetKey(varPtr) \ + (((VarInHash *)(varPtr))->entry.key.objPtr) + /* * Declarations for local functions defined in this file: */ @@ -644,11 +648,26 @@ EnvTraceProc( } /* - * If name2 is NULL, then return and do nothing. + * When an env array element is accessed via an upvar reference, there + * are two possibilities: + * 1. The upvar references the complete array. In this case name1 may be + * something else than "env", but that doesn't affect anything. name2 + * will still be the correct name for the enviroment variable to use. + * 2. The upvar references a single element of the array. In this case + * name2 will be NULL and name1 is the name of the alias. This alias + * must be resolved to the actual key of the array element. */ if (name2 == NULL) { - return NULL; + Var *varPtr, *arrayPtr; + Tcl_Obj *name; + + name = Tcl_NewStringObj(name1, -1); + Tcl_IncrRefCount(name); + varPtr = TclObjLookupVarEx(interp, name, NULL, /*flags*/ 0, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + Tcl_DecrRefCount(name); + name2 = Tcl_GetString(VarHashGetKey(varPtr)); } /* diff --git a/tests/env.test b/tests/env.test index 9eacd5d..30d8319 100644 --- a/tests/env.test +++ b/tests/env.test @@ -411,6 +411,38 @@ test env-7.3 { return [info exists ::env(test7_3)] }} } -cleanup cleanup1 -result 1 + +test env-7.4 { + get env variable through upvar +} -setup setup1 -body { + apply {{} { + set ::env(test7_4) origvalue + upvar #0 env(test7_4) var + return $var + }} +} -cleanup cleanup1 -result origvalue + +test env-7.5 { + set env variable through upvar +} -setup setup1 -body { + apply {{} { + set ::env(test7_4) origvalue + upvar #0 env(test7_4) var + set var newvalue + return $::env(test7_4) + }} +} -cleanup cleanup1 -result newvalue + +test env-7.6 { + unset env variable through upvar +} -setup setup1 -body { + apply {{} { + set ::env(test7_4) origvalue + upvar #0 env(test7_4) var + unset var + return [array get env test7_4] + }} +} -cleanup cleanup1 -result {} test env-8.0 { memory usage - valgrind does not report reachable memory -- cgit v0.12 From 8b4623feb42e145800da55276ee6987cc2f892d9 Mon Sep 17 00:00:00 2001 From: sbron Date: Wed, 24 Aug 2022 12:03:08 +0000 Subject: Use whitespace consistent with the surrounding code. --- generic/tclEnv.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 2c6f8e3..98d871a 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -663,10 +663,10 @@ EnvTraceProc( Tcl_Obj *name; name = Tcl_NewStringObj(name1, -1); - Tcl_IncrRefCount(name); + Tcl_IncrRefCount(name); varPtr = TclObjLookupVarEx(interp, name, NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - Tcl_DecrRefCount(name); + Tcl_DecrRefCount(name); name2 = Tcl_GetString(VarHashGetKey(varPtr)); } -- cgit v0.12 From 688186d7268b10d38b7e93cfa719208ebc1f96b2 Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 25 Aug 2022 20:07:29 +0000 Subject: TIP633 fconfigure -tolerantencoding: set tolerant 8.7 default value. --- generic/tclIO.c | 14 +++++++++++--- generic/tclIO.h | 2 +- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 6d9798e..cf96559 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -1703,6 +1703,14 @@ Tcl_CreateChannel( statePtr->outputEncodingFlags = TCL_ENCODING_START; /* + * Set encoding tolerant mode as default on 8.7.x and off on TCL9.x + */ + + #if TCL_MAJOR_VERSION < 9 + statePtr->flags |= CHANNEL_ENCODING_NOCOMPLAIN; + #endif + + /* * Set the channel up initially in AUTO input translation mode to accept * "\n", "\r" and "\r\n". Output translation mode is set to a platform * specific default value. The eofChar is set to 0 for both input and @@ -7910,7 +7918,7 @@ Tcl_GetChannelOption( Tcl_DStringAppendElement(dsPtr, "-tolerantencoding"); } Tcl_DStringAppendElement(dsPtr, - (flags & CHANNEL_TOLERANT_ENCODING) ? "1" : "0"); + (flags & CHANNEL_ENCODING_NOCOMPLAIN) ? "1" : "0"); if (len > 0) { return TCL_OK; } @@ -8178,9 +8186,9 @@ Tcl_SetChannelOption( return TCL_ERROR; } if (newMode) { - statePtr->flags |= CHANNEL_TOLERANT_ENCODING; + statePtr->flags |= CHANNEL_ENCODING_NOCOMPLAIN; } else { - statePtr->flags &= ~CHANNEL_TOLERANT_ENCODING; + statePtr->flags &= ~CHANNEL_ENCODING_NOCOMPLAIN; } return TCL_OK; } else if (HaveOpt(2, "-translation")) { diff --git a/generic/tclIO.h b/generic/tclIO.h index 1d63c0b..58e0c0f 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -271,7 +271,7 @@ typedef struct ChannelState { * changes. */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ -#define CHANNEL_TOLERANT_ENCODING (1<<17) /* set if option -tolerantencoding +#define CHANNEL_ENCODING_NOCOMPLAIN (1<<17) /* set if option -tolerantencoding * is set to 1 */ #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. -- cgit v0.12 From 2f0f646a076e6e374ff7a125957de91202178e07 Mon Sep 17 00:00:00 2001 From: bch Date: Fri, 26 Aug 2022 17:19:02 +0000 Subject: Tcl_GetVersion(3) - we just use int for components now, not Tcl_ReleaseType; Cleanup stray tag. --- doc/GetVersion.3 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/doc/GetVersion.3 b/doc/GetVersion.3 index 3672382..b973044 100644 --- a/doc/GetVersion.3 +++ b/doc/GetVersion.3 @@ -15,14 +15,13 @@ Tcl_GetVersion \- get the version of the library at runtime .sp \fBTcl_GetVersion\fR(\fImajor, minor, patchLevel, type\fR) .SH ARGUMENTS -.AS Tcl_ReleaseType *patchLevel out .AP int *major out Major version number of the Tcl library. .AP int *minor out Minor version number of the Tcl library. .AP int *patchLevel out The patch level of the Tcl library (or alpha or beta number). -.AP Tcl_ReleaseType *type out +.AP int *type out The type of release, also indicates the type of patch level. Can be one of \fBTCL_ALPHA_RELEASE\fR, \fBTCL_BETA_RELEASE\fR, or \fBTCL_FINAL_RELEASE\fR. -- cgit v0.12 From 18da054782020f70383cf5764a17be7cf3b0b457 Mon Sep 17 00:00:00 2001 From: sbron Date: Sat, 27 Aug 2022 08:14:31 +0000 Subject: Alternative fix for the error messages by chw, which doesn't break traces on non-existing array elements. --- generic/tclInt.h | 4 ++-- generic/tclVar.c | 8 +++++--- tests/env.test | 18 ++++++++++++++++++ tests/upvar.test | 16 ++++++++++++++++ 4 files changed, 41 insertions(+), 5 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 7599f8f..f5b25dc 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -816,8 +816,8 @@ typedef struct VarInHash { #define TclVarFindHiddenArray(varPtr,arrayPtr) \ do { \ - if (!arrayPtr && !TclIsVarUndefined(varPtr) && \ - TclIsVarInHash(varPtr) && TclVarParentArray(varPtr)) { \ + if ((arrayPtr == NULL) && TclIsVarInHash(varPtr) && \ + (TclVarParentArray(varPtr) != NULL)) { \ arrayPtr = TclVarParentArray(varPtr); \ } \ } while(0) diff --git a/generic/tclVar.c b/generic/tclVar.c index c88144f..b38575b 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -1390,6 +1390,7 @@ TclPtrGetVarIdx( { Interp *iPtr = (Interp *) interp; const char *msg; + Var *initialArrayPtr = arrayPtr; TclVarFindHiddenArray(varPtr, arrayPtr); @@ -1438,8 +1439,8 @@ TclPtrGetVarIdx( } if (flags & TCL_LEAVE_ERR_MSG) { - if (TclIsVarUndefined(varPtr) && arrayPtr - && !TclIsVarUndefined(arrayPtr)) { + if (TclIsVarUndefined(varPtr) && initialArrayPtr + && !TclIsVarUndefined(initialArrayPtr)) { msg = NOSUCHELEMENT; } else if (TclIsVarArray(varPtr)) { msg = ISARRAY; @@ -2447,6 +2448,7 @@ TclPtrUnsetVarIdx( { Interp *iPtr = (Interp *) interp; int result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK); + Var *initialArrayPtr = arrayPtr; /* * Keep the variable alive until we're done with it. We used to @@ -2470,7 +2472,7 @@ TclPtrUnsetVarIdx( if (result != TCL_OK) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset", - ((arrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index); + ((initialArrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index); Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", NULL); } } diff --git a/tests/env.test b/tests/env.test index 30d8319..fb8e22f 100644 --- a/tests/env.test +++ b/tests/env.test @@ -443,6 +443,24 @@ test env-7.6 { return [array get env test7_4] }} } -cleanup cleanup1 -result {} + +test env-7.7 { + create new (unset) env variable through upvar +} -setup setup1 -body { + apply {{} { + unset -nocomplain ::env(test7_7) + upvar #0 env(test7_7) var + interp create interp1 + set var newvalue + set result [interp1 eval {info exists ::env(test7_7)}] + if {$result} { + lappend result [interp1 eval {set ::env(test7_7)}] + } + interp delete interp1 + return $result + }} +} -cleanup cleanup1 -result {1 newvalue} + test env-8.0 { memory usage - valgrind does not report reachable memory diff --git a/tests/upvar.test b/tests/upvar.test index 268bb17..3682521 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -252,6 +252,22 @@ test upvar-5.6 {unset trace on upvar array element} -body { p1 foo bar set x } -result {{x1 {} unset} x1} +test upvar-5.7 {trace on non-existent upvar array element} -body { + proc p1 {a b} { + array set foo {} + trace add variable foo {read write unset} tproc + p2 + trace remove variable foo {read write unset} tproc + return [array get foo] + } + proc p2 {} { + upvar foo(hi) x1 + set x1 there + } + set x --- + lappend x [p1 foo bar] + set x +} -result {{x1 {} write} x1 {hi there}} test upvar-6.1 {retargeting an upvar} { proc p1 {} { -- cgit v0.12 From b437bfcd3ae2b4aeb6042d31504dae44fcd3c371 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 31 Aug 2022 09:12:57 +0000 Subject: Since numAfterRangeEnd (of type size_t) is always >= 0, those LIST_ASSERT's are useless --- generic/tclListObj.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/generic/tclListObj.c b/generic/tclListObj.c index be1c02c..200ea5a 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1488,7 +1488,6 @@ ListRepRange( ListRepElements(srcRepPtr, numSrcElems, srcElems); numAfterRangeEnd = numSrcElems - (rangeEnd + 1); /* Assert: Because numSrcElems > rangeEnd earlier */ - LIST_ASSERT(numAfterRangeEnd >= 0); if (numAfterRangeEnd != 0) { /* T:listrep-1.{8,9} */ ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd); @@ -1561,7 +1560,6 @@ ListRepRange( /* Ditto for trailing */ numAfterRangeEnd = numSrcElems - (rangeEnd + 1); /* Assert: Because numSrcElems > rangeEnd earlier */ - LIST_ASSERT(numAfterRangeEnd >= 0); if (numAfterRangeEnd != 0) { /* T:listrep-3.17 */ ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd); -- cgit v0.12 From abf853d0bba19a6b5d8271bda9049f20c1c85bf5 Mon Sep 17 00:00:00 2001 From: sbron Date: Wed, 31 Aug 2022 11:06:38 +0000 Subject: Implement modification of the 'name2' trace callback argument. --- doc/trace.n | 20 ++++++++++---------- doc/upvar.n | 4 ++++ generic/tclEnv.c | 23 ++--------------------- generic/tclInt.h | 3 +++ generic/tclTrace.c | 23 +++++++++++++++++++---- generic/tclVar.c | 19 +++++++++++++++---- tests/upvar.test | 8 ++++---- 7 files changed, 57 insertions(+), 43 deletions(-) diff --git a/doc/trace.n b/doc/trace.n index 570b263..959acc2 100644 --- a/doc/trace.n +++ b/doc/trace.n @@ -229,18 +229,18 @@ When the trace triggers, three arguments are appended to \fIcommandPrefix name1 name2 op\fR .CE .PP -\fIName1\fR and \fIname2\fR give the name(s) for the variable -being accessed: if the variable is a scalar then \fIname1\fR -gives the variable's name and \fIname2\fR is an empty string; -if the variable is an array element then \fIname1\fR gives the -name of the array and name2 gives the index into the array; -if an entire array is being deleted and the trace was registered +\fIName1\fR gives the name for the variable being accessed. +This is not necessarily the same as the name used in the +\fBtrace variable\fR command: the \fBupvar\fR command allows a +procedure to reference a variable under a different name. +If the trace was originally set on an array or array element, +\fIname2\fR provides which index into the array was affected. +This information is present even when \fIname1\fR refers to a +scalar, which may happen if the \fBupvar\fR command was used to +create a reference to a single array element. +If an entire array is being deleted and the trace was registered on the overall array, rather than a single element, then \fIname1\fR gives the array name and \fIname2\fR is an empty string. -\fIName1\fR and \fIname2\fR are not necessarily the same as the -name used in the \fBtrace variable\fR command: the \fBupvar\fR -command allows a procedure to reference a variable under a -different name. \fIOp\fR indicates what operation is being performed on the variable, and is one of \fBread\fR, \fBwrite\fR, or \fBunset\fR as defined above. diff --git a/doc/upvar.n b/doc/upvar.n index 6ad1237..b0324b2 100644 --- a/doc/upvar.n +++ b/doc/upvar.n @@ -97,6 +97,10 @@ set originalVar 1 trace variable originalVar w \fItraceproc\fR \fIsetByUpvar\fR originalVar 2 .CE +.PP +If \fIotherVar\fR refers to an element of an array, then the element +name is passed as the second argument to the trace procedure. This +may be important information in case of traces set on an entire array. .SH EXAMPLE A \fBdecr\fR command that works like \fBincr\fR except it subtracts the value from the variable instead of adding it: diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 98d871a..73a8b84 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -60,10 +60,6 @@ static struct { #define tNTL sizeof(techar) -/* Copied from tclVar.c - should possibly be moved to tclInt.h */ -#define VarHashGetKey(varPtr) \ - (((VarInHash *)(varPtr))->entry.key.objPtr) - /* * Declarations for local functions defined in this file: */ @@ -648,26 +644,11 @@ EnvTraceProc( } /* - * When an env array element is accessed via an upvar reference, there - * are two possibilities: - * 1. The upvar references the complete array. In this case name1 may be - * something else than "env", but that doesn't affect anything. name2 - * will still be the correct name for the enviroment variable to use. - * 2. The upvar references a single element of the array. In this case - * name2 will be NULL and name1 is the name of the alias. This alias - * must be resolved to the actual key of the array element. + * If name2 is NULL, then return and do nothing. */ if (name2 == NULL) { - Var *varPtr, *arrayPtr; - Tcl_Obj *name; - - name = Tcl_NewStringObj(name1, -1); - Tcl_IncrRefCount(name); - varPtr = TclObjLookupVarEx(interp, name, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - Tcl_DecrRefCount(name); - name2 = Tcl_GetString(VarHashGetKey(varPtr)); + return NULL; } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index f5b25dc..6657cef 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -872,6 +872,9 @@ typedef struct VarInHash { #define VarHashRefCount(varPtr) \ ((VarInHash *) (varPtr))->refCount +#define VarHashGetKey(varPtr) \ + (((VarInHash *)(varPtr))->entry.key.objPtr) + /* * Macros for direct variable access by TEBC. */ diff --git a/generic/tclTrace.c b/generic/tclTrace.c index f830a77..8999858 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -2634,6 +2634,7 @@ TclCallVarTraces( Tcl_InterpState state = NULL; Tcl_HashEntry *hPtr; int traceflags = flags & VAR_ALL_TRACES; + const char *element; /* * If there are already similar trace functions active for the variable, @@ -2685,6 +2686,20 @@ TclCallVarTraces( } } + /* Keep the original pointer for possible use in an error message */ + element = part2; + if (part2 == NULL) { + if (TclIsVarArrayElement(varPtr)) { + Tcl_Obj *keyObj = VarHashGetKey(varPtr); + part2 = Tcl_GetString(keyObj); + } + } else if ((flags & VAR_TRACED_UNSET) && !(flags & VAR_ARRAY_ELEMENT)) { + /* On unset traces, part2 has already been set by the caller, and + * the VAR_ARRAY_ELEMENT flag indicates whether the accessed + * variable actually has a second part, or is a scalar */ + element = NULL; + } + /* * Invoke traces on the array containing the variable, if relevant. */ @@ -2805,13 +2820,13 @@ TclCallVarTraces( Tcl_AppendObjToErrorInfo((Tcl_Interp *)iPtr, Tcl_ObjPrintf( "\n (%s trace on \"%s%s%s%s\")", type, part1, - (part2 ? "(" : ""), (part2 ? part2 : ""), - (part2 ? ")" : "") )); + (element ? "(" : ""), (element ? element : ""), + (element ? ")" : "") )); if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { - TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, + TclVarErrMsg((Tcl_Interp *) iPtr, part1, element, verb, TclGetString((Tcl_Obj *) result)); } else { - TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, result); + TclVarErrMsg((Tcl_Interp *) iPtr, part1, element, verb, result); } iPtr->flags &= ~(ERR_ALREADY_LOGGED); Tcl_DiscardInterpState(state); diff --git a/generic/tclVar.c b/generic/tclVar.c index b38575b..44645b5 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -108,9 +108,6 @@ VarHashNextVar( return VarHashGetValue(hPtr); } -#define VarHashGetKey(varPtr) \ - (((VarInHash *)(varPtr))->entry.key.objPtr) - #define VarHashDeleteTable(tablePtr) \ Tcl_DeleteHashTable(&(tablePtr)->table) @@ -2580,9 +2577,23 @@ UnsetVarStruct( if ((dummyVar.flags & VAR_TRACED_UNSET) || (arrayPtr && (arrayPtr->flags & VAR_TRACED_UNSET))) { + + /* + * Pass the array element name to TclObjCallVarTraces(), because + * it cannot be determined from dummyVar. Alternatively, indicate + * via flags whether the variable involved in the code that caused + * the trace to be triggered was an array element, for the correct + * formatting of error messages. + */ + if (part2Ptr) { + flags |= VAR_ARRAY_ELEMENT; + } else if (TclIsVarArrayElement(varPtr)) { + part2Ptr = VarHashGetKey(varPtr); + } + dummyVar.flags &= ~VAR_TRACE_ACTIVE; TclObjCallVarTraces(iPtr, arrayPtr, &dummyVar, part1Ptr, part2Ptr, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|VAR_ARRAY_ELEMENT)) | TCL_TRACE_UNSETS, /* leaveErrMsg */ 0, index); diff --git a/tests/upvar.test b/tests/upvar.test index 3682521..6330fa6 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -221,7 +221,7 @@ test upvar-5.4 {read trace on upvar array element} -body { set x --- p1 foo bar set x -} -result {{x1 {} read} x1} +} -result {{x1 c read} x1} test upvar-5.5 {write trace on upvar array element} -body { proc p1 {a b} { array set foo {c 22 d 33} @@ -236,7 +236,7 @@ test upvar-5.5 {write trace on upvar array element} -body { set x --- p1 foo bar set x -} -result {{x1 {} write} x1} +} -result {{x1 c write} x1} test upvar-5.6 {unset trace on upvar array element} -body { proc p1 {a b} { array set foo {c 22 d 33} @@ -251,7 +251,7 @@ test upvar-5.6 {unset trace on upvar array element} -body { set x --- p1 foo bar set x -} -result {{x1 {} unset} x1} +} -result {{x1 c unset} x1} test upvar-5.7 {trace on non-existent upvar array element} -body { proc p1 {a b} { array set foo {} @@ -267,7 +267,7 @@ test upvar-5.7 {trace on non-existent upvar array element} -body { set x --- lappend x [p1 foo bar] set x -} -result {{x1 {} write} x1 {hi there}} +} -result {{x1 hi write} x1 {hi there}} test upvar-6.1 {retargeting an upvar} { proc p1 {} { -- cgit v0.12 From 5f0c43664685bc2ee4df68984143d273a7d23ad6 Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 31 Aug 2022 20:33:29 +0000 Subject: Corrections to doc/safe.n --- doc/safe.n | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/safe.n b/doc/safe.n index b74f3c6..6dd4033 100644 --- a/doc/safe.n +++ b/doc/safe.n @@ -399,7 +399,7 @@ if \fB\-accessPath\fR is specified, then \fB\-autoPath\fR must also be specified, or else it will be set to {}. .PP The value of \fB\-autoPath\fR will be that required to access tclIndex -and pkgIndex.txt files according to the same rules as an unsafe +and pkgIndex.tcl files according to the same rules as an unsafe interpreter (see pkg_mkIndex(n) and library(n)). .PP With "Sync Mode" on, the option \fB\-autoPath\fR is undefined, and @@ -408,7 +408,7 @@ access path. In addition to the directories present if "Safe Mode" is off, the ::auto_path includes the numerous subdirectories and module paths that belong to the access path. .SH SYNC MODE -Before Tcl version 8.6.x, the Safe Base kept each safe interpreter's +Before Tcl version 8.7, the Safe Base kept each safe interpreter's ::auto_path synchronized with a tokenized form of its access path. Limitations of Tcl 8.4 and earlier made this feature necessary. This definition of ::auto_path did not conform its specification in library(n) -- cgit v0.12 From e03ac7f9c6599697608bb897f3bdbc2e47cf0883 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 2 Sep 2022 07:42:51 +0000 Subject: Some more (internal) ClientData -> void * changes --- macosx/tclMacOSXNotify.c | 20 ++++++++--------- tools/tsdPerf.c | 4 ++-- unix/tclEpollNotfy.c | 10 ++++----- unix/tclKqueueNotfy.c | 10 ++++----- unix/tclSelectNotfy.c | 4 ++-- unix/tclUnixCompat.c | 4 ++-- unix/tclUnixPipe.c | 2 +- unix/tclUnixTest.c | 20 ++++++++--------- unix/tclXtNotify.c | 10 ++++----- unix/tclXtTest.c | 2 +- win/tclWinConsole.c | 56 ++++++++++++++++++++++++------------------------ win/tclWinSock.c | 38 ++++++++++++++++---------------- win/tclWinTime.c | 18 ++++++++-------- 13 files changed, 99 insertions(+), 99 deletions(-) diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c index 15a1cd5..36c3f59 100644 --- a/macosx/tclMacOSXNotify.c +++ b/macosx/tclMacOSXNotify.c @@ -311,7 +311,7 @@ typedef struct FileHandler { * for this file. */ Tcl_FileProc *proc; /* Function to call, in the style of * Tcl_CreateFileHandler. */ - ClientData clientData; /* Argument to pass to proc. */ + void *clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ } FileHandler; @@ -505,7 +505,7 @@ static CFStringRef tclEventsOnlyRunLoopMode = NULL; */ static void StartNotifierThread(void); -static TCL_NORETURN void NotifierThreadProc(ClientData clientData); +static TCL_NORETURN void NotifierThreadProc(void *clientData); static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); static void TimerWakeUp(CFRunLoopTimerRef timer, void *info); static void QueueFileEvents(void *info); @@ -612,7 +612,7 @@ LookUpFileHandler( *---------------------------------------------------------------------- */ -ClientData +void * TclpInitNotifier(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -868,7 +868,7 @@ StartNotifierThread(void) void TclpFinalizeNotifier( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -970,7 +970,7 @@ TclpFinalizeNotifier( void TclpAlertNotifier( - ClientData clientData) + void *clientData) { ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; @@ -1047,7 +1047,7 @@ TclpSetTimer( static void TimerWakeUp( TCL_UNUSED(CFRunLoopTimerRef), - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { } @@ -1114,7 +1114,7 @@ TclpCreateFileHandler( * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ - ClientData clientData) /* Arbitrary data to pass to proc. */ + void *clientData) /* Arbitrary data to pass to proc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL); @@ -1334,7 +1334,7 @@ FileHandlerEventProc( *---------------------------------------------------------------------- */ -ClientData +void * TclpNotifierData(void) { return NULL; @@ -1908,7 +1908,7 @@ int TclAsyncNotifier( int sigNumber, /* Signal number. */ TCL_UNUSED(Tcl_ThreadId), /* Target thread. */ - TCL_UNUSED(ClientData), /* Notifier data. */ + TCL_UNUSED(void *), /* Notifier data. */ int *flagPtr, /* Flag to mark. */ int value) /* Value of mark. */ { @@ -1967,7 +1967,7 @@ TclAsyncNotifier( static TCL_NORETURN void NotifierThreadProc( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { ThreadSpecificData *tsdPtr; fd_set readableMask, writableMask, exceptionalMask; diff --git a/tools/tsdPerf.c b/tools/tsdPerf.c index 4c96f28..0bcc11b 100644 --- a/tools/tsdPerf.c +++ b/tools/tsdPerf.c @@ -10,7 +10,7 @@ typedef struct { static int -tsdPerfSetObjCmd(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { +tsdPerfSetObjCmd(void *cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { TsdPerf *perf = Tcl_GetThreadData(&key, sizeof(TsdPerf)); Tcl_WideInt i; @@ -29,7 +29,7 @@ tsdPerfSetObjCmd(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const } static int -tsdPerfGetObjCmd(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { +tsdPerfGetObjCmd(void *cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { TsdPerf *perf = Tcl_GetThreadData(&key, sizeof(TsdPerf)); diff --git a/unix/tclEpollNotfy.c b/unix/tclEpollNotfy.c index 3d6bcd5..659e659 100644 --- a/unix/tclEpollNotfy.c +++ b/unix/tclEpollNotfy.c @@ -42,7 +42,7 @@ typedef struct FileHandler { * for this file. */ Tcl_FileProc *proc; /* Function to call, in the style of * Tcl_CreateFileHandler. */ - ClientData clientData; /* Argument to pass to proc. */ + void *clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ LIST_ENTRY(FileHandler) readyNode; /* Next/previous in list of FileHandlers asso- @@ -150,7 +150,7 @@ static int PlatformEventsWait(struct epoll_event *events, *---------------------------------------------------------------------- */ -ClientData +void * TclpInitNotifier(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -275,7 +275,7 @@ PlatformEventsControl( void TclpFinalizeNotifier( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -513,7 +513,7 @@ TclpCreateFileHandler( * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ - ClientData clientData) /* Arbitrary data to pass to proc. */ + void *clientData) /* Arbitrary data to pass to proc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL); @@ -791,7 +791,7 @@ int TclAsyncNotifier( int sigNumber, /* Signal number. */ Tcl_ThreadId threadId, /* Target thread. */ - ClientData clientData, /* Notifier data. */ + void *clientData, /* Notifier data. */ int *flagPtr, /* Flag to mark. */ int value) /* Value of mark. */ { diff --git a/unix/tclKqueueNotfy.c b/unix/tclKqueueNotfy.c index 005abc5..487af9c 100644 --- a/unix/tclKqueueNotfy.c +++ b/unix/tclKqueueNotfy.c @@ -40,7 +40,7 @@ typedef struct FileHandler { * for this file. */ Tcl_FileProc *proc; /* Function to call, in the style of * Tcl_CreateFileHandler. */ - ClientData clientData; /* Argument to pass to proc. */ + void *clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ LIST_ENTRY(FileHandler) readyNode; /* Next/previous in list of FileHandlers asso- @@ -274,7 +274,7 @@ PlatformEventsControl( void TclpFinalizeNotifier( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -330,7 +330,7 @@ TclpFinalizeNotifier( *---------------------------------------------------------------------- */ -ClientData +void * TclpInitNotifier(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -518,7 +518,7 @@ TclpCreateFileHandler( * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ - ClientData clientData) /* Arbitrary data to pass to proc. */ + void *clientData) /* Arbitrary data to pass to proc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); FileHandler *filePtr = LookUpFileHandler(tsdPtr, fd, NULL); @@ -787,7 +787,7 @@ int TclAsyncNotifier( int sigNumber, /* Signal number. */ Tcl_ThreadId threadId, /* Target thread. */ - ClientData clientData, /* Notifier data. */ + void *clientData, /* Notifier data. */ int *flagPtr, /* Flag to mark. */ int value) /* Value of mark. */ { diff --git a/unix/tclSelectNotfy.c b/unix/tclSelectNotfy.c index e7a53bf..862a0e3 100644 --- a/unix/tclSelectNotfy.c +++ b/unix/tclSelectNotfy.c @@ -921,7 +921,7 @@ int TclAsyncNotifier( int sigNumber, /* Signal number. */ TCL_UNUSED(Tcl_ThreadId), /* Target thread. */ - TCL_UNUSED(ClientData), /* Notifier data. */ + TCL_UNUSED(void *), /* Notifier data. */ int *flagPtr, /* Flag to mark. */ int value) /* Value of mark. */ { @@ -986,7 +986,7 @@ TclAsyncNotifier( #if TCL_THREADS static TCL_NORETURN void NotifierThreadProc( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { ThreadSpecificData *tsdPtr; fd_set readableMask; diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c index 111a082..8aff976 100644 --- a/unix/tclUnixCompat.c +++ b/unix/tclUnixCompat.c @@ -116,10 +116,10 @@ static int CopyString(const char *src, char *buf, int buflen); #endif #ifdef NEED_PW_CLEANER -static void FreePwBuf(ClientData dummy); +static void FreePwBuf(void *dummy); #endif #ifdef NEED_GR_CLEANER -static void FreeGrBuf(ClientData dummy); +static void FreeGrBuf(void *dummy); #endif #endif /* TCL_THREADS */ diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c index d9f8043..0692df5 100644 --- a/unix/tclUnixPipe.c +++ b/unix/tclUnixPipe.c @@ -1251,7 +1251,7 @@ Tcl_WaitPid( int Tcl_PidObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index 80e8081..ccb9105 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -129,7 +129,7 @@ TclplatformtestInit( static int TestfilehandlerCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ @@ -310,7 +310,7 @@ TestfilehandlerCmd( static void TestFileHandlerProc( - ClientData clientData, /* Points to a Pipe structure. */ + void *clientData, /* Points to a Pipe structure. */ int mask) /* Indicates which events happened: * TCL_READABLE or TCL_WRITABLE. */ { @@ -343,7 +343,7 @@ TestFileHandlerProc( static int TestfilewaitCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ @@ -351,7 +351,7 @@ TestfilewaitCmd( int mask, result, timeout; Tcl_Channel channel; int fd; - ClientData data; + void *data; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "file readable|writable|both timeout"); @@ -374,7 +374,7 @@ TestfilewaitCmd( } if (Tcl_GetChannelHandle(channel, (mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE, - (ClientData*) &data) != TCL_OK) { + (void **) &data) != TCL_OK) { Tcl_AppendResult(interp, "couldn't get channel file", NULL); return TCL_ERROR; } @@ -411,7 +411,7 @@ TestfilewaitCmd( static int TestfindexecutableCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ @@ -453,7 +453,7 @@ TestfindexecutableCmd( static int TestforkCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ @@ -499,7 +499,7 @@ TestforkCmd( static int TestalarmCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ @@ -577,7 +577,7 @@ AlarmHandler( static int TestgotsigCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ TCL_UNUSED(int) /*objc*/, TCL_UNUSED(Tcl_Obj *const *)) @@ -608,7 +608,7 @@ TestgotsigCmd( static int TestchmodCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ diff --git a/unix/tclXtNotify.c b/unix/tclXtNotify.c index b7a1ea8..ab1bfee 100644 --- a/unix/tclXtNotify.c +++ b/unix/tclXtNotify.c @@ -33,7 +33,7 @@ typedef struct FileHandler { XtInputId except; /* Xt exception callback handle. */ Tcl_FileProc *proc; /* Procedure to call, in the style of * Tcl_CreateFileHandler. */ - ClientData clientData; /* Argument to pass to proc. */ + void *clientData; /* Argument to pass to proc. */ struct FileHandler *nextPtr;/* Next in list of all files we care about. */ } FileHandler; @@ -79,10 +79,10 @@ static int initialized = 0; static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); static void FileProc(XtPointer clientData, int *source, XtInputId *id); -static void NotifierExitHandler(ClientData clientData); +static void NotifierExitHandler(void *clientData); static void TimerProc(XtPointer clientData, XtIntervalId *id); static void CreateFileHandler(int fd, int mask, - Tcl_FileProc *proc, ClientData clientData); + Tcl_FileProc *proc, void *clientData); static void DeleteFileHandler(int fd); static void SetTimer(const Tcl_Time * timePtr); static int WaitForEvent(const Tcl_Time * timePtr); @@ -229,7 +229,7 @@ InitNotifier(void) static void NotifierExitHandler( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { if (notifier.currentTimeout != 0) { XtRemoveTimeOut(notifier.currentTimeout); @@ -339,7 +339,7 @@ CreateFileHandler( * called. */ Tcl_FileProc *proc, /* Procedure to call for each selected * event. */ - ClientData clientData) /* Arbitrary data to pass to proc. */ + void *clientData) /* Arbitrary data to pass to proc. */ { FileHandler *filePtr; diff --git a/unix/tclXtTest.c b/unix/tclXtTest.c index 882f497..09b16c5 100644 --- a/unix/tclXtTest.c +++ b/unix/tclXtTest.c @@ -77,7 +77,7 @@ Tclxttest_Init( static int TesteventloopCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 90b3c90..8452cf1 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -210,29 +210,29 @@ typedef struct { * Declarations for functions used only in this file. */ -static int ConsoleBlockModeProc(ClientData instanceData, int mode); -static void ConsoleCheckProc(ClientData clientData, int flags); -static int ConsoleCloseProc(ClientData instanceData, +static int ConsoleBlockModeProc(void *instanceData, int mode); +static void ConsoleCheckProc(void *clientData, int flags); +static int ConsoleCloseProc(void *instanceData, Tcl_Interp *interp, int flags); static int ConsoleEventProc(Tcl_Event *evPtr, int flags); -static void ConsoleExitHandler(ClientData clientData); -static int ConsoleGetHandleProc(ClientData instanceData, - int direction, ClientData *handlePtr); -static int ConsoleGetOptionProc(ClientData instanceData, +static void ConsoleExitHandler(void *clientData); +static int ConsoleGetHandleProc(void *instanceData, + int direction, void **handlePtr); +static int ConsoleGetOptionProc(void *instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); static void ConsoleInit(void); -static int ConsoleInputProc(ClientData instanceData, char *buf, +static int ConsoleInputProc(void *instanceData, char *buf, int toRead, int *errorCode); -static int ConsoleOutputProc(ClientData instanceData, +static int ConsoleOutputProc(void *instanceData, const char *buf, int toWrite, int *errorCode); -static int ConsoleSetOptionProc(ClientData instanceData, +static int ConsoleSetOptionProc(void *instanceData, Tcl_Interp *interp, const char *optionName, const char *value); -static void ConsoleSetupProc(ClientData clientData, int flags); -static void ConsoleWatchProc(ClientData instanceData, int mask); -static void ProcExitHandler(ClientData clientData); -static void ConsoleThreadActionProc(ClientData instanceData, int action); +static void ConsoleSetupProc(void *clientData, int flags); +static void ConsoleWatchProc(void *instanceData, int mask); +static void ProcExitHandler(void *clientData); +static void ConsoleThreadActionProc(void *instanceData, int action); static DWORD ReadConsoleChars(HANDLE hConsole, WCHAR *lpBuffer, RingSizeT nChars, RingSizeT *nCharsReadPtr); static DWORD WriteConsoleChars(HANDLE hConsole, @@ -670,7 +670,7 @@ ConsoleInit(void) static void ConsoleExitHandler( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { Tcl_DeleteEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL); } @@ -694,7 +694,7 @@ ConsoleExitHandler( static void ProcExitHandler( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { AcquireSRWLockExclusive(&gConsoleLock); gInitialized = 0; @@ -759,7 +759,7 @@ void NudgeWatchers (HANDLE consoleHandle) void ConsoleSetupProc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { ConsoleChannelInfo *chanInfoPtr; @@ -824,7 +824,7 @@ ConsoleSetupProc( static void ConsoleCheckProc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { ConsoleChannelInfo *chanInfoPtr; @@ -924,7 +924,7 @@ ConsoleCheckProc( static int ConsoleBlockModeProc( - ClientData instanceData, /* Instance data for channel. */ + void *instanceData, /* Instance data for channel. */ int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { @@ -964,7 +964,7 @@ ConsoleBlockModeProc( static int ConsoleCloseProc( - ClientData instanceData, /* Pointer to ConsoleChannelInfo structure. */ + void *instanceData, /* Pointer to ConsoleChannelInfo structure. */ TCL_UNUSED(Tcl_Interp *), int flags) { @@ -1083,7 +1083,7 @@ ConsoleCloseProc( */ static int ConsoleInputProc( - ClientData instanceData, /* Console state. */ + void *instanceData, /* Console state. */ char *bufPtr, /* Where to store data read. */ int bufSize, /* How much space is available in the * buffer? */ @@ -1236,7 +1236,7 @@ ConsoleInputProc( */ static int ConsoleOutputProc( - ClientData instanceData, /* Console state. */ + void *instanceData, /* Console state. */ const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCode) /* Where to store error code. */ @@ -1476,7 +1476,7 @@ ConsoleEventProc( static void ConsoleWatchProc( - ClientData instanceData, /* Console state. */ + void *instanceData, /* Console state. */ int newMask) /* What events to watch for, one of * of TCL_READABLE, TCL_WRITABLE */ @@ -1552,9 +1552,9 @@ ConsoleWatchProc( static int ConsoleGetHandleProc( - ClientData instanceData, /* The console state. */ + void *instanceData, /* The console state. */ TCL_UNUSED(int) /*direction*/, - ClientData *handlePtr) /* Where to store the handle. */ + void **handlePtr) /* Where to store the handle. */ { ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; @@ -2223,7 +2223,7 @@ TclWinOpenConsoleChannel( static void ConsoleThreadActionProc( - ClientData instanceData, + void *instanceData, int action) { ConsoleChannelInfo *chanInfoPtr = (ConsoleChannelInfo *)instanceData; @@ -2256,7 +2256,7 @@ ConsoleThreadActionProc( */ static int ConsoleSetOptionProc( - ClientData instanceData, /* File state. */ + void *instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Which option to set? */ const char *value) /* New value for option. */ @@ -2345,7 +2345,7 @@ ConsoleSetOptionProc( static int ConsoleGetOptionProc( - ClientData instanceData, /* File state. */ + void *instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Option to get. */ Tcl_DString *dsPtr) /* Where to store value(s). */ diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 06dce90..2261ee2 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -149,7 +149,7 @@ struct TcpState { * protected by semaphore */ Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ - ClientData acceptProcData; /* The data for the accept proc. */ + void *acceptProcData; /* The data for the accept proc. */ /* * Only needed for client sockets @@ -245,7 +245,7 @@ static int TcpConnect(Tcl_Interp *interp, TcpState *state); static void InitSockets(void); static TcpState * NewSocketInfo(SOCKET socket); -static void SocketExitHandler(ClientData clientData); +static void SocketExitHandler(void *clientData); static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); static int SocketsEnabled(void); @@ -256,7 +256,7 @@ static int WaitForSocketEvent(TcpState *statePtr, int events, static void AddSocketInfoFd(TcpState *statePtr, SOCKET socket); static int FindFDInList(TcpState *statePtr, SOCKET socket); static DWORD WINAPI SocketThread(LPVOID arg); -static void TcpThreadActionProc(ClientData instanceData, +static void TcpThreadActionProc(void *instanceData, int action); static int TcpCloseProc(void *, Tcl_Interp *); @@ -544,7 +544,7 @@ TclpFinalizeSockets(void) static int TcpBlockModeProc( - ClientData instanceData, /* Socket state. */ + void *instanceData, /* Socket state. */ int mode) /* The mode to set. Can be one of * TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ @@ -775,7 +775,7 @@ WaitForConnect( static int TcpInputProc( - ClientData instanceData, /* Socket state. */ + void *instanceData, /* Socket state. */ char *buf, /* Where to store data read. */ int bufSize, /* How much space is available in the * buffer? */ @@ -919,7 +919,7 @@ TcpInputProc( static int TcpOutputProc( - ClientData instanceData, /* Socket state. */ + void *instanceData, /* Socket state. */ const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCodePtr) /* Where to store error code. */ @@ -1034,7 +1034,7 @@ TcpOutputProc( static int TcpCloseProc( - ClientData instanceData, /* The socket to close. */ + void *instanceData, /* The socket to close. */ TCL_UNUSED(Tcl_Interp *)) { TcpState *statePtr = (TcpState *)instanceData; @@ -1128,7 +1128,7 @@ TcpCloseProc( static int TcpClose2Proc( - ClientData instanceData, /* The socket to close. */ + void *instanceData, /* The socket to close. */ Tcl_Interp *interp, /* For error reporting. */ int flags) /* Flags that indicate which side to close. */ { @@ -1178,7 +1178,7 @@ TcpClose2Proc( static int TcpSetOptionProc( - ClientData instanceData, /* Socket state. */ + void *instanceData, /* Socket state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Name of the option to set. */ TCL_UNUSED(const char *) /*value*/) /* New value for option. */ @@ -1283,7 +1283,7 @@ TcpSetOptionProc( static int TcpGetOptionProc( - ClientData instanceData, /* Socket state. */ + void *instanceData, /* Socket state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Name of the option to retrieve the value * for, or NULL to get all options and their @@ -1605,7 +1605,7 @@ TcpGetOptionProc( static void TcpWatchProc( - ClientData instanceData, /* The socket state. */ + void *instanceData, /* The socket state. */ int mask) /* Events of interest; an OR-ed combination of * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ @@ -1659,9 +1659,9 @@ TcpWatchProc( static int TcpGetHandleProc( - ClientData instanceData, /* The socket state. */ + void *instanceData, /* The socket state. */ TCL_UNUSED(int) /*direction*/, - ClientData *handlePtr) /* Where to store the handle. */ + void **handlePtr) /* Where to store the handle. */ { TcpState *statePtr = (TcpState *)instanceData; @@ -2129,7 +2129,7 @@ Tcl_OpenTcpClient( Tcl_Channel Tcl_MakeTcpClientChannel( - ClientData sock) /* The socket to wrap up into a channel. */ + void *sock) /* The socket to wrap up into a channel. */ { TcpState *statePtr; char channelName[SOCK_CHAN_LENGTH]; @@ -2189,7 +2189,7 @@ Tcl_OpenTcpServerEx( Tcl_TcpAcceptProc *acceptProc, /* Callback for accepting connections from new * clients. */ - ClientData acceptProcData) /* Data for the callback. */ + void *acceptProcData) /* Data for the callback. */ { SOCKET sock = INVALID_SOCKET; unsigned short chosenport = 0; @@ -2606,7 +2606,7 @@ SocketsEnabled(void) static void SocketExitHandler( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { Tcl_MutexLock(&socketMutex); @@ -2640,7 +2640,7 @@ SocketExitHandler( void SocketSetupProc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { TcpState *statePtr; @@ -2685,7 +2685,7 @@ SocketSetupProc( static void SocketCheckProc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { TcpState *statePtr; @@ -3406,7 +3406,7 @@ FindFDInList( static void TcpThreadActionProc( - ClientData instanceData, + void *instanceData, int action) { ThreadSpecificData *tsdPtr; diff --git a/win/tclWinTime.c b/win/tclWinTime.c index 15d9117..1855c20 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -108,7 +108,7 @@ static struct { * Declarations for functions defined later in this file. */ -static void StopCalibration(ClientData clientData); +static void StopCalibration(void *clientData); static DWORD WINAPI CalibrationThread(LPVOID arg); static void UpdateTimeEachSecond(void); static void ResetCounterSamples(unsigned long long fileTime, @@ -116,10 +116,10 @@ static void ResetCounterSamples(unsigned long long fileTime, static long long AccumulateSample(long long perfCounter, unsigned long long fileTime); static void NativeScaleTime(Tcl_Time* timebuf, - ClientData clientData); + void *clientData); static long long NativeGetMicroseconds(void); static void NativeGetTime(Tcl_Time* timebuf, - ClientData clientData); + void *clientData); /* * TIP #233 (Virtualized Time): Data for the time hooks, if any. @@ -127,7 +127,7 @@ static void NativeGetTime(Tcl_Time* timebuf, Tcl_GetTimeProc *tclGetTimeProcPtr = NativeGetTime; Tcl_ScaleTimeProc *tclScaleTimeProcPtr = NativeScaleTime; -ClientData tclTimeClientData = NULL; +void *tclTimeClientData = NULL; /* * Inlined version of Tcl_GetTime. @@ -411,7 +411,7 @@ Tcl_GetTime( static void NativeScaleTime( TCL_UNUSED(Tcl_Time *), - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { /* * Native scale is 1:1. Nothing is done. @@ -677,7 +677,7 @@ NativeGetMicroseconds(void) static void NativeGetTime( Tcl_Time *timePtr, - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { long long usecSincePosixEpoch; @@ -724,7 +724,7 @@ void TclWinResetTimerResolution(void); static void StopCalibration( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { SetEvent(timeInfo.exitEvent); @@ -1198,7 +1198,7 @@ void Tcl_SetTimeProc( Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, - ClientData clientData) + void *clientData) { tclGetTimeProcPtr = getProc; tclScaleTimeProcPtr = scaleProc; @@ -1225,7 +1225,7 @@ void Tcl_QueryTimeProc( Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, - ClientData *clientData) + void **clientData) { if (getProc) { *getProc = tclGetTimeProcPtr; -- cgit v0.12 From 70d6ba87462da32e8515e346a38eae4c9c9ab83f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 2 Sep 2022 10:17:44 +0000 Subject: Finish remaining part of TIP-627 for Tcl 9.0: Handle objProc2/objClientData2 fields correctly in Tcl_CmdInfo struct. --- generic/tclBasic.c | 95 +++++++++++++++++++++++++++++++++++++++++++-------- generic/tclIndexObj.c | 2 +- generic/tclTest.c | 37 ++++++++++++-------- 3 files changed, 105 insertions(+), 29 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index eb3889d..379ab10 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -608,13 +608,13 @@ TclFinalizeEvaluation(void) */ static int -buildInfoObjCmd( +buildInfoObjCmd2( void *clientData, Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - if (objc > 2) { + if (objc - 1 > 1) { Tcl_WrongNumArgs(interp, 1, objv, "?option?"); return TCL_ERROR; } @@ -693,6 +693,16 @@ buildInfoObjCmd( return TCL_OK; } +static int +buildInfoObjCmd( + void *clientData, + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return buildInfoObjCmd2(clientData, interp, (size_t)objc, objv); +} + /* *---------------------------------------------------------------------- * @@ -1234,9 +1244,13 @@ Tcl_CreateInterp(void) Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); Tcl_PkgProvideEx(interp, "tcl", TCL_PATCH_LEVEL, &tclStubs); - Tcl_CreateObjCommand(interp, "::tcl::build-info", - buildInfoObjCmd, (void *)version, NULL); - + Tcl_CmdInfo info2; + Tcl_Command buildInfoCmd = Tcl_CreateObjCommand2(interp, "::tcl::build-info", + buildInfoObjCmd2, (void *)version, NULL); + Tcl_GetCommandInfoFromToken(buildInfoCmd, &info2); + info2.objProc = buildInfoObjCmd; + info2.objClientData = (void *)version; + Tcl_SetCommandInfoFromToken(buildInfoCmd, &info2); if (TclTommath_Init(interp) != TCL_OK) { Tcl_Panic("%s", Tcl_GetStringResult(interp)); @@ -2631,10 +2645,11 @@ Tcl_CreateCommand( */ typedef struct { - void *clientData; /* Arbitrary value to pass to object function. */ Tcl_ObjCmdProc2 *proc; - Tcl_ObjCmdProc2 *nreProc; + void *clientData; /* Arbitrary value to pass to proc function. */ Tcl_CmdDeleteProc *deleteProc; + void *deleteData; /* Arbitrary value to pass to deleteProc function. */ + Tcl_ObjCmdProc2 *nreProc; } CmdWrapperInfo; @@ -2650,7 +2665,7 @@ static int cmdWrapperProc(void *clientData, static void cmdWrapperDeleteProc(void *clientData) { CmdWrapperInfo *info = (CmdWrapperInfo *)clientData; - clientData = info->clientData; + clientData = info->deleteData; Tcl_CmdDeleteProc *deleteProc = info->deleteProc; Tcl_Free(info); if (deleteProc != NULL) { @@ -2677,8 +2692,9 @@ Tcl_CreateObjCommand2( { CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo)); info->proc = proc; - info->deleteProc = deleteProc; info->clientData = clientData; + info->deleteProc = deleteProc; + info->deleteData = clientData; return Tcl_CreateObjCommand(interp, cmdName, (proc ? cmdWrapperProc : NULL), @@ -3265,6 +3281,28 @@ Tcl_SetCommandInfo( *---------------------------------------------------------------------- */ +static int +invokeObj2Command( + void *clientData, /* Points to command's Command structure. */ + Tcl_Interp *interp, /* Current interpreter. */ + size_t objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int result; + Command *cmdPtr = (Command *) clientData; + + if (objc > INT_MAX) { + objc = TCL_INDEX_NONE; + } + if (cmdPtr->objProc != NULL) { + result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); + } else { + result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, + cmdPtr->objClientData, objc, objv); + } + return result; +} + int Tcl_SetCommandInfoFromToken( Tcl_Command cmd, @@ -3296,8 +3334,19 @@ Tcl_SetCommandInfoFromToken( } if (cmdPtr->deleteProc == cmdWrapperDeleteProc) { CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData; + if (infoPtr->objProc2 == NULL) { + info->proc = invokeObj2Command; + info->clientData = cmdPtr; + info->nreProc = NULL; + } else { + if (infoPtr->objProc2 != info->proc) { + info->nreProc = NULL; + info->proc = infoPtr->objProc2; + } + info->clientData = infoPtr->objClientData2; + } info->deleteProc = infoPtr->deleteProc; - info->clientData = infoPtr->deleteData; + info->deleteData = infoPtr->deleteData; } else { cmdPtr->deleteProc = infoPtr->deleteProc; cmdPtr->deleteData = infoPtr->deleteData; @@ -3355,6 +3404,15 @@ Tcl_GetCommandInfo( *---------------------------------------------------------------------- */ +static int cmdWrapper2Proc(void *clientData, + Tcl_Interp *interp, + size_t objc, + Tcl_Obj *const objv[]) +{ + Command *cmdPtr = (Command *)clientData; + return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); +} + int Tcl_GetCommandInfoFromToken( Tcl_Command cmd, @@ -3368,7 +3426,8 @@ Tcl_GetCommandInfoFromToken( /* * Set isNativeObjectProc 1 if objProc was registered by a call to - * Tcl_CreateObjCommand. Otherwise set it to 0. + * Tcl_CreateObjCommand. Set isNativeObjectProc 2 if objProc was + * registered by a call to Tcl_CreateObjCommand. Otherwise set it to 0. */ cmdPtr = (Command *) cmd; @@ -3381,10 +3440,17 @@ Tcl_GetCommandInfoFromToken( if (cmdPtr->deleteProc == cmdWrapperDeleteProc) { CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData; infoPtr->deleteProc = info->deleteProc; - infoPtr->deleteData = info->clientData; + infoPtr->deleteData = info->deleteData; + infoPtr->objProc2 = info->proc; + infoPtr->objClientData2 = info->clientData; + if (cmdPtr->objProc == cmdWrapperProc) { + infoPtr->isNativeObjectProc = 2; + } } else { infoPtr->deleteProc = cmdPtr->deleteProc; infoPtr->deleteData = cmdPtr->deleteData; + infoPtr->objProc2 = cmdWrapper2Proc; + infoPtr->objClientData2 = cmdPtr; } infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; return 1; @@ -8491,9 +8557,10 @@ Tcl_NRCreateCommand2( { CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo)); info->proc = proc; + info->clientData = clientData; info->nreProc = nreProc; info->deleteProc = deleteProc; - info->clientData = clientData; + info->deleteData = clientData; return Tcl_NRCreateCommand(interp, cmdName, (proc ? cmdWrapperProc : NULL), (nreProc ? cmdWrapperNreProc : NULL), diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 78dd47e..763d661 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -944,7 +944,7 @@ Tcl_WrongNumArgs( * (either another element from objv, or the message string). */ - if (i 8 + if (info.isNativeObjectProc == 2) { + Tcl_CreateObjCommand2(interp, "::tcl::test::build-info", + info.objProc2, (void *)version, NULL); + } else +#endif Tcl_CreateObjCommand(interp, "::tcl::test::build-info", info.objProc, (void *)version, NULL); } @@ -573,7 +579,7 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, + Tcl_CreateObjCommand2(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, NULL, NULL); @@ -811,6 +817,12 @@ Tcltest_SafeInit( return TCL_ERROR; } if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) { +#if TCL_MAJOR_VERSION > 8 + if (info.isNativeObjectProc == 2) { + Tcl_CreateObjCommand2(interp, "::tcl::test::build-info", + info.objProc2, (void *)version, NULL); + } else +#endif Tcl_CreateObjCommand(interp, "::tcl::test::build-info", info.objProc, (void *)version, NULL); } @@ -6508,22 +6520,18 @@ static int TestWrongNumArgsObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + size_t objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i, length; + Tcl_WideInt i; + size_t length; const char *msg; - if (objc < 3) { - /* - * Don't use Tcl_WrongNumArgs here, as that is the function - * we want to test! - */ - Tcl_AppendResult(interp, "insufficient arguments", NULL); - return TCL_ERROR; + if (objc + 1 < 4) { + goto insufArgs; } - if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[1], &i) != TCL_OK) { return TCL_ERROR; } @@ -6532,15 +6540,16 @@ TestWrongNumArgsObjCmd( msg = NULL; } - if (i > objc - 3) { + if (i < 0 || (Tcl_WideUInt)i + 3 > (Tcl_WideUInt)objc) { /* * Asked for more arguments than were given. */ + insufArgs: Tcl_AppendResult(interp, "insufficient arguments", NULL); return TCL_ERROR; } - Tcl_WrongNumArgs(interp, i, &(objv[3]), msg); + Tcl_WrongNumArgs(interp, (size_t)i, &(objv[3]), msg); return TCL_OK; } -- cgit v0.12 From 007dfc95a9870b057dda71b51dc84e856aa09a38 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 2 Sep 2022 14:41:09 +0000 Subject: Some additional protection for objc < 0 --- generic/tclBasic.c | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b1b35e1..f474b5d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -8480,7 +8480,10 @@ int wrapperNRObjProc( clientData = info->clientData; Tcl_ObjCmdProc2 *proc = info->proc; Tcl_Free(info); - return proc(clientData, interp, objc, objv); + if (objc < 0) { + objc = -1; + } + return proc(clientData, interp, (size_t)objc, objv); } int @@ -8536,7 +8539,10 @@ static int cmdWrapperNreProc( Tcl_Obj *const objv[]) { CmdWrapperInfo *info = (CmdWrapperInfo *)clientData; - return info->nreProc(info->clientData, interp, objc, objv); + if (objc < 0) { + objc = -1; + } + return info->nreProc(info->clientData, interp, (size_t)objc, objv); } Tcl_Command -- cgit v0.12 From cd5e1b2e6cc18917b875413e8b7e40da7fb5002f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 2 Sep 2022 22:41:50 +0000 Subject: Complete Tcl_SetCommandInfoFromToken() implementation, in case Tcl_CreateObjCommand() is used to create the original Command, while objProc2 is filled later --- generic/tclBasic.c | 41 ++++++++++++++++++++++++++--------------- 1 file changed, 26 insertions(+), 15 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index f474b5d..b2ec58e 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1245,11 +1245,11 @@ Tcl_CreateInterp(void) Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); Tcl_PkgProvideEx(interp, "tcl", TCL_PATCH_LEVEL, &tclStubs); Tcl_CmdInfo info2; - Tcl_Command buildInfoCmd = Tcl_CreateObjCommand2(interp, "::tcl::build-info", - buildInfoObjCmd2, (void *)version, NULL); + Tcl_Command buildInfoCmd = Tcl_CreateObjCommand(interp, "::tcl::build-info", + buildInfoObjCmd, (void *)version, NULL); Tcl_GetCommandInfoFromToken(buildInfoCmd, &info2); - info2.objProc = buildInfoObjCmd; - info2.objClientData = (void *)version; + info2.objProc2 = buildInfoObjCmd2; + info2.objClientData2 = (void *)version; Tcl_SetCommandInfoFromToken(buildInfoCmd, &info2); if (TclTommath_Init(interp) != TCL_OK) { @@ -3306,6 +3306,15 @@ invokeObj2Command( return result; } +static int cmdWrapper2Proc(void *clientData, + Tcl_Interp *interp, + size_t objc, + Tcl_Obj *const objv[]) +{ + Command *cmdPtr = (Command *)clientData; + return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); +} + int Tcl_SetCommandInfoFromToken( Tcl_Command cmd, @@ -3351,8 +3360,19 @@ Tcl_SetCommandInfoFromToken( info->deleteProc = infoPtr->deleteProc; info->deleteData = infoPtr->deleteData; } else { - cmdPtr->deleteProc = infoPtr->deleteProc; - cmdPtr->deleteData = infoPtr->deleteData; + if ((infoPtr->objProc2 != NULL) && (infoPtr->objProc2 != cmdWrapper2Proc)) { + CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo)); + info->proc = infoPtr->objProc2; + info->clientData = infoPtr->objClientData2; + info->nreProc = NULL; + info->deleteProc = infoPtr->deleteProc; + info->deleteData = infoPtr->deleteData; + cmdPtr->deleteProc = cmdWrapperDeleteProc; + cmdPtr->deleteData = info; + } else { + cmdPtr->deleteProc = infoPtr->deleteProc; + cmdPtr->deleteData = infoPtr->deleteData; + } } return 1; } @@ -3407,15 +3427,6 @@ Tcl_GetCommandInfo( *---------------------------------------------------------------------- */ -static int cmdWrapper2Proc(void *clientData, - Tcl_Interp *interp, - size_t objc, - Tcl_Obj *const objv[]) -{ - Command *cmdPtr = (Command *)clientData; - return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); -} - int Tcl_GetCommandInfoFromToken( Tcl_Command cmd, -- cgit v0.12 From b9413619f69f8da7428dff21ac1fa1c9f85deea4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 3 Sep 2022 13:45:24 +0000 Subject: TIP #344 implementation --- doc/socket.n | 15 +++++- tests/ioCmd.test | 2 +- tests/socket.test | 2 +- unix/tclUnixSock.c | 139 ++++++++++++++++++++++++++++++++++++++++++++++++++--- win/tclWinSock.c | 82 +++++++++++-------------------- 5 files changed, 176 insertions(+), 64 deletions(-) diff --git a/doc/socket.n b/doc/socket.n index 8836150..4506181 100644 --- a/doc/socket.n +++ b/doc/socket.n @@ -162,7 +162,8 @@ described below. .SH "CONFIGURATION OPTIONS" .PP The \fBchan configure\fR command can be used to query several readonly -configuration options for socket channels: +configuration options for socket channels or in some cases to set +alternative properties on socket channels: .TP \fB\-error\fR . @@ -204,6 +205,18 @@ list is identical to the address, its first element. \fB\-connecting\fR . This option is not supported by server sockets. For client sockets, this option returns 1 if an asyncroneous connect is still in progress, 0 otherwise. +.TP +\fB\-keepalive\fR +. +This options sets or queries the TCP keepalive option on the socket as 1 if +keepalive is turned on, 0 otherwise. +.TP +\fB\-nagle\fR +. +This options sets or queries the TCP nodelay option (aka the Nagle algorithm) +When 1 the Nagle algorithm is turned on, 0 otherwise. Caution: the logic is +reversed here, i.e. when the option is 0, the underlying system call asserts +the TCP_NODELAY setting. .PP .SH "EXAMPLES" .PP diff --git a/tests/ioCmd.test b/tests/ioCmd.test index dbca866..3aeeb61 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -306,7 +306,7 @@ test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOr close $srv unset cli srv port rename iocmdSRV {} -} -returnCodes error -result [expectedOpts "-blah" {-connecting -peername -sockname}] +} -returnCodes error -result [expectedOpts "-blah" {-connecting -keepalive -peername -nagle -sockname}] test iocmd-8.16 {fconfigure command / tcp channel} -constraints socket -setup { set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] set port [lindex [fconfigure $srv -sockname] 2] diff --git a/tests/socket.test b/tests/socket.test index 4644e1d..7250cb8 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -1071,7 +1071,7 @@ test socket_$af-7.3 {testing socket specific options} -constraints [list socket close $s update llength $l -} -result 14 +} -result 18 test socket_$af-7.4 {testing socket specific options} -constraints [list socket supported_$af] -setup { set timer [after 10000 "set x timed_out"] set l "" diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index d2068c3..e815d77 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -9,6 +9,7 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#include #include "tclInt.h" /* @@ -146,6 +147,9 @@ static int TcpInputProc(void *instanceData, char *buf, int toRead, int *errorCode); static int TcpOutputProc(void *instanceData, const char *buf, int toWrite, int *errorCode); +static int TcpSetOptionProc(void *instanceData, + Tcl_Interp *interp, const char *optionName, + const char *value); static void TcpThreadActionProc(void *instanceData, int action); static void TcpWatchProc(void *instanceData, int mask); static int WaitForConnect(TcpState *statePtr, int *errorCodePtr); @@ -167,7 +171,7 @@ static const Tcl_ChannelType tcpChannelType = { TcpInputProc, /* Input proc. */ TcpOutputProc, /* Output proc. */ NULL, /* Seek proc. */ - NULL, /* Set option proc. */ + TcpSetOptionProc, /* Set option proc. */ TcpGetOptionProc, /* Get option proc. */ TcpWatchProc, /* Initialize notifier. */ TcpGetHandleProc, /* Get OS handles out of channel. */ @@ -434,7 +438,7 @@ TcpBlockModeProc( * * Side effects: * Processes socket events off the system queue. May process - * asynchroneous connects. + * asynchronous connects. * *---------------------------------------------------------------------- */ @@ -815,6 +819,88 @@ TcpHostPortList( /* *---------------------------------------------------------------------- * + * TcpSetOptionProc -- + * + * Sets TCP channel specific options. + * + * Results: + * None, unless an error happens. + * + * Side effects: + * Changes attributes of the socket at the system level. + * + *---------------------------------------------------------------------- + */ + +static int +TcpSetOptionProc( + void *instanceData, /* Socket state. */ + Tcl_Interp *interp, /* For error reporting - can be NULL. */ + const char *optionName, /* Name of the option to set. */ + const char *value) /* New value for option. */ +{ + TcpState *statePtr = (TcpState *)instanceData; + size_t len = 0; + + if (optionName != NULL) { + len = strlen(optionName); + } + + if ((len > 1) && (optionName[1] == 'k') && + (strncmp(optionName, "-keepalive", len) == 0)) { + int val = 0, ret; + + if (Tcl_GetBoolean(interp, value, &val) != TCL_OK) { + return TCL_ERROR; + } +#if defined(SO_KEEPALIVE) + ret = setsockopt(statePtr->fds.fd, SOL_SOCKET, SO_KEEPALIVE, + (const char *) &val, sizeof(int)); +#else + ret = -1; + Tcl_SetErrno(ENOTSUP); +#endif + if (ret < 0) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set socket option: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + return TCL_OK; + } + if ((len > 1) && (optionName[1] == 'n') && + (strncmp(optionName, "-nagle", len) == 0)) { + int val = 0, ret; + + if (Tcl_GetBoolean(interp, value, &val) != TCL_OK) { + return TCL_ERROR; + } + val = !val; /* Nagle ain't nodelay */ +#if defined(SOL_TCP) && defined(TCP_NODELAY) + ret = setsockopt(statePtr->fds.fd, SOL_TCP, TCP_NODELAY, + (const char *) &val, sizeof(int)); +#else + ret = -1; + Tcl_SetErrno(ENOTSUP); +#endif + if (ret < 0) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set socket option: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + return TCL_OK; + } + return Tcl_BadChannelOption(interp, optionName, "keepalive nagle"); +} + +/* + *---------------------------------------------------------------------- + * * TcpGetOptionProc -- * * Computes an option value for a TCP socket based channel, or a list of @@ -835,7 +921,7 @@ TcpHostPortList( static int TcpGetOptionProc( - void *instanceData, /* Socket state. */ + void *instanceData, /* Socket state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Name of the option to retrieve the value * for, or NULL to get all options and their @@ -846,8 +932,6 @@ TcpGetOptionProc( TcpState *statePtr = (TcpState *)instanceData; size_t len = 0; - WaitForConnect(statePtr, NULL); - if (optionName != NULL) { len = strlen(optionName); } @@ -856,6 +940,7 @@ TcpGetOptionProc( (strncmp(optionName, "-error", len) == 0)) { socklen_t optlen = sizeof(int); + WaitForConnect(statePtr, NULL); if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) { /* * Suppress errors as long as we are not done. @@ -880,6 +965,7 @@ TcpGetOptionProc( if ((len > 1) && (optionName[1] == 'c') && (strncmp(optionName, "-connecting", len) == 0)) { + WaitForConnect(statePtr, NULL); Tcl_DStringAppend(dsPtr, GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT) ? "1" : "0", TCL_INDEX_NONE); return TCL_OK; @@ -890,6 +976,7 @@ TcpGetOptionProc( address peername; socklen_t size = sizeof(peername); + WaitForConnect(statePtr, NULL); if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) { /* * In async connect output an empty string @@ -941,6 +1028,7 @@ TcpGetOptionProc( socklen_t size; int found = 0; + WaitForConnect(statePtr, NULL); if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-sockname"); Tcl_DStringStartSublist(dsPtr); @@ -974,9 +1062,46 @@ TcpGetOptionProc( } } + if ((len == 0) || ((len > 1) && (optionName[1] == 'k') && + (strncmp(optionName, "-keepalive", len) == 0))) { + socklen_t size; + int opt = 0; + + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-keepalive"); + } +#if defined(SO_KEEPALIVE) + getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_KEEPALIVE, + (char *) &opt, &size); +#endif + Tcl_DStringAppendElement(dsPtr, opt ? "1" : "0"); + if (len > 0) { + return TCL_OK; + } + } + + if ((len == 0) || ((len > 1) && (optionName[1] == 'n') && + (strncmp(optionName, "-nagle", len) == 0))) { + socklen_t size; + int opt = 0; + + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-nagle"); + } +#if defined(SOL_TCP) && defined(TCP_NODELAY) + getsockopt(statePtr->fds.fd, SOL_TCP, TCP_NODELAY, + (char *) &opt, &size); +#endif + opt = !opt; /* Nagle ain't nodelay */ + Tcl_DStringAppendElement(dsPtr, opt ? "1" : "0"); + if (len > 0) { + return TCL_OK; + } + } + if (len > 0) { return Tcl_BadChannelOption(interp, optionName, - "connecting peername sockname"); + "connecting keepalive nagle peername sockname"); } return TCL_OK; @@ -1351,7 +1476,7 @@ TcpConnect( } /* - * We need to forward the writable event that brought us here, bcasue + * We need to forward the writable event that brought us here, because * upon reading of getsockopt(SO_ERROR), at least some OSes clear the * writable state from the socket, and so a subsequent select() on * behalf of a script level [fileevent] would not fire. It doesn't diff --git a/win/tclWinSock.c b/win/tclWinSock.c index e806423..66d6b61 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -55,13 +55,6 @@ #endif /* - * Support for control over sockets' KEEPALIVE and NODELAY behavior is - * currently disabled. - */ - -#undef TCL_FEATURE_KEEPALIVE_NAGLE - -/* * Helper macros to make parts of this file clearer. The macros do exactly * what they say on the tin. :-) They also only ever refer to their arguments * once, and so can be used without regard to side effects. @@ -589,7 +582,7 @@ TcpBlockModeProc( * * Side effects: * Processes socket events off the system queue. May process - * asynchroneous connect. + * asynchronous connect. * *---------------------------------------------------------------------- */ @@ -1185,14 +1178,15 @@ TcpSetOptionProc( ClientData instanceData, /* Socket state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Name of the option to set. */ - TCL_UNUSED(const char *) /*value*/) /* New value for option. */ + const char *value) /* New value for option. */ { -#ifdef TCL_FEATURE_KEEPALIVE_NAGLE - TcpState *statePtr = instanceData; + TcpState *statePtr = (TcpState *)instanceData; SOCKET sock; -#else - (void)instanceData; -#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ + size_t len = 0; + + if (optionName != NULL) { + len = strlen(optionName); + } /* * Check that WinSock is initialized; do not call it if not, to prevent @@ -1208,20 +1202,17 @@ TcpSetOptionProc( return TCL_ERROR; } -#ifdef TCL_FEATURE_KEEPALIVE_NAGLE -#error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat statePtr->sockets as single fd or list" sock = statePtr->sockets->fd; - if (!strcasecmp(optionName, "-keepalive")) { - BOOL val = FALSE; + if ((len > 1) && (optionName[1] == 'k') && + (strncmp(optionName, "-keepalive", len) == 0)) { + BOOL val; int boolVar, rtn; if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) { return TCL_ERROR; } - if (boolVar) { - val = TRUE; - } + val = boolVar ? TRUE : FALSE; rtn = setsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (const char *) &val, sizeof(BOOL)); if (rtn != 0) { @@ -1234,16 +1225,16 @@ TcpSetOptionProc( return TCL_ERROR; } return TCL_OK; - } else if (!strcasecmp(optionName, "-nagle")) { - BOOL val = FALSE; + } + if ((len > 1) && (optionName[1] == 'n') && + (strncmp(optionName, "-nagle", len) == 0)) { + BOOL val; int boolVar, rtn; if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) { return TCL_ERROR; } - if (!boolVar) { - val = TRUE; - } + val = boolVar ? FALSE : TRUE; rtn = setsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (const char *) &val, sizeof(BOOL)); if (rtn != 0) { @@ -1257,11 +1248,7 @@ TcpSetOptionProc( } return TCL_OK; } - return Tcl_BadChannelOption(interp, optionName, "keepalive nagle"); -#else - return Tcl_BadChannelOption(interp, optionName, ""); -#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ } /* @@ -1536,54 +1523,43 @@ TcpGetOptionProc( } } -#ifdef TCL_FEATURE_KEEPALIVE_NAGLE - if (len == 0 || !strncmp(optionName, "-keepalive", len)) { + if ((len == 0) || ((len > 1) && (optionName[1] == 'k') && + (strncmp(optionName, "-keepalive", len) == 0))) { int optlen; BOOL opt = FALSE; if (len == 0) { + sock = statePtr->sockets->fd; Tcl_DStringAppendElement(dsPtr, "-keepalive"); } optlen = sizeof(BOOL); getsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (char *)&opt, &optlen); - if (opt) { - Tcl_DStringAppendElement(dsPtr, "1"); - } else { - Tcl_DStringAppendElement(dsPtr, "0"); - } + Tcl_DStringAppendElement(dsPtr, opt ? "1" : "0"); if (len > 0) { return TCL_OK; } } - if (len == 0 || !strncmp(optionName, "-nagle", len)) { + if ((len == 0) || ((len > 1) && (optionName[1] == 'n') && + (strncmp(optionName, "-nagle", len) == 0))) { int optlen; BOOL opt = FALSE; if (len == 0) { + sock = statePtr->sockets->fd; Tcl_DStringAppendElement(dsPtr, "-nagle"); } optlen = sizeof(BOOL); getsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (char *)&opt, &optlen); - if (opt) { - Tcl_DStringAppendElement(dsPtr, "0"); - } else { - Tcl_DStringAppendElement(dsPtr, "1"); - } + Tcl_DStringAppendElement(dsPtr, opt ? "0" : "1"); if (len > 0) { return TCL_OK; } } -#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ if (len > 0) { -#ifdef TCL_FEATURE_KEEPALIVE_NAGLE - return Tcl_BadChannelOption(interp, optionName, - "connecting peername sockname keepalive nagle"); -#else return Tcl_BadChannelOption(interp, optionName, - "connecting peername sockname"); -#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ + "connecting keepalive nagle peername sockname"); } return TCL_OK; @@ -1672,8 +1648,6 @@ TcpGetHandleProc( *handlePtr = INT2PTR(statePtr->sockets->fd); return TCL_OK; } - - /* *---------------------------------------------------------------------- @@ -1810,7 +1784,7 @@ TcpConnect( } /* - * For asynchroneous connect set the socket in nonblocking mode + * For asynchronous connect set the socket in nonblocking mode * and activate connect notification */ @@ -1925,7 +1899,7 @@ TcpConnect( /* * Clear the tsd socket list pointer if we did not wait for - * the FD_CONNECT asynchroneously + * the FD_CONNECT asynchronously */ tsdPtr->pendingTcpState = NULL; -- cgit v0.12 From 15640f92409edd55e33844d0b7c298ebce907ca3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 4 Sep 2022 20:15:06 +0000 Subject: Fix testcase iocmd-8.15 --- tests/ioCmd.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 3aeeb61..f911846 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -294,7 +294,7 @@ removeFile fconfigure.dummy test iocmd-8.14 {fconfigure command} { fconfigure stdin -buffers } 4096 -test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOrWin} -setup { +test iocmd-8.15 {fconfigure command / tcp channel} -constraints {socket unixOrWin} -setup { set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] set port [lindex [fconfigure $srv -sockname] 2] proc iocmdSRV {sock ip port} {close $sock} @@ -306,7 +306,7 @@ test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOr close $srv unset cli srv port rename iocmdSRV {} -} -returnCodes error -result [expectedOpts "-blah" {-connecting -keepalive -peername -nagle -sockname}] +} -returnCodes error -result [expectedOpts "-blah" {-connecting -keepalive -nagle -peername -sockname}] test iocmd-8.16 {fconfigure command / tcp channel} -constraints socket -setup { set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] set port [lindex [fconfigure $srv -sockname] 2] -- cgit v0.12 From ad1c9644ec994dee42c667d8562d68227437737e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 6 Sep 2022 13:35:30 +0000 Subject: Correct Tcl_DriverWideSeekProc documentation, matching implementation --- doc/CrtChannel.3 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/CrtChannel.3 b/doc/CrtChannel.3 index 968328c..e84c29a 100644 --- a/doc/CrtChannel.3 +++ b/doc/CrtChannel.3 @@ -530,9 +530,9 @@ operations will be applied. \fIWideSeekProc\fR must match the following prototype: .PP .CS -typedef Tcl_WideInt \fBTcl_DriverWideSeekProc\fR( +typedef long long \fBTcl_DriverWideSeekProc\fR( void *\fIinstanceData\fR, - Tcl_WideInt \fIoffset\fR, + long long \fIoffset\fR, int \fIseekMode\fR, int *\fIerrorCodePtr\fR); .CE -- cgit v0.12 From d12caa5cd97a62ef81fab89e63cf5d006c628b46 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 7 Sep 2022 14:47:52 +0000 Subject: Tcl_Size -> size_t (twice) --- generic/tclInt.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 183452e..4af38f3 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2450,7 +2450,7 @@ typedef struct ListStore { Tcl_Size firstUsed; /* Index of first slot in use within slots[] */ Tcl_Size numUsed; /* Number of slots in use (starting firstUsed) */ Tcl_Size numAllocated; /* Total number of slots[] array slots. */ - Tcl_Size refCount; /* Number of references to this instance */ + size_t refCount; /* Number of references to this instance */ int flags; /* LISTSTORE_* flags */ Tcl_Obj *slots[TCLFLEXARRAY]; /* Variable size array. Grown as needed */ } ListStore; @@ -2474,7 +2474,7 @@ typedef struct ListStore { typedef struct ListSpan { Tcl_Size spanStart; /* Starting index of the span */ Tcl_Size spanLength; /* Number of elements in the span */ - Tcl_Size refCount; /* Count of references to this span record */ + size_t refCount; /* Count of references to this span record */ } ListSpan; #ifndef LIST_SPAN_THRESHOLD /* May be set on build line */ #define LIST_SPAN_THRESHOLD 101 -- cgit v0.12 From d6b88eb7975e3dc13b386679c53bb4a6f7f7f616 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 9 Sep 2022 12:42:04 +0000 Subject: Change 'skip' argument from int to size_t. Should have been part of TIP #630 (TclOO commands > 2^31 (for 8.7)) --- doc/Class.3 | 2 +- doc/Method.3 | 2 +- generic/tclOO.c | 25 +++++++++++-------------- generic/tclOO.decls | 4 ++-- generic/tclOODecls.h | 8 ++++---- generic/tclOOInt.h | 4 ++-- 6 files changed, 21 insertions(+), 24 deletions(-) diff --git a/doc/Class.3 b/doc/Class.3 index 0d50e95..c029595 100644 --- a/doc/Class.3 +++ b/doc/Class.3 @@ -85,7 +85,7 @@ already exist. The number of elements in the \fIobjv\fR array. .AP "Tcl_Obj *const" *objv in The arguments to the command to create the instance of the class. -.AP int skip in +.AP size_t skip in The number of arguments at the start of the argument array, \fIobjv\fR, that are not arguments to any constructors. This allows the generation of correct error messages even when complicated calling patterns are used (e.g., via the diff --git a/doc/Method.3 b/doc/Method.3 index 9096734..c3a6b64 100644 --- a/doc/Method.3 +++ b/doc/Method.3 @@ -99,7 +99,7 @@ retain a reference to a context. The number of arguments to pass to the method implementation. .AP "Tcl_Obj *const" *objv in An array of arguments to pass to the method implementation. -.AP int skip in +.AP size_t skip in The number of arguments passed to the method implementation that do not represent "real" arguments. .BE diff --git a/generic/tclOO.c b/generic/tclOO.c index 5385f08..0d9c7da 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -1667,16 +1667,15 @@ Tcl_NewObjectInstance( const char *nsNameStr, /* Name of namespace to create inside object, * or NULL to ask the code to pick its own * unique name. */ - size_t objc1, /* Number of arguments. Negative value means + size_t objc, /* Number of arguments. Negative value means * do not call constructor. */ Tcl_Obj *const *objv, /* Argument list. */ - int skip) /* Number of arguments to _not_ pass to the + size_t skip) /* Number of arguments to _not_ pass to the * constructor. */ { Class *classPtr = (Class *) cls; Object *oPtr; ClientData clientData[4]; - int objc = objc1; oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); if (oPtr == NULL) { @@ -1688,7 +1687,7 @@ Tcl_NewObjectInstance( * used for object cloning only. */ - if (objc >= 0) { + if (objc != TCL_INDEX_NONE) { CallContext *contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL); @@ -1736,10 +1735,10 @@ TclNRNewObjectInstance( const char *nsNameStr, /* Name of namespace to create inside object, * or NULL to ask the code to pick its own * unique name. */ - int objc, /* Number of arguments. Negative value means + size_t objc, /* Number of arguments. Negative value means * do not call constructor. */ Tcl_Obj *const *objv, /* Argument list. */ - int skip, /* Number of arguments to _not_ pass to the + size_t skip, /* Number of arguments to _not_ pass to the * constructor. */ Tcl_Object *objectPtr) /* Place to write the object reference upon * successful allocation. */ @@ -1755,11 +1754,11 @@ TclNRNewObjectInstance( } /* - * Run constructors, except when objc < 0 (a special flag case used for + * Run constructors, except when objc == TCL_INDEX_NONE (a special flag case used for * object cloning only). If there aren't any constructors, we do nothing. */ - if (objc < 0) { + if (objc == TCL_INDEX_NONE) { *objectPtr = (Tcl_Object) oPtr; return TCL_OK; } @@ -2628,7 +2627,7 @@ int TclOOObjectCmdCore( Object *oPtr, /* The object being invoked. */ Tcl_Interp *interp, /* The interpreter containing the object. */ - size_t objc1, /* How many arguments are being passed in. */ + size_t objc, /* How many arguments are being passed in. */ Tcl_Obj *const *objv, /* The array of arguments. */ int flags, /* Whether this is an invocation through the * public or the private command interface. */ @@ -2643,14 +2642,13 @@ TclOOObjectCmdCore( Object *callerObjPtr = NULL; Class *callerClsPtr = NULL; int result; - int objc = objc1; /* * If we've no method name, throw this directly into the unknown * processing. */ - if (objc < 2) { + if (objc + 1 < 3) { flags |= FORCE_UNKNOWN; methodNamePtr = NULL; goto noMapping; @@ -2801,15 +2799,14 @@ int Tcl_ObjectContextInvokeNext( Tcl_Interp *interp, Tcl_ObjectContext context, - size_t objc1, + size_t objc, Tcl_Obj *const *objv, - int skip) + size_t skip) { CallContext *contextPtr = (CallContext *) context; size_t savedIndex = contextPtr->index; size_t savedSkip = contextPtr->skip; int result; - int objc = objc1; if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) { /* diff --git a/generic/tclOO.decls b/generic/tclOO.decls index d9adb4d..3783adf 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -69,7 +69,7 @@ declare 12 { declare 13 { Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, size_t objc, - Tcl_Obj *const *objv, int skip) + Tcl_Obj *const *objv, size_t skip) } declare 14 { int Tcl_ObjectDeleted(Tcl_Object object) @@ -105,7 +105,7 @@ declare 22 { declare 23 { int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, size_t objc, Tcl_Obj *const *objv, - int skip) + size_t skip) } declare 24 { Tcl_ObjectMapMethodNameProc *Tcl_ObjectGetMethodNameMapper( diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 7cfa039..0c141fe 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -70,7 +70,7 @@ TCLAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, TCLAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, size_t objc, - Tcl_Obj *const *objv, int skip); + Tcl_Obj *const *objv, size_t skip); /* 14 */ TCLAPI int Tcl_ObjectDeleted(Tcl_Object object); /* 15 */ @@ -100,7 +100,7 @@ TCLAPI void Tcl_ObjectSetMetadata(Tcl_Object object, /* 23 */ TCLAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, size_t objc, - Tcl_Obj *const *objv, int skip); + Tcl_Obj *const *objv, size_t skip); /* 24 */ TCLAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( Tcl_Object object); @@ -159,7 +159,7 @@ typedef struct TclOOStubs { Tcl_Obj * (*tcl_MethodName) (Tcl_Method method); /* 10 */ Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, void *clientData); /* 11 */ Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, void *clientData); /* 12 */ - Tcl_Object (*tcl_NewObjectInstance) (Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, size_t objc, Tcl_Obj *const *objv, int skip); /* 13 */ + Tcl_Object (*tcl_NewObjectInstance) (Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, size_t objc, Tcl_Obj *const *objv, size_t skip); /* 13 */ int (*tcl_ObjectDeleted) (Tcl_Object object); /* 14 */ int (*tcl_ObjectContextIsFiltering) (Tcl_ObjectContext context); /* 15 */ Tcl_Method (*tcl_ObjectContextMethod) (Tcl_ObjectContext context); /* 16 */ @@ -169,7 +169,7 @@ typedef struct TclOOStubs { void (*tcl_ClassSetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, void *metadata); /* 20 */ void * (*tcl_ObjectGetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 21 */ void (*tcl_ObjectSetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, void *metadata); /* 22 */ - int (*tcl_ObjectContextInvokeNext) (Tcl_Interp *interp, Tcl_ObjectContext context, size_t objc, Tcl_Obj *const *objv, int skip); /* 23 */ + int (*tcl_ObjectContextInvokeNext) (Tcl_Interp *interp, Tcl_ObjectContext context, size_t objc, Tcl_Obj *const *objv, size_t skip); /* 23 */ Tcl_ObjectMapMethodNameProc * (*tcl_ObjectGetMethodNameMapper) (Tcl_Object object); /* 24 */ void (*tcl_ObjectSetMethodNameMapper) (Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 25 */ void (*tcl_ClassSetConstructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 26 */ diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 2ef4752..b7fb34d 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -505,8 +505,8 @@ MODULE_SCOPE Tcl_Method TclNewMethod(Tcl_Interp *interp, Tcl_Class cls, void *clientData); MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, - const char *nsNameStr, int objc, - Tcl_Obj *const *objv, int skip, + const char *nsNameStr, size_t objc, + Tcl_Obj *const *objv, size_t skip, Tcl_Object *objectPtr); MODULE_SCOPE Object * TclNewObjectInstanceCommon(Tcl_Interp *interp, Class *classPtr, -- cgit v0.12 From 8ad68e4ae6be99da8761d19c3755707dd0f08f95 Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 9 Sep 2022 17:09:10 +0000 Subject: TIP633: fconfigure -tolerantencoding: correct/add command interface tests --- tests/io.test | 15 +++++++++++++++ tests/ioCmd.test | 12 ++++++------ tests/socket.test | 2 +- tests/zlib.test | 4 ++-- 4 files changed, 24 insertions(+), 9 deletions(-) diff --git a/tests/io.test b/tests/io.test index b6c4fb5..653c02b 100644 --- a/tests/io.test +++ b/tests/io.test @@ -8985,6 +8985,21 @@ test io-75.2 {unrepresentable character write passes and is replaced by ?} -setu removeFile io-75.2 } -returnCodes ok -result "A?" +test io-75.3 {check if -tolerantencoding option is saved} -setup { + set fn [makeFile {} io-75.3] + set f [open $fn w] +} -body { + # the following command gets in result error in TCL 9.0 + fconfigure $f -encoding iso8859-1 -tolerantencoding 0 + lappend res [fconfigure $f -tolerantencoding] + fconfigure $f -encoding iso8859-1 -tolerantencoding 1 + lappend res [fconfigure $f -tolerantencoding] +} -cleanup { + close $f + removeFile io-75.3 +} -returnCodes ok -result "0 1" + + # ### ### ### ######### ######### ######### # cleanup diff --git a/tests/ioCmd.test b/tests/ioCmd.test index dbca866..908ac5a 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -245,7 +245,7 @@ test iocmd-8.7 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -translation lf} +} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -tolerantencoding 1 -translation lf} test iocmd-8.8 {fconfigure command} -setup { file delete $path(test1) set x {} @@ -257,7 +257,7 @@ test iocmd-8.8 {fconfigure command} -setup { lappend x [fconfigure $f1] } -cleanup { catch {close $f1} -} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -translation lf}} +} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -tolerantencoding 1 -translation lf}} test iocmd-8.9 {fconfigure command} -setup { file delete $path(test1) } -body { @@ -267,7 +267,7 @@ test iocmd-8.9 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf} +} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf} test iocmd-8.10 {fconfigure command} -returnCodes error -body { fconfigure a b } -result {can not find channel named "a"} @@ -1363,7 +1363,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { close $c rename foo {} set res -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -tolerantencoding 1 -translation {auto *}}} test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -1372,7 +1372,7 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -tolerantencoding 1 -translation {auto *}}} test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -1384,7 +1384,7 @@ test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -tolerantencoding 1 -translation {auto *} -bar foo -snarf x}} test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { diff --git a/tests/socket.test b/tests/socket.test index 4644e1d..c354f46 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -1071,7 +1071,7 @@ test socket_$af-7.3 {testing socket specific options} -constraints [list socket close $s update llength $l -} -result 14 +} -result 16 test socket_$af-7.4 {testing socket specific options} -constraints [list socket supported_$af] -setup { set timer [after 10000 "set x timed_out"] set l "" diff --git a/tests/zlib.test b/tests/zlib.test index 7de6d64..8c2d368 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -292,7 +292,7 @@ test zlib-8.6 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf}} test zlib-8.7 {transformation and fconfigure} -setup { set file [makeFile {} test.gz] set fd [open $file wb] @@ -302,7 +302,7 @@ test zlib-8.7 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf}} # Input is headers from fetching SPDY draft # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" -- cgit v0.12 From 77334ba0ad75d22574c957a65fff91ea17e3bc8e Mon Sep 17 00:00:00 2001 From: oehhar Date: Sun, 11 Sep 2022 08:24:21 +0000 Subject: TIP633 fconfigure -strctencoding: TCL 9 branch: prepare test cases with -strictencoding 0 and 1 --- tests/io.test | 85 +++++++++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 74 insertions(+), 11 deletions(-) diff --git a/tests/io.test b/tests/io.test index f65e221..8ff3972 100644 --- a/tests/io.test +++ b/tests/io.test @@ -8952,9 +8952,7 @@ test io-74.1 {[104f2885bb] improper cache validity check} -setup { removeFile io-74.1 } -returnCodes error -match glob -result {can not find channel named "*"} -# Note: the following tests 75.1 to 75.3 are in preparation for TCL 9.0, where -# those should result in an error result -test io-75.1 {multibyte encoding error read results in raw bytes} -setup { +test io-75.1 {multibyte encoding error read results in raw bytes (-strictencoding 0)} -setup { set fn [makeFile {} io-75.1] set f [open $fn w+] fconfigure $f -encoding binary @@ -8963,24 +8961,29 @@ test io-75.1 {multibyte encoding error read results in raw bytes} -setup { puts -nonewline $f "A\xC0\x40" flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -} -constraints knownBug -body { + fconfigure $f -encoding utf-8 -strictencoding 0 -buffering none +} -body { read $f } -cleanup { close $f removeFile io-75.1 -} -returnCodes error +} -returnCodes ok -result "A\xC0\x40" +# for TCL 9.0, the result is error -test io-75.2 {unrepresentable character write passes and is replaced by ?} -setup { +test io-75.2 {unrepresentable character write passes and is replaced by ? (-strictencoding 0)} -constraints deprecated -setup { set fn [makeFile {} io-75.2] set f [open $fn w+] - fconfigure $f -encoding iso8859-1 -} -constraints knownBug -body { + fconfigure $f -encoding iso8859-1 -strictencoding 0 +} -body { + # the following command gets in result error in TCL 9.0 puts -nonewline $f "A\u2022" + flush $f + seek $f 0 + read $f } -cleanup { close $f removeFile io-75.2 -} -returnCodes error +} -returnCodes ok -result "A?" # Incomplete sequence test. # This error may IMHO only be detected with the close. @@ -8992,15 +8995,75 @@ test io-75.3 {incomplete multibyte encoding read is ignored} -setup { puts -nonewline $f "A\xC0" flush $f seek $f 0 + fconfigure $f -encoding utf-8 -buffering none -strictencoding 0 +} -body { + set d [read $f] + close $f + set d +} -cleanup { + removeFile io-75.3 +} -returnCodes ok -result "A\xC0" + +test io-75.4 {multibyte encoding error read results in raw bytes (-strictencoding 1} -setup { + set fn [makeFile {} io-75.4] + set f [open $fn w+] + fconfigure $f -encoding binary + # In UTF-8, a byte 0xCx starts a multibyte sequence and must be followed + # by a byte > 0x7F. This is violated to get an invalid sequence. + puts -nonewline $f "A\xC0\x40" + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none +} -constraints knownBug -body { + read $f +} -cleanup { + close $f + removeFile io-75.4 +} -returnCodes error + +test io-75.5 {unrepresentable character write passes and is replaced by ? (-strictencoding 1} -setup { + set fn [makeFile {} io-75.5] + set f [open $fn w+] + fconfigure $f -encoding iso8859-1 +} -constraints knownBug -body { + puts -nonewline $f "A\u2022" +} -cleanup { + close $f + removeFile io-75.5 +} -returnCodes error + +# Incomplete sequence test. +# This error may IMHO only be detected with the close. +# But the read already returns the incomplete sequence. +test io-75.6 {incomplete multibyte encoding read is ignored (-strictencoding 1)} -setup { + set fn [makeFile {} io-75.6] + set f [open $fn w+] + fconfigure $f -encoding binary + puts -nonewline $f "A\xC0" + flush $f + seek $f 0 fconfigure $f -encoding utf-8 -buffering none } -constraints knownBug -body { set d [read $f] close $f set d } -cleanup { - removeFile io-75.3 + removeFile io-75.5 } -returnCodes error +test io-75.7 {check if -tolerantencoding option is saved} -setup { + set fn [makeFile {} io-75.7] + set f [open $fn w] +} -body { + fconfigure $f -encoding iso8859-1 -strictencoding 0 + lappend res [fconfigure $f -strictencoding] + fconfigure $f -encoding iso8859-1 -strictencoding 1 + lappend res [fconfigure $f -strictencoding] +} -cleanup { + close $f + removeFile io-75.7 +} -returnCodes ok -result "0 1" + # ### ### ### ######### ######### ######### # cleanup -- cgit v0.12 From 370f7dfa406329d5dfbf91ef4da3d647230ee99c Mon Sep 17 00:00:00 2001 From: oehhar Date: Sun, 11 Sep 2022 08:55:59 +0000 Subject: TIP633 fconfigure -strictencoding: change option name to "-strictencoding". --- generic/tclIO.c | 12 ++++++------ generic/tclIO.h | 4 ++-- tests/io.test | 14 -------------- tests/ioCmd.test | 12 ++++++------ tests/zlib.test | 4 ++-- 5 files changed, 16 insertions(+), 30 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index cf96559..0f5f9c0 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -7913,12 +7913,12 @@ Tcl_GetChannelOption( return TCL_OK; } } - if (len == 0 || HaveOpt(2, "-tolerantencoding")) { + if (len == 0 || HaveOpt(2, "-strictencoding")) { if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-tolerantencoding"); + Tcl_DStringAppendElement(dsPtr, "-strictencoding"); } Tcl_DStringAppendElement(dsPtr, - (flags & CHANNEL_ENCODING_NOCOMPLAIN) ? "1" : "0"); + (flags & CHANNEL_ENCODING_NOCOMPLAIN) ? "0" : "1"); if (len > 0) { return TCL_OK; } @@ -8179,16 +8179,16 @@ Tcl_SetChannelOption( ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_STICKY_EOF|CHANNEL_BLOCKED); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; return TCL_OK; - } else if (HaveOpt(2, "-tolerantencoding")) { + } else if (HaveOpt(2, "-strictencoding")) { int newMode; if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { return TCL_ERROR; } if (newMode) { - statePtr->flags |= CHANNEL_ENCODING_NOCOMPLAIN; - } else { statePtr->flags &= ~CHANNEL_ENCODING_NOCOMPLAIN; + } else { + statePtr->flags |= CHANNEL_ENCODING_NOCOMPLAIN; } return TCL_OK; } else if (HaveOpt(2, "-translation")) { diff --git a/generic/tclIO.h b/generic/tclIO.h index 58e0c0f..54ffe0e 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -271,8 +271,8 @@ typedef struct ChannelState { * changes. */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ -#define CHANNEL_ENCODING_NOCOMPLAIN (1<<17) /* set if option -tolerantencoding - * is set to 1 */ +#define CHANNEL_ENCODING_NOCOMPLAIN (1<<17) /* set if option -strictencoding + * is set to 0 */ #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. * Its structures are still live and diff --git a/tests/io.test b/tests/io.test index adb5620..5c45918 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9006,20 +9006,6 @@ test io-75.3 {incomplete multibyte encoding read is ignored} -setup { removeFile io-75.3 } -returnCodes ok -result "A\xC0" -test io-75.4 {check if -tolerantencoding option is saved} -setup { - set fn [makeFile {} io-75.4] - set f [open $fn w] -} -body { - # the following command gets in result error in TCL 9.0 - fconfigure $f -encoding iso8859-1 -tolerantencoding 0 - lappend res [fconfigure $f -tolerantencoding] - fconfigure $f -encoding iso8859-1 -tolerantencoding 1 - lappend res [fconfigure $f -tolerantencoding] -} -cleanup { - close $f - removeFile io-75.4 -} -returnCodes ok -result "0 1" - # ### ### ### ######### ######### ######### # cleanup diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 908ac5a..178b54a 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -245,7 +245,7 @@ test iocmd-8.7 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -tolerantencoding 1 -translation lf} +} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -strictencoding 1 -translation lf} test iocmd-8.8 {fconfigure command} -setup { file delete $path(test1) set x {} @@ -257,7 +257,7 @@ test iocmd-8.8 {fconfigure command} -setup { lappend x [fconfigure $f1] } -cleanup { catch {close $f1} -} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -tolerantencoding 1 -translation lf}} +} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -strictencoding 1 -translation lf}} test iocmd-8.9 {fconfigure command} -setup { file delete $path(test1) } -body { @@ -267,7 +267,7 @@ test iocmd-8.9 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf} +} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -strictencoding 1 -translation lf} test iocmd-8.10 {fconfigure command} -returnCodes error -body { fconfigure a b } -result {can not find channel named "a"} @@ -1363,7 +1363,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { close $c rename foo {} set res -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -tolerantencoding 1 -translation {auto *}}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 1 -translation {auto *}}} test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -1372,7 +1372,7 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -tolerantencoding 1 -translation {auto *}}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 1 -translation {auto *}}} test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -1384,7 +1384,7 @@ test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -tolerantencoding 1 -translation {auto *} -bar foo -snarf x}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 1 -translation {auto *} -bar foo -snarf x}} test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { diff --git a/tests/zlib.test b/tests/zlib.test index 8c2d368..f848b58 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -292,7 +292,7 @@ test zlib-8.6 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf}} test zlib-8.7 {transformation and fconfigure} -setup { set file [makeFile {} test.gz] set fd [open $file wb] @@ -302,7 +302,7 @@ test zlib-8.7 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -tolerantencoding 1 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf}} # Input is headers from fetching SPDY draft # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" -- cgit v0.12 From 330bdbdecea1f151f8d1f1bdb7648ce6161b795e Mon Sep 17 00:00:00 2001 From: oehhar Date: Sun, 11 Sep 2022 09:27:10 +0000 Subject: TIP633 fconfigure -strictencoding: make only "-strictencoding 0" possible on TCL 8.7 --- generic/tclIO.c | 31 +++++++++++-------------------- generic/tclIO.h | 2 -- tests/ioCmd.test | 19 +++++++++++++------ tests/zlib.test | 4 ++-- 4 files changed, 26 insertions(+), 30 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 0f5f9c0..b801441 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -1703,14 +1703,6 @@ Tcl_CreateChannel( statePtr->outputEncodingFlags = TCL_ENCODING_START; /* - * Set encoding tolerant mode as default on 8.7.x and off on TCL9.x - */ - - #if TCL_MAJOR_VERSION < 9 - statePtr->flags |= CHANNEL_ENCODING_NOCOMPLAIN; - #endif - - /* * Set the channel up initially in AUTO input translation mode to accept * "\n", "\r" and "\r\n". Output translation mode is set to a platform * specific default value. The eofChar is set to 0 for both input and @@ -7913,20 +7905,16 @@ Tcl_GetChannelOption( return TCL_OK; } } - if (len == 0 || HaveOpt(2, "-strictencoding")) { + if (len == 0 || HaveOpt(1, "-strictencoding")) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-strictencoding"); } - Tcl_DStringAppendElement(dsPtr, - (flags & CHANNEL_ENCODING_NOCOMPLAIN) ? "0" : "1"); - if (len > 0) { - return TCL_OK; - } + Tcl_DStringAppendElement(dsPtr,"0"); if (len > 0) { return TCL_OK; } } - if (len == 0 || HaveOpt(2, "-translation")) { + if (len == 0 || HaveOpt(1, "-translation")) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-translation"); } @@ -8179,19 +8167,22 @@ Tcl_SetChannelOption( ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_STICKY_EOF|CHANNEL_BLOCKED); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; return TCL_OK; - } else if (HaveOpt(2, "-strictencoding")) { + } else if (HaveOpt(1, "-strictencoding")) { int newMode; if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { return TCL_ERROR; } if (newMode) { - statePtr->flags &= ~CHANNEL_ENCODING_NOCOMPLAIN; - } else { - statePtr->flags |= CHANNEL_ENCODING_NOCOMPLAIN; + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -strictencoding: only false allowed", + -1)); + } + return TCL_ERROR; } return TCL_OK; - } else if (HaveOpt(2, "-translation")) { + } else if (HaveOpt(1, "-translation")) { const char *readMode, *writeMode; if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { diff --git a/generic/tclIO.h b/generic/tclIO.h index 54ffe0e..54aa5af 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -271,8 +271,6 @@ typedef struct ChannelState { * changes. */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ -#define CHANNEL_ENCODING_NOCOMPLAIN (1<<17) /* set if option -strictencoding - * is set to 0 */ #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. * Its structures are still live and diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 178b54a..ad4cd4e 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -245,7 +245,7 @@ test iocmd-8.7 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -strictencoding 1 -translation lf} +} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -strictencoding 0 -translation lf} test iocmd-8.8 {fconfigure command} -setup { file delete $path(test1) set x {} @@ -257,7 +257,7 @@ test iocmd-8.8 {fconfigure command} -setup { lappend x [fconfigure $f1] } -cleanup { catch {close $f1} -} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -strictencoding 1 -translation lf}} +} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -strictencoding 0 -translation lf}} test iocmd-8.9 {fconfigure command} -setup { file delete $path(test1) } -body { @@ -267,7 +267,7 @@ test iocmd-8.9 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -strictencoding 1 -translation lf} +} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -strictencoding 0 -translation lf} test iocmd-8.10 {fconfigure command} -returnCodes error -body { fconfigure a b } -result {can not find channel named "a"} @@ -369,6 +369,13 @@ test iocmd-8.20 {fconfigure command / win console channel} -constraints {nonPort } -returnCodes error -result [expectedOpts "-blah" {-inputmode}] # TODO: Test parsing of serial channel options (nonPortable, since requires an # open channel to work with). +test iocmd-8.21 {fconfigure command / -strictencoding 1 error} -setup { + # I don't know how else to open the console, but this is non-portable + set console stdin +} -body { + fconfigure $console -strictencoding 1 +} -returnCodes error -result "bad value for -strictencoding: only false allowed" + test iocmd-9.1 {eof command} { list [catch {eof} msg] $msg $::errorCode @@ -1363,7 +1370,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { close $c rename foo {} set res -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 1 -translation {auto *}}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 0 -translation {auto *}}} test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -1372,7 +1379,7 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 1 -translation {auto *}}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 0 -translation {auto *}}} test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -1384,7 +1391,7 @@ test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 1 -translation {auto *} -bar foo -snarf x}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 0 -translation {auto *} -bar foo -snarf x}} test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { diff --git a/tests/zlib.test b/tests/zlib.test index f848b58..a1c7aa4 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -292,7 +292,7 @@ test zlib-8.6 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf}} test zlib-8.7 {transformation and fconfigure} -setup { set file [makeFile {} test.gz] set fd [open $file wb] @@ -302,7 +302,7 @@ test zlib-8.7 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf}} # Input is headers from fetching SPDY draft # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" -- cgit v0.12 From 14086d3b4aca32f2aa71c2799862593f2db4e0fd Mon Sep 17 00:00:00 2001 From: oehhar Date: Sun, 11 Sep 2022 09:55:09 +0000 Subject: TIP633 fconfigure -strictencoding: TCL 9 command line implementation --- generic/tclIO.c | 25 +++++++++++++++++++++++++ generic/tclIO.h | 2 ++ tests/io.test | 26 +++++++------------------- tests/ioCmd.test | 12 ++++++------ tests/zlib.test | 4 ++-- 5 files changed, 42 insertions(+), 27 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 5317e30..d8a9760 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -7869,6 +7869,19 @@ Tcl_GetChannelOption( return TCL_OK; } } + if (len == 0 || HaveOpt(1, "-strictencoding")) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-strictencoding"); + } + Tcl_DStringAppendElement(dsPtr, + (flags & CHANNEL_ENCODING_NOCOMPLAIN) ? "0" : "1"); + if (len > 0) { + return TCL_OK; + } + if (len > 0) { + return TCL_OK; + } + } if (len == 0 || HaveOpt(1, "-translation")) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-translation"); @@ -8132,6 +8145,18 @@ Tcl_SetChannelOption( ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_STICKY_EOF|CHANNEL_BLOCKED); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; return TCL_OK; + } else if (HaveOpt(1, "-strictencoding")) { + int newMode; + + if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { + return TCL_ERROR; + } + if (newMode) { + statePtr->flags &= ~CHANNEL_ENCODING_NOCOMPLAIN; + } else { + statePtr->flags |= CHANNEL_ENCODING_NOCOMPLAIN; + } + return TCL_OK; } else if (HaveOpt(1, "-translation")) { const char *readMode, *writeMode; diff --git a/generic/tclIO.h b/generic/tclIO.h index ca6a0ac..a4128bc 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -271,6 +271,8 @@ typedef struct ChannelState { * changes. */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ +#define CHANNEL_ENCODING_NOCOMPLAIN (1<<17) /* set if option -strictencoding + * is set to 0 */ #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. * Its structures are still live and diff --git a/tests/io.test b/tests/io.test index 8ff3972..eaec685 100644 --- a/tests/io.test +++ b/tests/io.test @@ -8952,6 +8952,7 @@ test io-74.1 {[104f2885bb] improper cache validity check} -setup { removeFile io-74.1 } -returnCodes error -match glob -result {can not find channel named "*"} + test io-75.1 {multibyte encoding error read results in raw bytes (-strictencoding 0)} -setup { set fn [makeFile {} io-75.1] set f [open $fn w+] @@ -8963,14 +8964,14 @@ test io-75.1 {multibyte encoding error read results in raw bytes (-strictencodin seek $f 0 fconfigure $f -encoding utf-8 -strictencoding 0 -buffering none } -body { - read $f + set d [read $f] + expr {$d eq "A\xC0\x40"} } -cleanup { close $f removeFile io-75.1 -} -returnCodes ok -result "A\xC0\x40" -# for TCL 9.0, the result is error +} -returnCodes ok -result 1 -test io-75.2 {unrepresentable character write passes and is replaced by ? (-strictencoding 0)} -constraints deprecated -setup { +test io-75.2 {unrepresentable character write passes and is replaced by ? (-strictencoding 0)} -setup { set fn [makeFile {} io-75.2] set f [open $fn w+] fconfigure $f -encoding iso8859-1 -strictencoding 0 @@ -9025,7 +9026,7 @@ test io-75.5 {unrepresentable character write passes and is replaced by ? (-stri set fn [makeFile {} io-75.5] set f [open $fn w+] fconfigure $f -encoding iso8859-1 -} -constraints knownBug -body { +} -body { puts -nonewline $f "A\u2022" } -cleanup { close $f @@ -9043,7 +9044,7 @@ test io-75.6 {incomplete multibyte encoding read is ignored (-strictencoding 1)} flush $f seek $f 0 fconfigure $f -encoding utf-8 -buffering none -} -constraints knownBug -body { +} -body { set d [read $f] close $f set d @@ -9051,19 +9052,6 @@ test io-75.6 {incomplete multibyte encoding read is ignored (-strictencoding 1)} removeFile io-75.5 } -returnCodes error -test io-75.7 {check if -tolerantencoding option is saved} -setup { - set fn [makeFile {} io-75.7] - set f [open $fn w] -} -body { - fconfigure $f -encoding iso8859-1 -strictencoding 0 - lappend res [fconfigure $f -strictencoding] - fconfigure $f -encoding iso8859-1 -strictencoding 1 - lappend res [fconfigure $f -strictencoding] -} -cleanup { - close $f - removeFile io-75.7 -} -returnCodes ok -result "0 1" - # ### ### ### ######### ######### ######### # cleanup diff --git a/tests/ioCmd.test b/tests/ioCmd.test index dbca866..178b54a 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -245,7 +245,7 @@ test iocmd-8.7 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -translation lf} +} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -strictencoding 1 -translation lf} test iocmd-8.8 {fconfigure command} -setup { file delete $path(test1) set x {} @@ -257,7 +257,7 @@ test iocmd-8.8 {fconfigure command} -setup { lappend x [fconfigure $f1] } -cleanup { catch {close $f1} -} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -translation lf}} +} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -strictencoding 1 -translation lf}} test iocmd-8.9 {fconfigure command} -setup { file delete $path(test1) } -body { @@ -267,7 +267,7 @@ test iocmd-8.9 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf} +} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -strictencoding 1 -translation lf} test iocmd-8.10 {fconfigure command} -returnCodes error -body { fconfigure a b } -result {can not find channel named "a"} @@ -1363,7 +1363,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { close $c rename foo {} set res -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 1 -translation {auto *}}} test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -1372,7 +1372,7 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 1 -translation {auto *}}} test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -1384,7 +1384,7 @@ test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 1 -translation {auto *} -bar foo -snarf x}} test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { diff --git a/tests/zlib.test b/tests/zlib.test index 7de6d64..f848b58 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -292,7 +292,7 @@ test zlib-8.6 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf}} test zlib-8.7 {transformation and fconfigure} -setup { set file [makeFile {} test.gz] set fd [open $file wb] @@ -302,7 +302,7 @@ test zlib-8.7 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf}} # Input is headers from fetching SPDY draft # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" -- cgit v0.12 From 32439d945eea3cc4754f2779090075c16256f18a Mon Sep 17 00:00:00 2001 From: oehhar Date: Sun, 11 Sep 2022 13:45:04 +0000 Subject: Ticket [6978c01b65]: write not encodable character->report to script level Test io-75.5 now ok. --- generic/tclIO.c | 13 +++++++++++++ tests/io.test | 4 ++-- 2 files changed, 15 insertions(+), 2 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 5317e30..732e103 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4356,6 +4356,19 @@ Write( statePtr->outputEncodingFlags &= ~TCL_ENCODING_START; + /* + * See io-75.2, TCL bug 6978c01b65. + * Check, if an encoding error occured and should be reported to the + * script level. + * This happens, if a written character may not be represented by the + * current output encoding and strict encoding is active.hao_ + */ + + if (result == TCL_CONVERT_UNKNOWN) { + Tcl_SetErrno(EILSEQ); + return -1; + } + if ((result != TCL_OK) && (srcRead + dstWrote == 0)) { /* * We're reading from invalid/incomplete UTF-8. diff --git a/tests/io.test b/tests/io.test index 8b93317..9204208 100644 --- a/tests/io.test +++ b/tests/io.test @@ -8977,7 +8977,7 @@ test io-75.5 {unrepresentable character write passes and is replaced by ?} -setu set fn [makeFile {} io-75.5] set f [open $fn w+] fconfigure $f -encoding iso8859-1 -} -constraints knownBug -body { +} -body { puts -nonewline $f "A\u2022" } -body { puts -nonewline $f "A\u2022" @@ -8987,7 +8987,7 @@ test io-75.5 {unrepresentable character write passes and is replaced by ?} -setu } -cleanup { close $f removeFile io-75.5 -} -returnCodes error +} -returnCodes error -match glob -result {error writing "*": illegal byte sequence} # Incomplete sequence test. # This error may IMHO only be detected with the close. -- cgit v0.12 From 8f0f3b11657ba48eee382942394b7741af6b02cf Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 11 Sep 2022 20:48:49 +0000 Subject: Change io-75.5 to test for both written output and which exception is thrown. This shows the bug is not fixed yet .... :-( --- tests/io.test | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/io.test b/tests/io.test index 9204208..3c7811a 100644 --- a/tests/io.test +++ b/tests/io.test @@ -8977,17 +8977,17 @@ test io-75.5 {unrepresentable character write passes and is replaced by ?} -setu set fn [makeFile {} io-75.5] set f [open $fn w+] fconfigure $f -encoding iso8859-1 -} -body { +} -constraints knownBug -body { puts -nonewline $f "A\u2022" } -body { - puts -nonewline $f "A\u2022" + catch {puts -nonewline $f "A\u2022"} msg flush $f seek $f 0 - read $f + list [read $f] $msg } -cleanup { close $f removeFile io-75.5 -} -returnCodes error -match glob -result {error writing "*": illegal byte sequence} +} -match glob -result [list {A} {error writing "*": illegal byte sequence}] # Incomplete sequence test. # This error may IMHO only be detected with the close. -- cgit v0.12 From f5846ef8f5f21d1aad31894ecee56c0c5cd5c3c1 Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 12 Sep 2022 10:47:30 +0000 Subject: TIP633 fconfigure -strictencoding: implement write -strictencoding 0. --- generic/tclIO.c | 10 ++++++++++ tests/io.test | 2 +- 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 37bef84..4715954 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4345,6 +4345,16 @@ Write( } dst = InsertPoint(bufPtr); dstLen = SpaceLeft(bufPtr); + + /* + * Transfer encoding strict option to the encoding flags + */ + + if (statePtr->flags & CHANNEL_ENCODING_NOCOMPLAIN) { + statePtr->outputEncodingFlags |= TCL_ENCODING_NOCOMPLAIN; + } else { + statePtr->outputEncodingFlags &= ~TCL_ENCODING_NOCOMPLAIN; + } result = Tcl_UtfToExternal(NULL, encoding, src, srcLimit, statePtr->outputEncodingFlags, diff --git a/tests/io.test b/tests/io.test index aeec781..dbb74f0 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9014,7 +9014,7 @@ test io-75.4 {multibyte encoding error read results in raw bytes (-strictencodin flush $f seek $f 0 fconfigure $f -encoding utf-8 -buffering none -} -constraints knownBug -body { +} -body { read $f } -cleanup { close $f -- cgit v0.12 From c36fa478b248c2d1444e72ff0a27edc1fddbb208 Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 12 Sep 2022 10:59:44 +0000 Subject: TIP633 fconfigure -strictencoding: move transfer over the loop. Adapt test suite to use hex results to prevent blocking on console output. --- generic/tclIO.c | 20 ++++++++++---------- tests/io.test | 10 ++++++---- 2 files changed, 16 insertions(+), 14 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 4715954..c2f6add 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4308,6 +4308,16 @@ Write( } /* + * Transfer encoding strict option to the encoding flags + */ + + if (statePtr->flags & CHANNEL_ENCODING_NOCOMPLAIN) { + statePtr->outputEncodingFlags |= TCL_ENCODING_NOCOMPLAIN; + } else { + statePtr->outputEncodingFlags &= ~TCL_ENCODING_NOCOMPLAIN; + } + + /* * Write the terminated escape sequence even if srcLen is 0. */ @@ -4346,16 +4356,6 @@ Write( dst = InsertPoint(bufPtr); dstLen = SpaceLeft(bufPtr); - /* - * Transfer encoding strict option to the encoding flags - */ - - if (statePtr->flags & CHANNEL_ENCODING_NOCOMPLAIN) { - statePtr->outputEncodingFlags |= TCL_ENCODING_NOCOMPLAIN; - } else { - statePtr->outputEncodingFlags &= ~TCL_ENCODING_NOCOMPLAIN; - } - result = Tcl_UtfToExternal(NULL, encoding, src, srcLimit, statePtr->outputEncodingFlags, &statePtr->outputEncodingState, dst, diff --git a/tests/io.test b/tests/io.test index dbb74f0..479695d 100644 --- a/tests/io.test +++ b/tests/io.test @@ -8964,11 +8964,12 @@ test io-75.1 {multibyte encoding error read results in raw bytes (-strictencodin fconfigure $f -encoding utf-8 -strictencoding 0 -buffering none } -body { set d [read $f] - expr {$d eq "A\xC0\x40"} + binary scan $d H* hd + set hd } -cleanup { close $f removeFile io-75.1 -} -returnCodes ok -result 1 +} -returnCodes ok -result "41C040" test io-75.2 {unrepresentable character write passes and is replaced by ? (-strictencoding 0)} -setup { set fn [makeFile {} io-75.2] @@ -8999,10 +9000,11 @@ test io-75.3 {incomplete multibyte encoding read is ignored} -setup { } -body { set d [read $f] close $f - set d + binary scan $d H* hd + set hd } -cleanup { removeFile io-75.3 -} -returnCodes ok -result "A\xC0" +} -returnCodes ok -result "41C0" test io-75.4 {multibyte encoding error read results in raw bytes (-strictencoding 1} -setup { set fn [makeFile {} io-75.4] -- cgit v0.12 From 393743bb7088f57b28cd5f98d2c9f70189807a2e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 12 Sep 2022 20:41:29 +0000 Subject: Start TIP #346 implementation: For now only \xC0\x80 --- generic/tcl.h | 1 + generic/tclCmdAH.c | 22 ++++++++++++++++------ generic/tclEncoding.c | 8 ++++++-- tests/cmdAH.test | 24 ++++++++++++------------ tests/encoding.test | 4 ++-- tests/safe.test | 8 ++++---- 6 files changed, 41 insertions(+), 26 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index f17d43e..acff803 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2118,6 +2118,7 @@ typedef struct Tcl_EncodingType { #define TCL_ENCODING_CHAR_LIMIT 0x10 #define TCL_ENCODING_MODIFIED 0x20 #define TCL_ENCODING_NOCOMPLAIN 0x40 +#define TCL_ENCODING_STRICT 0x44 /* * The following definitions are the error codes returned by the conversion diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 28fc210..572a995 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -564,8 +564,10 @@ EncodingConvertfromObjCmd( * 2) encoding data -> objc = 3 * 3) -nocomplain data -> objc = 3 * 4) -nocomplain encoding data -> objc = 4 - * 5) -failindex val data -> objc = 4 - * 6) -failindex val encoding data -> objc = 5 + * 5) -strict data -> objc = 3 + * 6) -strict encoding data -> objc = 4 + * 7) -failindex val data -> objc = 4 + * 8) -failindex val encoding data -> objc = 5 */ if (objc == 2) { @@ -579,6 +581,10 @@ EncodingConvertfromObjCmd( && !strncmp(bytesPtr, "-nocomplain", strlen(bytesPtr))) { flags = TCL_ENCODING_NOCOMPLAIN; objcUnprocessed--; + } else if (bytesPtr[0] == '-' && bytesPtr[1] == 's' + && !strncmp(bytesPtr, "-strict", strlen(bytesPtr))) { + flags = TCL_ENCODING_STRICT; + objcUnprocessed--; } else if (bytesPtr[0] == '-' && bytesPtr[1] == 'f' && !strncmp(bytesPtr, "-failindex", strlen(bytesPtr))) { /* at least two additional arguments needed */ @@ -603,7 +609,7 @@ EncodingConvertfromObjCmd( } } else { encConvFromError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-failindex var? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"); return TCL_ERROR; } @@ -621,7 +627,7 @@ EncodingConvertfromObjCmd( } result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, flags, &ds); - if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (result != TCL_INDEX_NONE)) { + if ((!(flags & TCL_ENCODING_NOCOMPLAIN) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)) && (result != TCL_INDEX_NONE)) { if (failVarObj != NULL) { if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; @@ -714,6 +720,10 @@ EncodingConverttoObjCmd( && !strncmp(stringPtr, "-nocomplain", strlen(stringPtr))) { flags = TCL_ENCODING_NOCOMPLAIN; objcUnprocessed--; + } else if (stringPtr[0] == '-' && stringPtr[1] == 's' + && !strncmp(stringPtr, "-strict", strlen(stringPtr))) { + flags = TCL_ENCODING_STRICT; + objcUnprocessed--; } else if (stringPtr[0] == '-' && stringPtr[1] == 'f' && !strncmp(stringPtr, "-failindex", strlen(stringPtr))) { /* at least two additional arguments needed */ @@ -738,7 +748,7 @@ EncodingConverttoObjCmd( } } else { encConvToError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-failindex var? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"); return TCL_ERROR; } @@ -749,7 +759,7 @@ EncodingConverttoObjCmd( stringPtr = TclGetStringFromObj(data, &length); result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, flags, &ds); - if (!(flags & TCL_ENCODING_NOCOMPLAIN) && (result != TCL_INDEX_NONE)) { + if ((!(flags & TCL_ENCODING_NOCOMPLAIN) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)) && (result != TCL_INDEX_NONE)) { if (failVarObj != NULL) { /* I hope, wide int will cover size_t data type */ if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) { diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 0ce75b4..9c4b5ce 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2288,7 +2288,7 @@ BinaryProc( */ #if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) -# define STOPONERROR !(flags & TCL_ENCODING_NOCOMPLAIN) +# define STOPONERROR (!(flags & TCL_ENCODING_NOCOMPLAIN) || (flags & TCL_ENCODING_STOPONERROR)) #else # define STOPONERROR (flags & TCL_ENCODING_STOPONERROR) #endif @@ -2359,10 +2359,14 @@ UtfToUtfProc( *dst++ = *src++; } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) - && (UCHAR(src[1]) == 0x80) && !(flags & TCL_ENCODING_MODIFIED)) { + && (UCHAR(src[1]) == 0x80) && (!(flags & TCL_ENCODING_MODIFIED) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT))) { /* * Convert 0xC080 to real nulls when we are in output mode. */ + if (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)) { + result = TCL_CONVERT_UNKNOWN; + break; + } *dst++ = 0; src += 2; diff --git a/tests/cmdAH.test b/tests/cmdAH.test index ab1a8e6..64991af 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -178,7 +178,7 @@ test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { } -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto -} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto foo bar } -result {unknown encoding "foo"} @@ -200,7 +200,7 @@ test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { } -result 8C test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom foo bar } -result {unknown encoding "foo"} @@ -237,10 +237,10 @@ test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup { test cmdAH-4.14.1 {Syntax error, -nocomplain and -failindex, no encoding} -body { encoding convertfrom -nocomplain -failindex 2 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.14.2 {Syntax error, -nocomplain and -failindex, no encoding} -body { encoding convertto -nocomplain -failindex 2 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.15.1 {Syntax error, -failindex and -nocomplain, no encoding} -body { encoding convertfrom -failindex 2 -nocomplain ABC } -returnCodes 1 -result {unknown encoding "-nocomplain"} @@ -249,19 +249,19 @@ test cmdAH-4.15.2 {Syntax error, -failindex and -nocomplain, no encoding} -body } -returnCodes 1 -result {unknown encoding "-nocomplain"} test cmdAH-4.16.1 {Syntax error, -nocomplain and -failindex, encoding} -body { encoding convertfrom -nocomplain -failindex 2 utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.16.2 {Syntax error, -nocomplain and -failindex, encoding} -body { encoding convertto -nocomplain -failindex 2 utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.17.1 {Syntax error, -failindex and -nocomplain, encoding} -body { encoding convertfrom -failindex 2 -nocomplain utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.17.2 {Syntax error, -failindex and -nocomplain, encoding} -body { encoding convertto -failindex 2 -nocomplain utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.18.1 {Syntax error, -failindex with no var, no encoding} -body { encoding convertfrom -failindex ABC -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.18.2 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { proc encoding_test {} { encoding convertfrom -failindex ABC @@ -269,12 +269,12 @@ test cmdAH-4.18.2 {Syntax error, -failindex with no var, no encoding (byte compi } -body { # Compile and execute encoding_test -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} -cleanup { +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} -cleanup { rename encoding_test "" } test cmdAH-4.18.3 {Syntax error, -failindex with no var, no encoding} -body { encoding convertto -failindex ABC -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test cmdAH-4.18.4 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { proc encoding_test {} { encoding convertto -failindex ABC @@ -282,7 +282,7 @@ test cmdAH-4.18.4 {Syntax error, -failindex with no var, no encoding (byte compi } -body { # Compile and execute encoding_test -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-failindex var? ?encoding? data"} -cleanup { +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} -cleanup { rename encoding_test "" } test cmdAH-4.19.1 {convertrom -failindex with correct data} -body { diff --git a/tests/encoding.test b/tests/encoding.test index 6f11968..c8f409e 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -669,10 +669,10 @@ test encoding-24.21 {Parse with -nocomplain but without providing encoding} { } 1 test encoding-24.22 {Syntax error, two encodings} -body { encoding convertfrom iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test encoding-24.23 {Syntax error, two encodings} -body { encoding convertto iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} file delete [file join [temporaryDirectory] iso2022.txt] diff --git a/tests/safe.test b/tests/safe.test index fc7c814..148215a 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1269,7 +1269,7 @@ test safe-11.7 {testing safe encoding} -setup { interp eval $i encoding convertfrom } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test safe-11.7.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1278,7 +1278,7 @@ test safe-11.7.1 {testing safe encoding} -setup { } -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-failindex var? ?encoding? data" +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data" while executing "encoding convertfrom" invoked from within @@ -1291,7 +1291,7 @@ test safe-11.8 {testing safe encoding} -setup { interp eval $i encoding convertto } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test safe-11.8.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1300,7 +1300,7 @@ test safe-11.8.1 {testing safe encoding} -setup { } -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-failindex var? ?encoding? data" +} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data" while executing "encoding convertto" invoked from within -- cgit v0.12 From 2e97ff6575a090c476f6f9ca06e7f1c960f85222 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 13 Sep 2022 15:59:22 +0000 Subject: Mark 2 testcases as knownBug. Looks related to [6978c01b65] --- tests/io.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/io.test b/tests/io.test index 03ed24d..012843c 100644 --- a/tests/io.test +++ b/tests/io.test @@ -8967,7 +8967,7 @@ test io-75.6 {multibyte encoding error read results in raw bytes} -setup { flush $f seek $f 0 fconfigure $f -encoding utf-8 -buffering none -} -body { +} -constraints knownBug -body { set d [read $f] binary scan $d H* hd set hd @@ -9026,7 +9026,7 @@ test io-75.9 {shiftjis encoding error read results in raw bytes} -setup { flush $f seek $f 0 fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf -} -body { +} -constraints knownBug -body { set d [read $f] binary scan $d H* hd set hd -- cgit v0.12 From fd14473a4c83f51302ba81076ec2f9d3ce9be74b Mon Sep 17 00:00:00 2001 From: bch Date: Tue, 13 Sep 2022 21:50:17 +0000 Subject: fix logical-or markup in documentation --- doc/ListObj.3 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/ListObj.3 b/doc/ListObj.3 index 182f2fb..a0ed5c9 100644 --- a/doc/ListObj.3 +++ b/doc/ListObj.3 @@ -59,7 +59,7 @@ points to the Tcl value that will be appended to \fIlistPtr\fR. For \fBTcl_SetListObj\fR, this points to the Tcl value that will be converted to a list value containing the \fIobjc\fR elements of the array referenced by \fIobjv\fR. -.AP size_t | int *objcPtr in +.AP "size_t \&| int" *objcPtr in Points to location where \fBTcl_ListObjGetElements\fR stores the number of element values in \fIlistPtr\fR. .AP Tcl_Obj ***objvPtr out @@ -76,7 +76,7 @@ An array of pointers to values. \fBTcl_NewListObj\fR will insert these values into a new list value and \fBTcl_ListObjReplace\fR will insert them into an existing \fIlistPtr\fR. Each value will become a separate list element. -.AP size_t | int *lengthPtr out +.AP "size_t \&| int" *lengthPtr out Points to location where \fBTcl_ListObjLength\fR stores the length of the list. .AP size_t index in -- cgit v0.12 From a267b4feeba6903ec6b84d760f0dfa05812b79fe Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 14 Sep 2022 07:19:10 +0000 Subject: More logical-or markup fixes in documentation --- doc/ByteArrObj.3 | 2 +- doc/DictObj.3 | 2 +- doc/FileSystem.3 | 2 +- doc/ParseArgs.3 | 2 +- doc/SplitList.3 | 2 +- doc/SplitPath.3 | 2 +- doc/StringObj.3 | 2 +- generic/tclInt.h | 2 +- 8 files changed, 8 insertions(+), 8 deletions(-) diff --git a/doc/ByteArrObj.3 b/doc/ByteArrObj.3 index ad1eb32..69f55d6 100644 --- a/doc/ByteArrObj.3 +++ b/doc/ByteArrObj.3 @@ -43,7 +43,7 @@ overwritten by a byte-array value. For \fBTcl_GetBytesFromObj\fR, to the value from which to extract an array of bytes. .AP Tcl_Interp *interp in Interpreter to use for error reporting. -.AP "size_t | int" *numBytesPtr out +.AP "size_t \&| int" *numBytesPtr out Points to space where the number of bytes in the array may be written. Caller may pass NULL when it does not need this information. .BE diff --git a/doc/DictObj.3 b/doc/DictObj.3 index c03d267..ebff7bf 100644 --- a/doc/DictObj.3 +++ b/doc/DictObj.3 @@ -70,7 +70,7 @@ Points to a variable that will have the value from a key/value pair placed within it. For \fBTcl_DictObjFirst\fR and \fBTcl_DictObjNext\fR, this may be NULL to indicate that the caller is not interested in the value. -.AP size_t | int *sizePtr out +.AP "size_t \&| int" *sizePtr out Points to a variable that will have the number of key/value pairs contained within the dictionary placed within it. .AP Tcl_DictSearch *searchPtr in/out diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index 0975dbe..ae4f4b3 100644 --- a/doc/FileSystem.3 +++ b/doc/FileSystem.3 @@ -269,7 +269,7 @@ allowed for the \fImode\fR argument to the Tcl \fBopen\fR command. .AP int permissions in POSIX-style permission flags such as 0644. If a new file is created, these permissions will be set on the created file. -.AP size_t | int *lenPtr out +.AP "size_t \&| int" *lenPtr out If non-NULL, filled with the number of elements in the split path. .AP Tcl_Obj *basePtr in The base path on to which to join the given elements. May be NULL. diff --git a/doc/ParseArgs.3 b/doc/ParseArgs.3 index 02b52d4..6a5184f 100644 --- a/doc/ParseArgs.3 +++ b/doc/ParseArgs.3 @@ -21,7 +21,7 @@ int Where to store error messages. .AP "const Tcl_ArgvInfo" *argTable in Pointer to array of option descriptors. -.AP size_t | int *objcPtr in/out +.AP "size_t \&| int" *objcPtr in/out A pointer to variable holding number of arguments in \fIobjv\fR. Will be modified to hold number of arguments left in the unprocessed argument list stored in \fIremObjv\fR. diff --git a/doc/SplitList.3 b/doc/SplitList.3 index f56330b..6d9a9aa 100644 --- a/doc/SplitList.3 +++ b/doc/SplitList.3 @@ -38,7 +38,7 @@ Interpreter to use for error reporting. If NULL, then no error message is left. .AP "const char" *list in Pointer to a string with proper list structure. -.AP size_t | int *argcPtr out +.AP "size_t \&| int" *argcPtr out Filled in with number of elements in \fIlist\fR. .AP "const char" ***argvPtr out \fI*argvPtr\fR will be filled in with the address of an array of diff --git a/doc/SplitPath.3 b/doc/SplitPath.3 index ff16792..10e84f5 100644 --- a/doc/SplitPath.3 +++ b/doc/SplitPath.3 @@ -25,7 +25,7 @@ Tcl_PathType .AP "const char" *path in File path in a form appropriate for the current platform (see the \fBfilename\fR manual entry for acceptable forms for path names). -.AP size_t | int *argcPtr out +.AP "size_t \&| int" *argcPtr out Filled in with number of path elements in \fIpath\fR. .AP "const char" ***argvPtr out \fI*argvPtr\fR will be filled in with the address of an array of diff --git a/doc/StringObj.3 b/doc/StringObj.3 index 4991f1c..14041c5 100644 --- a/doc/StringObj.3 +++ b/doc/StringObj.3 @@ -118,7 +118,7 @@ the last one available. Points to a value to manipulate. .AP Tcl_Obj *appendObjPtr in The value to append to \fIobjPtr\fR in \fBTcl_AppendObjToObj\fR. -.AP size_t | int *lengthPtr out +.AP "size_t \&| int" *lengthPtr out The location where \fBTcl_GetStringFromObj\fR will store the length of a value's string representation. May be (int *)NULL when not used. .AP "const char" *string in diff --git a/generic/tclInt.h b/generic/tclInt.h index 1c1e797..768aedf 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4833,7 +4833,7 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; * of counting along a string of all one-byte characters. The ANSI C * "prototype" for this macro is: * - * MODULE_SCOPE void TclNumUtfCharsM(int | size_t numChars, const char *bytes, + * MODULE_SCOPE void TclNumUtfCharsM(size_t numChars, const char *bytes, * size_t numBytes); *---------------------------------------------------------------- */ -- cgit v0.12 From 184e43e860ab041daae004b1d500f0c231f3ef74 Mon Sep 17 00:00:00 2001 From: bch Date: Thu, 15 Sep 2022 04:49:33 +0000 Subject: doc - describe proper prototype -- even though they are identical signatures atm --- doc/CrtChnlHdlr.3 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/CrtChnlHdlr.3 b/doc/CrtChnlHdlr.3 index c9f4efe..ee8b411 100644 --- a/doc/CrtChnlHdlr.3 +++ b/doc/CrtChnlHdlr.3 @@ -29,7 +29,7 @@ Tcl channel such as returned by \fBTcl_CreateChannel\fR. Conditions under which \fIproc\fR should be called: OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR and \fBTCL_EXCEPTION\fR. Specify a zero value to temporarily disable an existing handler. -.AP Tcl_FileProc *proc in +.AP Tcl_ChannelProc *proc in Procedure to invoke whenever the channel indicated by \fIchannel\fR meets the conditions specified by \fImask\fR. .AP void *clientData in -- cgit v0.12 From 7a073b3366cbaab135a569a1690eda1bcfe9b8c2 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 15 Sep 2022 11:48:56 +0000 Subject: Silence compiler warnings. --- generic/tclFCmd.c | 2 +- generic/tclFileName.c | 2 -- generic/tclPathObj.c | 7 +++---- 3 files changed, 4 insertions(+), 7 deletions(-) diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 6bf34d8..89550d9 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -871,7 +871,7 @@ FileForceOption( static Tcl_Obj * FileBasename( - Tcl_Interp *interp, /* Interp, for error return. */ + TCL_UNUSED(Tcl_Interp *), /* Interp, for error return. */ Tcl_Obj *pathPtr) /* Path whose basename to extract. */ { size_t objc; diff --git a/generic/tclFileName.c b/generic/tclFileName.c index d560710..476629a 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -26,8 +26,6 @@ TclPlatformType tclPlatform = TCL_PLATFORM_UNIX; * Prototypes for local procedures defined in this file: */ -static const char * DoTildeSubst(Tcl_Interp *interp, - const char *user, Tcl_DString *resultPtr); static const char * ExtractWinRoot(const char *path, Tcl_DString *resultPtr, int offset, Tcl_PathType *typePtr); diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 2fbeea3..361fad5 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -540,7 +540,7 @@ TclFSGetPathType( Tcl_Obj * TclPathPart( - Tcl_Interp *interp, /* Used for error reporting */ + TCL_UNUSED(Tcl_Interp *), /* Used for error reporting */ Tcl_Obj *pathPtr, /* Path to take dirname of */ Tcl_PathPart portion) /* Requested portion of name */ { @@ -2174,13 +2174,12 @@ Tcl_FSEqualPaths( static int SetFsPathFromAny( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + TCL_UNUSED(Tcl_Interp *), /* Used for error reporting if not NULL. */ Tcl_Obj *pathPtr) /* The object to convert. */ { size_t len; FsPath *fsPathPtr; Tcl_Obj *transPtr; - const char *name; if (TclHasInternalRep(pathPtr, &fsPathType)) { return TCL_OK; @@ -2200,7 +2199,7 @@ SetFsPathFromAny( * cmdAH.test exercise most of the code). */ - name = Tcl_GetStringFromObj(pathPtr, &len); + Tcl_GetStringFromObj(pathPtr, &len); /* TODO: Is this needed? */ transPtr = TclJoinPath(1, &pathPtr, 1); /* -- cgit v0.12 From ddde6c7c506fc37df04bd8eea0ee4dbd3e3cae2d Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 15 Sep 2022 11:55:46 +0000 Subject: Update test results --- tests/cmdAH.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 3c78842..b52d105 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -362,7 +362,7 @@ test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { } -result {wrong # args: should be "file subcommand ?arg ...?"} test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body { file x -} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, home, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, home, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, tildeexpand, type, volumes, or writable} test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body { file exists } -result {wrong # args: should be "file exists name"} @@ -1669,7 +1669,7 @@ test cmdAH-29.6.1 { # Error conditions test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file gorp x -} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, home, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, home, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, tildeexpand, type, volumes, or writable} test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file ex x } -match glob -result {unknown or ambiguous subcommand "ex": must be *} -- cgit v0.12 From 4968ffa1ce26b16430b8237f14784242c1075a1b Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 15 Sep 2022 15:59:11 +0000 Subject: [51d5f22997] Protect against passing negative size to Tcl_NewListObj. --- generic/tclProc.c | 2 +- tests/proc.test | 7 +++++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index b846269..4d421c7 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -1431,7 +1431,7 @@ InitArgsAndLocals( varPtr->flags = 0; if (defPtr && defPtr->flags & VAR_IS_ARGS) { - Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, argObjs+i); + Tcl_Obj *listPtr = Tcl_NewListObj((argCt>i)? argCt-i : 0, argObjs+i); varPtr->value.objPtr = listPtr; Tcl_IncrRefCount(listPtr); /* Local var is a reference. */ diff --git a/tests/proc.test b/tests/proc.test index b87af57..118dca1 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -412,6 +412,13 @@ test proc-7.5 {[631b4c45df] Crash in argument processing} { unset -nocomplain val } {} +test proc-7.6 {[51d5f22997] Crash in argument processing} -cleanup { + rename foo {} +} -body { + proc foo {{x {}} {y {}} args} {} + foo +} -result {} + # cleanup catch {rename p ""} -- cgit v0.12 From 7b28b969395da897dfabb2069ebe7c7406a6983a Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 15 Sep 2022 16:45:20 +0000 Subject: Remove tilde expansion from docs. Fix comments that referenced the same. --- doc/Translate.3 | 8 ++++---- doc/exec.n | 2 +- doc/file.n | 42 ++++++------------------------------------ doc/filename.n | 20 -------------------- doc/glob.n | 10 ---------- generic/tclFileName.c | 28 ++++++++++------------------ generic/tclPathObj.c | 4 ---- 7 files changed, 21 insertions(+), 93 deletions(-) diff --git a/doc/Translate.3 b/doc/Translate.3 index 38831d3..256baec 100644 --- a/doc/Translate.3 +++ b/doc/Translate.3 @@ -9,7 +9,7 @@ .so man.macros .BS .SH NAME -Tcl_TranslateFileName \- convert file name to native form and replace tilde with home directory +Tcl_TranslateFileName \- convert file name to native form .SH SYNOPSIS .nf \fB#include \fR @@ -34,7 +34,7 @@ anything stored here. This utility procedure translates a file name to a platform-specific form which, after being converted to the appropriate encoding, is suitable for passing to the local operating system. In particular, it converts -network names into native form and does tilde substitution. +network names into native form. .PP However, with the advent of the newer \fBTcl_FSGetNormalizedPath\fR and \fBTcl_FSGetNativePath\fR, there is no longer any need to use this @@ -45,7 +45,7 @@ Finally \fBTcl_FSGetNativePath\fR does not require you to free anything afterwards. .PP If -\fBTcl_TranslateFileName\fR has to do tilde substitution or translate +\fBTcl_TranslateFileName\fR has to translate the name then it uses the dynamic string at \fI*bufferPtr\fR to hold the new string it generates. @@ -68,4 +68,4 @@ has its default empty value when \fBTcl_TranslateFileName\fR is invoked. .SH "SEE ALSO" filename(n) .SH KEYWORDS -file name, home directory, tilde, translate, user +file name, home directory, translate, user diff --git a/doc/exec.n b/doc/exec.n index 3cfc29d..1f87818 100644 --- a/doc/exec.n +++ b/doc/exec.n @@ -198,7 +198,7 @@ the commands in the pipeline will go to the application's standard error file unless redirected. .PP The first word in each command is taken as the command name; -tilde-substitution is performed on it, and if the result contains +if the result contains no slashes then the directories in the PATH environment variable are searched for an executable by the given name. diff --git a/doc/file.n b/doc/file.n index daa0ad8..c168e50 100644 --- a/doc/file.n +++ b/doc/file.n @@ -16,12 +16,10 @@ file \- Manipulate file names and attributes .BE .SH DESCRIPTION .PP -This command provides several operations on a file's name or attributes. -\fIName\fR is the name of a file; if it starts with a tilde, then tilde -substitution is done before executing the command (see the manual entry for -\fBfilename\fR for details). \fIOption\fR indicates what to do with the -file name. Any unique abbreviation for \fIoption\fR is acceptable. The -valid options are: +This command provides several operations on a file's name or attributes. The +\fIname\fR argument is the name of a file in most cases. The \fIoption\fR +argument indicates what to do with the file name. Any unique abbreviation for +\fIoption\fR is acceptable. The valid options are: .TP \fBfile atime \fIname\fR ?\fItime\fR? . @@ -145,21 +143,6 @@ returned. For example, .CE .PP returns \fBc:/\fR. -.PP -Note that tilde substitution will only be -performed if it is necessary to complete the command. For example, -.PP -.CS -\fBfile dirname\fR ~/src/foo.c -.CE -.PP -returns \fB~/src\fR, whereas -.PP -.CS -\fBfile dirname\fR ~ -.CE -.PP -returns \fB/home\fR (or something similar). .RE .TP \fBfile executable \fIname\fR @@ -397,19 +380,6 @@ Returns a list whose elements are the path components in \fIname\fR. The first element of the list will have the same path type as \fIname\fR. All other elements will be relative. Path separators will be discarded unless they are needed to ensure that an element is unambiguously relative. -For example, under Unix -.RS -.PP -.CS -\fBfile split\fR /foo/~bar/baz -.CE -.PP -returns -.QW \fB/\0\0foo\0\0./~bar\0\0baz\fR -to ensure that later commands -that use the third component do not attempt to perform tilde -substitution. -.RE .TP \fBfile stat \fIname varName\fR . @@ -506,11 +476,11 @@ native APIs and external programs that require a filename. Returns the result of performing tilde substitution on \fIname\fR. If the name begins with a tilde, then the file name will be interpreted as if the first element is replaced with the location of the home directory for the given user. -If the tilde is followed immediately by a path separator, the \fBHOME\fR +If the tilde is followed immediately by a path separator, the \fB$HOME\fR environment variable is substituted. Otherwise the characters between the tilde and the next separator are taken as a user name, which is used to retrieve the user's home directory for substitution. An error is raised if the -\fBHOME\fR environment variable or user does not exist. +\fB$HOME\fR environment variable or user does not exist. .RS .PP If the file name does not begin with a tilde, it is returned unmodified. diff --git a/doc/filename.n b/doc/filename.n index 7b9d6fa..1c49d02 100644 --- a/doc/filename.n +++ b/doc/filename.n @@ -118,26 +118,6 @@ Volume-relative path to a file \fBfoo\fR in the root directory of the current volume. This is not a valid UNC path, so the assumption is that the extra backslashes are superfluous. .RE -.SH "TILDE SUBSTITUTION" -.PP -In addition to the file name rules described above, Tcl also supports -\fIcsh\fR-style tilde substitution. If a file name starts with a tilde, -then the file name will be interpreted as if the first element is -replaced with the location of the home directory for the given user. If -the tilde is followed immediately by a separator, then the \fB$HOME\fR -environment variable is substituted. Otherwise the characters between -the tilde and the next separator are taken as a user name, which is used -to retrieve the user's home directory for substitution. This works on -Unix, MacOS X and Windows (except very old releases). -.PP -Old Windows platforms do not support tilde substitution when a user name -follows the tilde. On these platforms, attempts to use a tilde followed -by a user name will generate an error that the user does not exist when -Tcl attempts to interpret that part of the path or otherwise access the -file. The behaviour of these paths when not trying to interpret them is -the same as on Unix. File names that have a tilde without a user name -will be correctly substituted using the \fB$HOME\fR environment -variable, just like for Unix. .SH "PORTABILITY ISSUES" .PP Not all file systems are case sensitive, so scripts should avoid code diff --git a/doc/glob.n b/doc/glob.n index a2cbce2..8a3099e 100644 --- a/doc/glob.n +++ b/doc/glob.n @@ -185,16 +185,6 @@ command if you want the list sorted). Second, \fBglob\fR only returns the names of files that actually exist; in csh no check for existence is made unless a pattern contains a ?, *, or [] construct. -.LP -When the \fBglob\fR command returns relative paths whose filenames -start with a tilde -.QW ~ -(for example through \fBglob *\fR or \fBglob \-tails\fR, the returned -list will not quote the tilde with -.QW ./ . -This means care must be taken if those names are later to -be used with \fBfile join\fR, to avoid them being interpreted as -absolute paths pointing to a given user's home directory. .SH "WINDOWS PORTABILITY ISSUES" .PP For Windows UNC names, the servername and sharename components of the path diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 476629a..74e4d7f 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -662,8 +662,7 @@ SplitUnixPath( } /* - * Split on slashes. Embedded elements that start with tilde will be - * prefixed with "./" so they are not affected by tilde substitution. + * Split on slashes. */ for (;;) { @@ -725,9 +724,7 @@ SplitWinPath( Tcl_DStringFree(&buf); /* - * Split on slashes. Embedded elements that start with tilde or a drive - * letter will be prefixed with "./" so they are not affected by tilde - * substitution. + * Split on slashes. */ do { @@ -836,7 +833,7 @@ TclpNativeJoinPath( start = Tcl_GetStringFromObj(prefix, &length); /* - * Remove the ./ from tilde prefixed elements, and drive-letter prefixed + * Remove the ./ from drive-letter prefixed * elements on Windows, unless it is the first component. */ @@ -999,19 +996,15 @@ Tcl_JoinPath( * Tcl_TranslateFileName -- * * Converts a file name into a form usable by the native system - * interfaces. If the name starts with a tilde, it will produce a name - * where the tilde and following characters have been replaced by the - * home directory location for the named user. + * interfaces. * * Results: - * The return value is a pointer to a string containing the name after - * tilde substitution. If there was no tilde substitution, the return - * value is a pointer to a copy of the original string. If there was an + * The return value is a pointer to a string containing the name. + * This may either be the name pointer passed in or space allocated in + * bufferPtr. In all cases, if the return value is not NULL, the caller + * must call Tcl_DStringFree() to free the space. If there was an * error in processing the name, then an error message is left in the * interp's result (if interp was not NULL) and the return value is NULL. - * Space for the return value is allocated in bufferPtr; the caller must - * call Tcl_DStringFree() to free the space if the return value was not - * NULL. * * Side effects: * None. @@ -1028,7 +1021,7 @@ Tcl_TranslateFileName( * "~" (to indicate any user's home * directory). */ Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with - * name after tilde substitution. */ + * name. */ { Tcl_Obj *path = Tcl_NewStringObj(name, -1); Tcl_Obj *transPtr; @@ -1607,8 +1600,7 @@ Tcl_GlobObjCmd( * * TclGlob -- * - * Sets the separator string based on the platform, performs tilde - * substitution, and calls DoGlob. + * Sets the separator string based on the platform 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 diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 361fad5..40955b1 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -2159,10 +2159,6 @@ Tcl_FSEqualPaths( * 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 "~" indicates a particular - * user's directory. - * * Results: * Standard Tcl error code. * -- cgit v0.12 From a312d4a759c7d925d22e4e4fc8cbbe2d23dc9f27 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 16 Sep 2022 13:44:25 +0000 Subject: Add testcases, and fix a bug found by it --- generic/tclEncoding.c | 9 ++++++--- tests/cmdAH.test | 20 ++++++++++++++++++++ 2 files changed, 26 insertions(+), 3 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 9c4b5ce..3d5e474 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2361,13 +2361,16 @@ UtfToUtfProc( } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) && (UCHAR(src[1]) == 0x80) && (!(flags & TCL_ENCODING_MODIFIED) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT))) { /* - * Convert 0xC080 to real nulls when we are in output mode. + * If in input mode, and -strict is specified: This is an error. */ - if (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)) { + if (flags & TCL_ENCODING_MODIFIED) { result = TCL_CONVERT_UNKNOWN; break; - } + } + /* + * Convert 0xC080 to real nulls when we are in output mode, with or without '-strict'. + */ *dst++ = 0; src += 2; } else if (!Tcl_UtfCharComplete(src, srcEnd - src)) { diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 38ca521..69da6c2 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -21,6 +21,7 @@ catch [list package require -exact tcl::test [info patchlevel]] testConstraint testchmod [llength [info commands testchmod]] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testvolumetype [llength [info commands testvolumetype]] +testConstraint testbytestring [llength [info commands testbytestring]] testConstraint time64bit [expr { $::tcl_platform(pointerSize) >= 8 || [llength [info command testsize]] && [testsize st_mtime] >= 8 @@ -349,6 +350,25 @@ test cmdAH-4.21.2 {convertto -failindex with wrong character (byte compiled)} -s } -returnCodes 0 -result {41 1} -cleanup { rename encoding_test "" } +test cmdAH-4.22 {convertfrom -strict} -body { + encoding convertfrom -strict utf-8 A\x00B +} -result A\x00B + +test cmdAH-4.23 {convertfrom -strict} -body { + encoding convertfrom -strict utf-8 A\xC0\x80B +} -returnCodes error -result {unexpected byte sequence starting at index 1: '\xC0'} + +test cmdAH-4.24 {convertto -strict} -body { + encoding convertto -strict utf-8 A\x00B +} -result A\x00B + +test cmdAH-4.25 {convertfrom -strict} -constraints knownBug -body { + encoding convertfrom -strict utf-8 A\x80B +} -returnCodes error -result {unexpected byte sequence starting at index 1: '\x80'} + +test cmdAH-4.26 {convertto -strict} -constraints {testbytestring knownBug} -body { + encoding convertto -strict utf-8 A[testbytestring \x80]B +} -returnCodes error -result {unexpected byte sequence starting at index 1: '\x80'} test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { file -- cgit v0.12 From 7b46c41c056ce57494a3dc67b3f17fdf344ce9fb Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 16 Sep 2022 14:59:14 +0000 Subject: remove obsolete comments --- generic/tcl.h | 19 ++----------------- 1 file changed, 2 insertions(+), 17 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index d74309f..1c330d8 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -354,25 +354,9 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; /* *---------------------------------------------------------------------------- * Data structures defined opaquely in this module. The definitions below just - * provide dummy types. A few fields are made visible in Tcl_Interp - * structures, namely those used for returning a string result from commands. - * Direct access to the result field is discouraged in Tcl 8.0. The - * interpreter result is either an object or a string, and the two values are - * kept consistent unless some C code sets interp->result directly. - * Programmers should use either the function Tcl_GetObjResult() or - * Tcl_GetStringResult() to read the interpreter's result. See the SetResult - * man page for details. - * - * Note: any change to the Tcl_Interp definition below must be mirrored in the - * "real" definition in tclInt.h. - * - * Note: Tcl_ObjCmdProc functions do not directly set result and freeProc. - * Instead, they set a Tcl_Obj member in the "real" structure that can be - * accessed with Tcl_GetObjResult() and Tcl_SetObjResult(). + * provide dummy types. */ -typedef struct Tcl_Interp Tcl_Interp; - typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_Channel_ *Tcl_Channel; typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion; @@ -382,6 +366,7 @@ typedef struct Tcl_Dict_ *Tcl_Dict; typedef struct Tcl_EncodingState_ *Tcl_EncodingState; typedef struct Tcl_Encoding_ *Tcl_Encoding; typedef struct Tcl_Event Tcl_Event; +typedef struct Tcl_Interp Tcl_Interp; typedef struct Tcl_InterpState_ *Tcl_InterpState; typedef struct Tcl_LoadHandle_ *Tcl_LoadHandle; typedef struct Tcl_Mutex_ *Tcl_Mutex; -- cgit v0.12 From 260c5156ed0ec2b944268320a267cee9a57cd547 Mon Sep 17 00:00:00 2001 From: dgp Date: Sun, 18 Sep 2022 13:59:26 +0000 Subject: TIP implementation to add/use public routines Tcl_GetNumber(FromObj). --- generic/tcl.decls | 8 ++++++++ generic/tcl.h | 14 ++++++++++++++ generic/tclBasic.c | 32 ++++++++++++++++---------------- generic/tclDecls.h | 14 ++++++++++++++ generic/tclExecute.c | 4 ++-- generic/tclInt.h | 18 ------------------ generic/tclLink.c | 2 +- generic/tclObj.c | 40 ++++++++++++++++++++++++++++++++++++++-- generic/tclStubInit.c | 2 ++ generic/tclUtil.c | 10 +++++----- 10 files changed, 100 insertions(+), 44 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index d08ba0a..2bbad1c 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2523,6 +2523,14 @@ declare 679 { int Tcl_NRCallObjProc2(Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, void *clientData, size_t objc, Tcl_Obj *const objv[]) } +declare 680 { + int Tcl_GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + void **clientDataPtr, int *typePtr) +} +declare 681 { + int Tcl_GetNumber(Tcl_Interp *interp, const char *bytes, size_t numBytes, + void **clientDataPtr, int *typePtr) +} # ----- BASELINE -- FOR -- 8.7.0 ----- # diff --git a/generic/tcl.h b/generic/tcl.h index f17d43e..cd16ea9 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -974,6 +974,20 @@ typedef struct Tcl_DString { #define TCL_INTEGER_SPACE (3*(int)sizeof(Tcl_WideInt)) /* + *---------------------------------------------------------------------------- + * Type values returned by Tcl_GetNumberFromObj + * TCL_NUMBER_INT Representation is a Tcl_WideInt + * TCL_NUMBER_BIG Representation is an mp_int + * TCL_NUMBER_DOUBLE Representation is a double + * TCL_NUMBER_NAN Value is NaN. + */ + +#define TCL_NUMBER_INT 2 +#define TCL_NUMBER_BIG 3 +#define TCL_NUMBER_DOUBLE 4 +#define TCL_NUMBER_NAN 5 + +/* * Flag values passed to Tcl_ConvertElement. * TCL_DONT_USE_BRACES forces it not to enclose the element in braces, but to * use backslash quoting instead. diff --git a/generic/tclBasic.c b/generic/tclBasic.c index b806c33..d7afc14 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4133,7 +4133,7 @@ OldMathFuncProc( args = (Tcl_Value *)ckalloc(dataPtr->numArgs * sizeof(Tcl_Value)); for (j = 1, k = 0; j < objc; ++j, ++k) { - /* TODO: Convert to TclGetNumberFromObj? */ + /* TODO: Convert to Tcl_GetNumberFromObj? */ valuePtr = objv[j]; result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d); #ifdef ACCEPT_NAN @@ -7041,7 +7041,7 @@ Tcl_ExprLongObj( return TCL_ERROR; } - if (TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type)!=TCL_OK) { + if (Tcl_GetNumberFromObj(interp, resultPtr, &internalPtr, &type)!=TCL_OK) { return TCL_ERROR; } @@ -7087,7 +7087,7 @@ Tcl_ExprDoubleObj( return TCL_ERROR; } - result = TclGetNumberFromObj(interp, resultPtr, &internalPtr, &type); + result = Tcl_GetNumberFromObj(interp, resultPtr, &internalPtr, &type); if (result == TCL_OK) { switch (type) { case TCL_NUMBER_NAN: @@ -7808,7 +7808,7 @@ ExprIsqrtFunc( * Make sure that the arg is a number. */ - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } @@ -8071,7 +8071,7 @@ ExprAbsFunc( return TCL_ERROR; } - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } @@ -8226,7 +8226,7 @@ ExprIntFunc( MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } @@ -8307,7 +8307,7 @@ ExprMaxMinFunc( } res = objv[1]; for (i = 1; i < objc; i++) { - if (TclGetNumberFromObj(interp, objv[i], &ptr, &type) != TCL_OK) { + if (Tcl_GetNumberFromObj(interp, objv[i], &ptr, &type) != TCL_OK) { return TCL_ERROR; } if (type == TCL_NUMBER_NAN) { @@ -8459,7 +8459,7 @@ ExprRoundFunc( return TCL_ERROR; } - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } @@ -8727,7 +8727,7 @@ ExprIsFiniteFunc( return TCL_ERROR; } - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } if (type != TCL_NUMBER_NAN) { @@ -8758,7 +8758,7 @@ ExprIsInfinityFunc( return TCL_ERROR; } - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } if (type != TCL_NUMBER_NAN) { @@ -8788,7 +8788,7 @@ ExprIsNaNFunc( return TCL_ERROR; } - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } if (type != TCL_NUMBER_NAN) { @@ -8818,7 +8818,7 @@ ExprIsNormalFunc( return TCL_ERROR; } - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } if (type != TCL_NUMBER_NAN) { @@ -8848,7 +8848,7 @@ ExprIsSubnormalFunc( return TCL_ERROR; } - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } if (type != TCL_NUMBER_NAN) { @@ -8878,7 +8878,7 @@ ExprIsUnorderedFunc( return TCL_ERROR; } - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } if (type == TCL_NUMBER_NAN) { @@ -8888,7 +8888,7 @@ ExprIsUnorderedFunc( result = (ClassifyDouble(d) == FP_NAN); } - if (TclGetNumberFromObj(interp, objv[2], &ptr, &type) != TCL_OK) { + if (Tcl_GetNumberFromObj(interp, objv[2], &ptr, &type) != TCL_OK) { return TCL_ERROR; } if (type == TCL_NUMBER_NAN) { @@ -8920,7 +8920,7 @@ FloatClassifyObjCmd( return TCL_ERROR; } - if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + if (Tcl_GetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } if (type == TCL_NUMBER_NAN) { diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 3917d0f..82d592b 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1996,6 +1996,14 @@ EXTERN Tcl_Command Tcl_NRCreateCommand2(Tcl_Interp *interp, EXTERN int Tcl_NRCallObjProc2(Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, void *clientData, size_t objc, Tcl_Obj *const objv[]); +/* 680 */ +EXTERN int Tcl_GetNumberFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, void **clientDataPtr, + int *typePtr); +/* 681 */ +EXTERN int Tcl_GetNumber(Tcl_Interp *interp, const char *bytes, + size_t numBytes, void **clientDataPtr, + int *typePtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2711,6 +2719,8 @@ typedef struct TclStubs { Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */ Tcl_Command (*tcl_NRCreateCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc, Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 678 */ int (*tcl_NRCallObjProc2) (Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, void *clientData, size_t objc, Tcl_Obj *const objv[]); /* 679 */ + int (*tcl_GetNumberFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void **clientDataPtr, int *typePtr); /* 680 */ + int (*tcl_GetNumber) (Tcl_Interp *interp, const char *bytes, size_t numBytes, void **clientDataPtr, int *typePtr); /* 681 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4099,6 +4109,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_NRCreateCommand2) /* 678 */ #define Tcl_NRCallObjProc2 \ (tclStubsPtr->tcl_NRCallObjProc2) /* 679 */ +#define Tcl_GetNumberFromObj \ + (tclStubsPtr->tcl_GetNumberFromObj) /* 680 */ +#define Tcl_GetNumber \ + (tclStubsPtr->tcl_GetNumber) /* 681 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 8aa3bb2..dc5adc2 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -502,7 +502,7 @@ VarHashCreateVar( /* * Macro used in this file to save a function call for common uses of - * TclGetNumberFromObj(). The ANSI C "prototype" is: + * Tcl_GetNumberFromObj(). The ANSI C "prototype" is: * * MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, * void **ptrPtr, int *tPtr); @@ -521,7 +521,7 @@ VarHashCreateVar( (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \ ? TCL_ERROR : \ - TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) + Tcl_GetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) /* * Macro used to make the check for type overflow more mnemonic. This works by diff --git a/generic/tclInt.h b/generic/tclInt.h index 09f22d3..9eba8c5 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2875,21 +2875,6 @@ typedef struct ProcessGlobalValue { /* Reject underscore digit separator */ /* - *---------------------------------------------------------------------- - * Type values TclGetNumberFromObj - *---------------------------------------------------------------------- - */ - -#define TCL_NUMBER_INT 2 -#if !defined(TCL_NO_DEPRECATED) -# define TCL_NUMBER_LONG 1 /* deprecated, not used any more */ -# define TCL_NUMBER_WIDE TCL_NUMBER_INT /* deprecated */ -#endif -#define TCL_NUMBER_BIG 3 -#define TCL_NUMBER_DOUBLE 4 -#define TCL_NUMBER_NAN 5 - -/* *---------------------------------------------------------------- * Variables shared among Tcl modules but not used by the outside world. *---------------------------------------------------------------- @@ -3199,9 +3184,6 @@ MODULE_SCOPE int TclGetCompletionCodeFromObj(Tcl_Interp *interp, Tcl_Obj *value, int *code); MODULE_SCOPE Proc * TclGetLambdaFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **nsObjPtrPtr); -MODULE_SCOPE int TclGetNumberFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, void **clientDataPtr, - int *typePtr); MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp, const char *modeString, int *seekFlagPtr, int *binaryPtr); diff --git a/generic/tclLink.c b/generic/tclLink.c index 6bd65fa..0d57d44 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -530,7 +530,7 @@ GetUWide( void *clientData; int type, intValue; - if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) { + if (Tcl_GetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) { if (type == TCL_NUMBER_INT) { *widePtr = *((const Tcl_WideInt *) clientData); return (*widePtr < 0); diff --git a/generic/tclObj.c b/generic/tclObj.c index 5726596..f9b5bd3 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -3856,7 +3856,7 @@ TclSetBignumInternalRep( /* *---------------------------------------------------------------------- * - * TclGetNumberFromObj -- + * Tcl_GetNumberFromObj -- * * Extracts a number (of any possible numeric type) from an object. * @@ -3874,7 +3874,7 @@ TclSetBignumInternalRep( */ int -TclGetNumberFromObj( +Tcl_GetNumberFromObj( Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientDataPtr, @@ -3909,6 +3909,42 @@ TclGetNumberFromObj( TclParseNumber(interp, objPtr, "number", NULL, -1, NULL, 0)); return TCL_ERROR; } + +int +Tcl_GetNumber( + Tcl_Interp *interp, + const char *bytes, + size_t numBytes, + ClientData *clientDataPtr, + int *typePtr) +{ + static Tcl_ThreadDataKey numberCacheKey; + Tcl_Obj *objPtr = (Tcl_Obj *)Tcl_GetThreadData(&numberCacheKey, + sizeof(Tcl_Obj)); + + Tcl_FreeInternalRep(objPtr); + + if (bytes == NULL) { + bytes = &tclEmptyString; + numBytes = 0; + } + if (numBytes == (size_t)TCL_INDEX_NONE) { + numBytes = strlen(bytes); + } + if (numBytes > INT_MAX) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return TCL_ERROR; + } + + objPtr->bytes = (char *) bytes; + objPtr->length = numBytes; + + return Tcl_GetNumberFromObj(interp, objPtr, clientDataPtr, typePtr); +} /* *---------------------------------------------------------------------- diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index ae00b04..4e6041e 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -2043,6 +2043,8 @@ const TclStubs tclStubs = { Tcl_CreateObjTrace2, /* 677 */ Tcl_NRCreateCommand2, /* 678 */ Tcl_NRCallObjProc2, /* 679 */ + Tcl_GetNumberFromObj, /* 680 */ + Tcl_GetNumber, /* 681 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 7ab6eae..742bded 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3644,7 +3644,7 @@ GetWideForIndex( { int numType; ClientData cd; - int code = TclGetNumberFromObj(NULL, objPtr, &cd, &numType); + int code = Tcl_GetNumberFromObj(NULL, objPtr, &cd, &numType); if (code == TCL_OK) { if (numType == TCL_NUMBER_INT) { @@ -3803,7 +3803,7 @@ GetEndOffsetFromObj( /* ... value continues with [-+] ... */ /* Save first integer as wide if possible */ - TclGetNumberFromObj(NULL, objPtr, &cd, &t1); + Tcl_GetNumberFromObj(NULL, objPtr, &cd, &t1); if (t1 == TCL_NUMBER_INT) { w1 = (*(Tcl_WideInt *)cd); } @@ -3813,7 +3813,7 @@ GetEndOffsetFromObj( /* ... value concludes with second valid integer */ /* Save second integer as wide if possible */ - TclGetNumberFromObj(NULL, objPtr, &cd, &t2); + Tcl_GetNumberFromObj(NULL, objPtr, &cd, &t2); if (t2 == TCL_NUMBER_INT) { w2 = (*(Tcl_WideInt *)cd); } @@ -3866,7 +3866,7 @@ GetEndOffsetFromObj( Tcl_ExprObj(compute, objPtr, &sum); Tcl_DeleteInterp(compute); } - TclGetNumberFromObj(NULL, sum, &cd, &numType); + Tcl_GetNumberFromObj(NULL, sum, &cd, &numType); if (numType == TCL_NUMBER_INT) { /* sum holds an integer in the signed wide range */ @@ -3917,7 +3917,7 @@ GetEndOffsetFromObj( } /* Got an integer offset; pull it from where parser left it. */ - TclGetNumberFromObj(NULL, objPtr, &cd, &t); + Tcl_GetNumberFromObj(NULL, objPtr, &cd, &t); if (t == TCL_NUMBER_BIG) { /* Truncate to the signed wide range. */ -- cgit v0.12 From 9d536c3831e542752097c755a299643a06782298 Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 19 Sep 2022 17:40:28 +0000 Subject: TIP633 fconfigure -nocomplainencoding (TCL9): replace "-strictencoding 0" by "-nocomplainencoding 1". --- generic/tclIO.c | 15 ++++++--------- generic/tclIO.h | 4 ++-- tests/io.test | 20 ++++++++++---------- tests/ioCmd.test | 12 ++++++------ tests/zlib.test | 4 ++-- 5 files changed, 26 insertions(+), 29 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index c06ca5a..00327cb 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -7928,15 +7928,12 @@ Tcl_GetChannelOption( return TCL_OK; } } - if (len == 0 || HaveOpt(1, "-strictencoding")) { + if (len == 0 || HaveOpt(1, "-nocomplainencoding")) { if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-strictencoding"); + Tcl_DStringAppendElement(dsPtr, "-nocomplainencoding"); } Tcl_DStringAppendElement(dsPtr, - (flags & CHANNEL_ENCODING_NOCOMPLAIN) ? "0" : "1"); - if (len > 0) { - return TCL_OK; - } + (flags & CHANNEL_ENCODING_NOCOMPLAIN) ? "1" : "0"); if (len > 0) { return TCL_OK; } @@ -8204,16 +8201,16 @@ Tcl_SetChannelOption( ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_STICKY_EOF|CHANNEL_BLOCKED); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; return TCL_OK; - } else if (HaveOpt(1, "-strictencoding")) { + } else if (HaveOpt(1, "-nocomplainencoding")) { int newMode; if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { return TCL_ERROR; } if (newMode) { - statePtr->flags &= ~CHANNEL_ENCODING_NOCOMPLAIN; - } else { statePtr->flags |= CHANNEL_ENCODING_NOCOMPLAIN; + } else { + statePtr->flags &= ~CHANNEL_ENCODING_NOCOMPLAIN; } return TCL_OK; } else if (HaveOpt(1, "-translation")) { diff --git a/generic/tclIO.h b/generic/tclIO.h index a4128bc..532dd62 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -271,8 +271,8 @@ typedef struct ChannelState { * changes. */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ -#define CHANNEL_ENCODING_NOCOMPLAIN (1<<17) /* set if option -strictencoding - * is set to 0 */ +#define CHANNEL_ENCODING_NOCOMPLAIN (1<<17) /* set if option + * -nocomplainencoding is set to 1 */ #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. * Its structures are still live and diff --git a/tests/io.test b/tests/io.test index b606c3e..dc61466 100644 --- a/tests/io.test +++ b/tests/io.test @@ -8952,7 +8952,7 @@ test io-74.1 {[104f2885bb] improper cache validity check} -setup { removeFile io-74.1 } -returnCodes error -match glob -result {can not find channel named "*"} -test io-75.1 {multibyte encoding error read results in raw bytes (-strictencoding 0)} -setup { +test io-75.1 {multibyte encoding error read results in raw bytes (-nocomplainencoding 1)} -setup { set fn [makeFile {} io-75.1] set f [open $fn w+] fconfigure $f -encoding binary @@ -8961,7 +8961,7 @@ test io-75.1 {multibyte encoding error read results in raw bytes (-strictencodin puts -nonewline $f "A\xC0\x40" flush $f seek $f 0 - fconfigure $f -encoding utf-8 -strictencoding 0 -buffering none + fconfigure $f -encoding utf-8 -nocomplainencoding 1 -buffering none } -body { set d [read $f] binary scan $d H* hd @@ -8971,10 +8971,10 @@ test io-75.1 {multibyte encoding error read results in raw bytes (-strictencodin removeFile io-75.1 } -result "41c040" -test io-75.2 {unrepresentable character write passes and is replaced by ? (-strictencoding 0)} -setup { +test io-75.2 {unrepresentable character write passes and is replaced by ? (-nocomplainencoding 1)} -setup { set fn [makeFile {} io-75.2] set f [open $fn w+] - fconfigure $f -encoding iso8859-1 -strictencoding 0 + fconfigure $f -encoding iso8859-1 -nocomplainencoding 1 } -body { puts -nonewline $f "A\u2022" flush $f @@ -8988,14 +8988,14 @@ test io-75.2 {unrepresentable character write passes and is replaced by ? (-stri # Incomplete sequence test. # This error may IMHO only be detected with the close. # But the read already returns the incomplete sequence. -test io-75.3 {incomplete multibyte encoding read is ignored (-strictencoding 0)} -setup { +test io-75.3 {incomplete multibyte encoding read is ignored (-nocomplainencoding 1)} -setup { set fn [makeFile {} io-75.3] set f [open $fn w+] fconfigure $f -encoding binary puts -nonewline $f "A\xC0" flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -strictencoding 0 + fconfigure $f -encoding utf-8 -buffering none -nocomplainencoding 1 } -body { set d [read $f] close $f @@ -9007,7 +9007,7 @@ test io-75.3 {incomplete multibyte encoding read is ignored (-strictencoding 0)} # As utf-8 has a special treatment in multi-byte decoding, also test another # one. -test io-75.4 {shiftjis encoding error read results in raw bytes (-strictencoding 0)} -setup { +test io-75.4 {shiftjis encoding error read results in raw bytes (-nocomplainencoding 1)} -setup { set fn [makeFile {} io-75.4] set f [open $fn w+] fconfigure $f -encoding binary @@ -9016,7 +9016,7 @@ test io-75.4 {shiftjis encoding error read results in raw bytes (-strictencoding puts -nonewline $f "A\x81\xFFA" flush $f seek $f 0 - fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf -strictencoding 0 + fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf -nocomplainencoding 1 } -body { set d [read $f] binary scan $d H* hd @@ -9026,7 +9026,7 @@ test io-75.4 {shiftjis encoding error read results in raw bytes (-strictencoding removeFile io-75.4 } -result "4181ff41" -test io-75.5 {incomplete shiftjis encoding read is ignored (-strictencoding 0)} -setup { +test io-75.5 {incomplete shiftjis encoding read is ignored (-nocomplainencoding 1)} -setup { set fn [makeFile {} io-75.5] set f [open $fn w+] fconfigure $f -encoding binary @@ -9034,7 +9034,7 @@ test io-75.5 {incomplete shiftjis encoding read is ignored (-strictencoding 0)} puts -nonewline $f "A\x81" flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -strictencoding 0 + fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -nocomplainencoding 1 } -body { set d [read $f] close $f diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 178b54a..92e96a2 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -245,7 +245,7 @@ test iocmd-8.7 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -strictencoding 1 -translation lf} +} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -nocomplainencoding 0 -translation lf} test iocmd-8.8 {fconfigure command} -setup { file delete $path(test1) set x {} @@ -257,7 +257,7 @@ test iocmd-8.8 {fconfigure command} -setup { lappend x [fconfigure $f1] } -cleanup { catch {close $f1} -} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -strictencoding 1 -translation lf}} +} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -nocomplainencoding 0 -translation lf}} test iocmd-8.9 {fconfigure command} -setup { file delete $path(test1) } -body { @@ -267,7 +267,7 @@ test iocmd-8.9 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -strictencoding 1 -translation lf} +} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -nocomplainencoding 0 -translation lf} test iocmd-8.10 {fconfigure command} -returnCodes error -body { fconfigure a b } -result {can not find channel named "a"} @@ -1363,7 +1363,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { close $c rename foo {} set res -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 1 -translation {auto *}}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -nocomplainencoding 0 -translation {auto *}}} test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -1372,7 +1372,7 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 1 -translation {auto *}}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -nocomplainencoding 0 -translation {auto *}}} test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -1384,7 +1384,7 @@ test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 1 -translation {auto *} -bar foo -snarf x}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -nocomplainencoding 0 -translation {auto *} -bar foo -snarf x}} test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { diff --git a/tests/zlib.test b/tests/zlib.test index f848b58..d20011f 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -292,7 +292,7 @@ test zlib-8.6 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 0 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 0 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 0 -translation lf}} test zlib-8.7 {transformation and fconfigure} -setup { set file [makeFile {} test.gz] set fd [open $file wb] @@ -302,7 +302,7 @@ test zlib-8.7 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 1 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 0 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 0 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 0 -translation lf}} # Input is headers from fetching SPDY draft # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" -- cgit v0.12 From 5d066cf1694f50526815d3b96301e4cf7f3007fd Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 19 Sep 2022 17:45:10 +0000 Subject: TIP633 fconfigure -nocomplainencoding (TCL8.7): replace "-strictencoding 0" by "-nocomplainencoding 1". --- generic/tclIO.c | 12 ++++++------ tests/ioCmd.test | 18 +++++++++--------- tests/zlib.test | 4 ++-- 3 files changed, 17 insertions(+), 17 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 71ad637..3c1d4b0 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -7923,11 +7923,11 @@ Tcl_GetChannelOption( return TCL_OK; } } - if (len == 0 || HaveOpt(1, "-strictencoding")) { + if (len == 0 || HaveOpt(1, "-nocomplainencoding")) { if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-strictencoding"); + Tcl_DStringAppendElement(dsPtr, "-nocomplainencoding"); } - Tcl_DStringAppendElement(dsPtr,"0"); + Tcl_DStringAppendElement(dsPtr,"1"); if (len > 0) { return TCL_OK; } @@ -8185,16 +8185,16 @@ Tcl_SetChannelOption( ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_STICKY_EOF|CHANNEL_BLOCKED); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; return TCL_OK; - } else if (HaveOpt(1, "-strictencoding")) { + } else if (HaveOpt(1, "-nocomplainencoding")) { int newMode; if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { return TCL_ERROR; } - if (newMode) { + if (!newMode) { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad value for -strictencoding: only false allowed", + "bad value for -nocomplainencoding: only true allowed", -1)); } return TCL_ERROR; diff --git a/tests/ioCmd.test b/tests/ioCmd.test index ad4cd4e..0af12ce 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -245,7 +245,7 @@ test iocmd-8.7 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -strictencoding 0 -translation lf} +} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -nocomplainencoding 1 -translation lf} test iocmd-8.8 {fconfigure command} -setup { file delete $path(test1) set x {} @@ -257,7 +257,7 @@ test iocmd-8.8 {fconfigure command} -setup { lappend x [fconfigure $f1] } -cleanup { catch {close $f1} -} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -strictencoding 0 -translation lf}} +} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -nocomplainencoding 1 -translation lf}} test iocmd-8.9 {fconfigure command} -setup { file delete $path(test1) } -body { @@ -267,7 +267,7 @@ test iocmd-8.9 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -strictencoding 0 -translation lf} +} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -nocomplainencoding 1 -translation lf} test iocmd-8.10 {fconfigure command} -returnCodes error -body { fconfigure a b } -result {can not find channel named "a"} @@ -369,12 +369,12 @@ test iocmd-8.20 {fconfigure command / win console channel} -constraints {nonPort } -returnCodes error -result [expectedOpts "-blah" {-inputmode}] # TODO: Test parsing of serial channel options (nonPortable, since requires an # open channel to work with). -test iocmd-8.21 {fconfigure command / -strictencoding 1 error} -setup { +test iocmd-8.21 {fconfigure command / -nocomplainencoding 0 error} -setup { # I don't know how else to open the console, but this is non-portable set console stdin } -body { - fconfigure $console -strictencoding 1 -} -returnCodes error -result "bad value for -strictencoding: only false allowed" + fconfigure $console -nocomplainencoding 0 +} -returnCodes error -result "bad value for -nocomplainencoding: only true allowed" test iocmd-9.1 {eof command} { @@ -1370,7 +1370,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { close $c rename foo {} set res -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 0 -translation {auto *}}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -nocomplainencoding 1 -translation {auto *}}} test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -1379,7 +1379,7 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 0 -translation {auto *}}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -nocomplainencoding 1 -translation {auto *}}} test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -1391,7 +1391,7 @@ test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 0 -translation {auto *} -bar foo -snarf x}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -nocomplainencoding 1 -translation {auto *} -bar foo -snarf x}} test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { diff --git a/tests/zlib.test b/tests/zlib.test index a1c7aa4..6d71a81 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -292,7 +292,7 @@ test zlib-8.6 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -translation lf}} test zlib-8.7 {transformation and fconfigure} -setup { set file [makeFile {} test.gz] set fd [open $file wb] @@ -302,7 +302,7 @@ test zlib-8.7 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -translation lf}} # Input is headers from fetching SPDY draft # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" -- cgit v0.12 From 6a3c75c37fdb9e5ad6a19ad77d0be583468637e7 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 21 Sep 2022 14:59:40 +0000 Subject: Reduce chances for test conflicts. --- tests/env.test | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/tests/env.test b/tests/env.test index ebe7bc7..dcf5ab4 100644 --- a/tests/env.test +++ b/tests/env.test @@ -427,10 +427,10 @@ test env-7.5 { set env variable through upvar } -setup setup1 -body { apply {{} { - set ::env(test7_4) origvalue - upvar #0 env(test7_4) var + set ::env(test7_5) origvalue + upvar #0 env(test7_5) var set var newvalue - return $::env(test7_4) + return $::env(test7_5) }} } -cleanup cleanup1 -result newvalue @@ -438,10 +438,10 @@ test env-7.6 { unset env variable through upvar } -setup setup1 -body { apply {{} { - set ::env(test7_4) origvalue - upvar #0 env(test7_4) var + set ::env(test7_6) origvalue + upvar #0 env(test7_6) var unset var - return [array get env test7_4] + return [array get env test7_6] }} } -cleanup cleanup1 -result {} -- cgit v0.12 From ed4c583b0670380c6dacc6f7dce3bd2a791ae785 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 21 Sep 2022 15:25:25 +0000 Subject: TIP #640 implementation: Tcl_SaveResult reuse for Tcl 9.0 --- generic/tcl.h | 2 +- generic/tclDecls.h | 10 +++------- 2 files changed, 4 insertions(+), 8 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 1c330d8..36d175d 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -676,7 +676,7 @@ typedef struct Tcl_Obj { * is typically allocated on the stack. */ -typedef Tcl_Obj *Tcl_SavedResult; +typedef Tcl_InterpState Tcl_SavedResult; /* *---------------------------------------------------------------------------- diff --git a/generic/tclDecls.h b/generic/tclDecls.h index ad2480c..c1a7d88 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3882,18 +3882,14 @@ extern const TclStubs *tclStubsPtr; #define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp)) #define Tcl_SaveResult(interp, statePtr) \ do { \ - *(statePtr) = Tcl_GetObjResult(interp); \ - Tcl_IncrRefCount(*(statePtr)); \ - Tcl_SetObjResult(interp, Tcl_NewObj()); \ + *(statePtr) = Tcl_SaveInterpState(interp, TCL_ERROR); \ } while(0) #define Tcl_RestoreResult(interp, statePtr) \ do { \ - Tcl_ResetResult(interp); \ - Tcl_SetObjResult(interp, *(statePtr)); \ - Tcl_DecrRefCount(*(statePtr)); \ + Tcl_RestoreInterpState(interp, *(statePtr)); \ } while(0) #define Tcl_DiscardResult(statePtr) \ - Tcl_DecrRefCount(*(statePtr)) + Tcl_DiscardInterpState(*(statePtr)) #define Tcl_SetResult(interp, result, freeProc) \ do { \ const char *__result = result; \ -- cgit v0.12 From 85c05d7a3d1760c35dcf594502b7816f35a443da Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 21 Sep 2022 15:39:02 +0000 Subject: Include TYPE_OPEN_PAREN in the comment. --- generic/tclParse.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclParse.c b/generic/tclParse.c index 18773a5..af507e9 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -33,6 +33,7 @@ * meaning in ParseTokens: backslash, dollar sign, or * open bracket. * TYPE_QUOTE - Character is a double quote. + * TYPE_OPEN_PAREN - Character is a left parenthesis. * TYPE_CLOSE_PAREN - Character is a right parenthesis. * TYPE_CLOSE_BRACK - Character is a right square bracket. * TYPE_BRACE - Character is a curly brace (either left or right). -- cgit v0.12 From d00000e8162adf60a7f52d474d430d0cf3cfab6c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 22 Sep 2022 10:56:56 +0000 Subject: fix testcase --- tests/socket.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/socket.test b/tests/socket.test index 4644e1d..c354f46 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -1071,7 +1071,7 @@ test socket_$af-7.3 {testing socket specific options} -constraints [list socket close $s update llength $l -} -result 14 +} -result 16 test socket_$af-7.4 {testing socket specific options} -constraints [list socket supported_$af] -setup { set timer [after 10000 "set x timed_out"] set l "" -- cgit v0.12 From 606baf39a5ea4daea70730647a6c5e435db9df03 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 22 Sep 2022 11:26:44 +0000 Subject: Add -strictencoding option to channels. Thanks to Harald Oehlman for his example (largely copied). No testcases yet --- generic/tclIO.c | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclIO.h | 3 ++- tests/ioCmd.test | 12 ++++++------ tests/socket.test | 2 +- tests/zlib.test | 4 ++-- 5 files changed, 64 insertions(+), 10 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index e00b99b..04c3b1b 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4342,6 +4342,14 @@ Write( } /* + * Transfer encoding strict option to the encoding flags + */ + + if (statePtr->flags & CHANNEL_ENCODING_STRICT) { + statePtr->outputEncodingFlags |= TCL_ENCODING_STRICT; + } + + /* * Write the terminated escape sequence even if srcLen is 0. */ @@ -4657,6 +4665,14 @@ Tcl_GetsObj( } /* + * Transfer encoding strict option to the encoding flags + */ + + if (statePtr->flags & CHANNEL_ENCODING_STRICT) { + statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT; + } + + /* * Object used by FilterInputBytes to keep track of how much data has been * consumed from the channel buffers. */ @@ -5412,6 +5428,15 @@ FilterInputBytes( *gsPtr->dstPtr = dst; } gsPtr->state = statePtr->inputEncodingState; + + /* + * Transfer encoding strict option to the encoding flags + */ + + if (statePtr->flags & CHANNEL_ENCODING_STRICT) { + statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT; + } + result = Tcl_ExternalToUtf(NULL, gsPtr->encoding, raw, rawLen, statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE, &statePtr->inputEncodingState, dst, spaceLeft, &gsPtr->rawRead, @@ -6185,6 +6210,14 @@ ReadChars( } /* + * Transfer encoding strict option to the encoding flags + */ + + if (statePtr->flags & CHANNEL_ENCODING_STRICT) { + statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT; + } + + /* * This routine is burdened with satisfying several constraints. It cannot * append more than 'charsToRead` chars onto objPtr. This is measured * after encoding and translation transformations are completed. There is @@ -7920,6 +7953,16 @@ Tcl_GetChannelOption( return TCL_OK; } } + if (len == 0 || HaveOpt(1, "-strictencoding")) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-strictencoding"); + } + Tcl_DStringAppendElement(dsPtr, + (flags & CHANNEL_ENCODING_STRICT) ? "1" : "0"); + if (len > 0) { + return TCL_OK; + } + } if (len == 0 || HaveOpt(1, "-translation")) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-translation"); @@ -8173,6 +8216,16 @@ Tcl_SetChannelOption( ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_STICKY_EOF|CHANNEL_BLOCKED); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; return TCL_OK; + } else if (HaveOpt(1, "-strictencoding")) { + int newMode; + + if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { + return TCL_ERROR; + } + if (newMode) { + statePtr->flags |= CHANNEL_ENCODING_STRICT; + } + return TCL_OK; } else if (HaveOpt(1, "-translation")) { const char *readMode, *writeMode; diff --git a/generic/tclIO.h b/generic/tclIO.h index 54aa5af..7fbb19e 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -271,7 +271,8 @@ typedef struct ChannelState { * changes. */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ - +#define CHANNEL_ENCODING_STRICT (1<<18) /* set if option + * -strictencoding is set to 1 */ #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. * Its structures are still live and * usable, but it may not be closed diff --git a/tests/ioCmd.test b/tests/ioCmd.test index dbca866..4b61fff 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -245,7 +245,7 @@ test iocmd-8.7 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -translation lf} +} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -strictencoding 0 -translation lf} test iocmd-8.8 {fconfigure command} -setup { file delete $path(test1) set x {} @@ -257,7 +257,7 @@ test iocmd-8.8 {fconfigure command} -setup { lappend x [fconfigure $f1] } -cleanup { catch {close $f1} -} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -translation lf}} +} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -strictencoding 0 -translation lf}} test iocmd-8.9 {fconfigure command} -setup { file delete $path(test1) } -body { @@ -267,7 +267,7 @@ test iocmd-8.9 {fconfigure command} -setup { fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf} +} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -strictencoding 0 -translation lf} test iocmd-8.10 {fconfigure command} -returnCodes error -body { fconfigure a b } -result {can not find channel named "a"} @@ -1363,7 +1363,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { close $c rename foo {} set res -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 0 -translation {auto *}}} test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -1372,7 +1372,7 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 0 -translation {auto *}}} test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -1384,7 +1384,7 @@ test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -strictencoding 0 -translation {auto *} -bar foo -snarf x}} test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { diff --git a/tests/socket.test b/tests/socket.test index 4644e1d..c354f46 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -1071,7 +1071,7 @@ test socket_$af-7.3 {testing socket specific options} -constraints [list socket close $s update llength $l -} -result 14 +} -result 16 test socket_$af-7.4 {testing socket specific options} -constraints [list socket supported_$af] -setup { set timer [after 10000 "set x timed_out"] set l "" diff --git a/tests/zlib.test b/tests/zlib.test index 7de6d64..a1c7aa4 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -292,7 +292,7 @@ test zlib-8.6 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf}} test zlib-8.7 {transformation and fconfigure} -setup { set file [makeFile {} test.gz] set fd [open $file wb] @@ -302,7 +302,7 @@ test zlib-8.7 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -strictencoding 0 -translation lf}} # Input is headers from fetching SPDY draft # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" -- cgit v0.12 From 107106ad026b2a4ea8482a1ea74d7520fd64b36e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 26 Sep 2022 21:45:10 +0000 Subject: Adapt implementation to TIP: -nagle -> -nodelay (and invert some logic) --- doc/socket.n | 10 ++++------ tests/ioCmd.test | 2 +- unix/tclUnixSock.c | 12 +++++------- win/tclWinSock.c | 14 +++++++------- 4 files changed, 17 insertions(+), 21 deletions(-) diff --git a/doc/socket.n b/doc/socket.n index 4506181..b7b3228 100644 --- a/doc/socket.n +++ b/doc/socket.n @@ -208,15 +208,13 @@ This option is not supported by server sockets. For client sockets, this option .TP \fB\-keepalive\fR . -This options sets or queries the TCP keepalive option on the socket as 1 if +This option sets or queries the TCP keepalive option on the socket as 1 if keepalive is turned on, 0 otherwise. .TP -\fB\-nagle\fR +\fB\-nodelay\fR . -This options sets or queries the TCP nodelay option (aka the Nagle algorithm) -When 1 the Nagle algorithm is turned on, 0 otherwise. Caution: the logic is -reversed here, i.e. when the option is 0, the underlying system call asserts -the TCP_NODELAY setting. +This option sets or queries the TCP nodelay option on the socket as 1 if +nodelay is turned on, 0 otherwise. .PP .SH "EXAMPLES" .PP diff --git a/tests/ioCmd.test b/tests/ioCmd.test index f911846..02a0428 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -306,7 +306,7 @@ test iocmd-8.15 {fconfigure command / tcp channel} -constraints {socket unixOrWi close $srv unset cli srv port rename iocmdSRV {} -} -returnCodes error -result [expectedOpts "-blah" {-connecting -keepalive -nagle -peername -sockname}] +} -returnCodes error -result [expectedOpts "-blah" {-connecting -keepalive -nodelay -peername -sockname}] test iocmd-8.16 {fconfigure command / tcp channel} -constraints socket -setup { set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] set port [lindex [fconfigure $srv -sockname] 2] diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 7f22796..e904cfd 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -864,13 +864,12 @@ TcpSetOptionProc( return TCL_OK; } if ((len > 1) && (optionName[1] == 'n') && - (strncmp(optionName, "-nagle", len) == 0)) { + (strncmp(optionName, "-nodelay", len) == 0)) { int val = 0, ret; if (Tcl_GetBoolean(interp, value, &val) != TCL_OK) { return TCL_ERROR; } - val = !val; /* Nagle ain't nodelay */ #if defined(SOL_TCP) && defined(TCP_NODELAY) ret = setsockopt(statePtr->fds.fd, SOL_TCP, TCP_NODELAY, (const char *) &val, sizeof(int)); @@ -888,7 +887,7 @@ TcpSetOptionProc( } return TCL_OK; } - return Tcl_BadChannelOption(interp, optionName, "keepalive nagle"); + return Tcl_BadChannelOption(interp, optionName, "keepalive nodelay"); } /* @@ -1074,18 +1073,17 @@ TcpGetOptionProc( } if ((len == 0) || ((len > 1) && (optionName[1] == 'n') && - (strncmp(optionName, "-nagle", len) == 0))) { + (strncmp(optionName, "-nodelay", len) == 0))) { socklen_t size; int opt = 0; if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-nagle"); + Tcl_DStringAppendElement(dsPtr, "-nodelay"); } #if defined(SOL_TCP) && defined(TCP_NODELAY) getsockopt(statePtr->fds.fd, SOL_TCP, TCP_NODELAY, (char *) &opt, &size); #endif - opt = !opt; /* Nagle ain't nodelay */ Tcl_DStringAppendElement(dsPtr, opt ? "1" : "0"); if (len > 0) { return TCL_OK; @@ -1094,7 +1092,7 @@ TcpGetOptionProc( if (len > 0) { return Tcl_BadChannelOption(interp, optionName, - "connecting keepalive nagle peername sockname"); + "connecting keepalive nodelay peername sockname"); } return TCL_OK; diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 8d16b5c..56d2ba4 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1220,14 +1220,14 @@ TcpSetOptionProc( return TCL_OK; } if ((len > 1) && (optionName[1] == 'n') && - (strncmp(optionName, "-nagle", len) == 0)) { + (strncmp(optionName, "-nodelay", len) == 0)) { BOOL val; int boolVar, rtn; if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) { return TCL_ERROR; } - val = boolVar ? FALSE : TRUE; + val = boolVar ? TRUE : FALSE; rtn = setsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (const char *) &val, sizeof(BOOL)); if (rtn != 0) { @@ -1241,7 +1241,7 @@ TcpSetOptionProc( } return TCL_OK; } - return Tcl_BadChannelOption(interp, optionName, "keepalive nagle"); + return Tcl_BadChannelOption(interp, optionName, "keepalive nodelay"); } /* @@ -1533,17 +1533,17 @@ TcpGetOptionProc( } if ((len == 0) || ((len > 1) && (optionName[1] == 'n') && - (strncmp(optionName, "-nagle", len) == 0))) { + (strncmp(optionName, "-nodelay", len) == 0))) { int optlen; BOOL opt = FALSE; if (len == 0) { sock = statePtr->sockets->fd; - Tcl_DStringAppendElement(dsPtr, "-nagle"); + Tcl_DStringAppendElement(dsPtr, "-nodelay"); } optlen = sizeof(BOOL); getsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (char *)&opt, &optlen); - Tcl_DStringAppendElement(dsPtr, opt ? "0" : "1"); + Tcl_DStringAppendElement(dsPtr, opt ? "1" : "0"); if (len > 0) { return TCL_OK; } @@ -1551,7 +1551,7 @@ TcpGetOptionProc( if (len > 0) { return Tcl_BadChannelOption(interp, optionName, - "connecting keepalive nagle peername sockname"); + "connecting keepalive nodelay peername sockname"); } return TCL_OK; -- cgit v0.12 From 69ac37dbaeab806d67efd79d047215bcbfe1654c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 28 Sep 2022 11:55:26 +0000 Subject: Don't worry deprecation warnings for Tcl_SaveResult: If TIP #640 is accepted it won't matter any more. Eliminate some compiler warnings Mark some lseq testcases as "knownBug", they still need to be fixed --- generic/tclArithSeries.c | 2 +- generic/tclDecls.h | 10 +--------- generic/tclListObj.c | 2 +- tests/lseq.test | 18 +++++++++--------- 4 files changed, 12 insertions(+), 20 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 023ba4a..d104995 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -339,7 +339,7 @@ TclNewArithSeriesObj( } } - if (len > ListSizeT_MAX) { + if (len < 0 || (Tcl_WideUInt)len > ListSizeT_MAX) { Tcl_SetObjResult( interp, Tcl_NewStringObj("max length of a Tcl list exceeded", -1)); diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 910e67e..7ae6fc3 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3892,28 +3892,20 @@ extern const TclStubs *tclStubsPtr; #define Tcl_GlobalEval(interp, objPtr) \ Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, TCL_EVAL_GLOBAL) #define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp)) -static TCL_DEPRECATED_API("Use Tcl_SaveInterpState") void Tcl_SaveResult_(void) {} #define Tcl_SaveResult(interp, statePtr) \ do { \ - Tcl_SaveResult_(); \ *(statePtr) = Tcl_GetObjResult(interp); \ Tcl_IncrRefCount(*(statePtr)); \ Tcl_SetObjResult(interp, Tcl_NewObj()); \ } while(0) -static TCL_DEPRECATED_API("Use Tcl_RestoreInterpState") void Tcl_RestoreResult_(void) {} #define Tcl_RestoreResult(interp, statePtr) \ do { \ - Tcl_RestoreResult_(); \ Tcl_ResetResult(interp); \ Tcl_SetObjResult(interp, *(statePtr)); \ Tcl_DecrRefCount(*(statePtr)); \ } while(0) -static TCL_DEPRECATED_API("Use Tcl_DiscardInterpState") void Tcl_DiscardResult_(void) {} #define Tcl_DiscardResult(statePtr) \ - do { \ - Tcl_DiscardResult_(); \ - Tcl_DecrRefCount(*(statePtr)); \ - } while(0) + Tcl_DecrRefCount(*(statePtr)) #define Tcl_SetResult(interp, result, freeProc) \ do { \ const char *__result = result; \ diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 8349408..b870bca 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -2628,7 +2628,7 @@ TclLindexFlat( /* Handle ArithSeries as special case */ if (TclHasInternalRep(listObj,&tclArithSeriesType)) { Tcl_WideInt listLen = TclArithSeriesObjLength(listObj); - int index; + ListSizeT index; Tcl_Obj *elemObj = NULL; for (i=0 ; i lseq: invalid step = -2 with a = 1 and b = 10 -test lseq-4.3 {TIP examples} { +test lseq-4.3 {TIP examples} knownBug { set examples {# Examples from TIP-629 # --- Begin --- lseq 10 .. 1 @@ -474,7 +474,7 @@ test lseq-4.3 {TIP examples} { # # Ticket 9933cc4d88697f05976accebd31c1e3ba6efe9c6 - lseq corner case -test lseq-4.4 {lseq corner case} -body { +test lseq-4.4 {lseq corner case} -constraints knownBug -body { set tcmd { set res {} set s [catch {lindex [lseq 10 100] 0} e] -- cgit v0.12 From 414f4c9f7c689e4c1cba2c4f568db0ff3b5df688 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 28 Sep 2022 18:41:42 +0000 Subject: WIP on documentation of proposed routines. --- doc/Number.3 | 88 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 88 insertions(+) create mode 100644 doc/Number.3 diff --git a/doc/Number.3 b/doc/Number.3 new file mode 100644 index 0000000..588171e --- /dev/null +++ b/doc/Number.3 @@ -0,0 +1,88 @@ +'\" +'\" Contribution from Don Porter, NIST, 2022. (not subject to US copyright) +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH Tcl_GetNumber 3 8.7 Tcl "Tcl Library Procedures" +.so man.macros +.BS +.SH NAME +Tcl_GetNumber, Tcl_GetNumberFromObj \- get numeric value from Tcl value +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +\fB#include \fR +.sp +int +\fBTcl_GetNumber\fR(\fIinterp, bytes, numBytes, clientDataPtr, typePtr\fR) +.sp +int +\fBTcl_GetNumberFromObj\fR(\fIinterp, objPtr, clientDataPtr, typePtr\fR) +.SH ARGUMENTS +.AS Tcl_Interp clientDataPtr out +.AP Tcl_Interp *interp out +When non-NULL, error information is recorded here when the value is not +in any of the numeric formats recognized by Tcl. +.AP "const char" *bytes in +Points to first byte of the string value to be examined. +.AP size_t numBytes in +The number of bytes, starting at \fIbytes\fR, that should be examined. +If the value \fBTCL_INDEX_NONE\fR is provided, then all bytes should +be examined until the first \fBNUL\fR byte terminates examination. +.AP "void *" *clientDataPtr out +Points to space where a pointer value may be written through which a numeric +value is available to read. +.AP int *typePtr out +Points to space where a value may be written reporting what type of +numeric storage is available to read. +.AP Tcl_Obj *objPtr in +A Tcl value to be examined. +.BE +.SH DESCRIPTION +.PP +These procedures enable callers to retrieve a numeric value from a +Tcl value in a numeric format recognized by Tcl. +.PP +Tcl recognizes many values as numbers. Several examples include: +\fB"0"\fR, \fB" +1"\fR, \fB"-2 "\fR, \fB" 3 "\fR, \fB"0xdad1"\fR, \fB"0d09"\fR, +\fB"1_000_000"\fR, \fB"4.0"\fR, \fB"1e-7"\fR, \fB"NaN"\fR, or \fB"Inf"\fR. +When built-in Tcl commands act on these values as numbers, they are converted +to a numeric representation for efficient handling in C code. Tcl makes +use of three C types to store these representations: \fBdouble\fR, +\fBTcl_WideInt\fR, and \fBmp_int\fR. The \fBdouble\fR type is provided by the +C language standard. The \fBTcl_WideInt\fR type is declared in the Tcl +header file, \fBtcl.h\fR, and is equivalent to the C standard type +\fBlong long\fR on most platforms. The \fBmp_int\fR type is declared in the +header file \fBtclTomMath.h\fR, and implemented by the LibTomMath +multiple-precision integer library, included with Tcl. + +The routines \fBTcl_GetNumber\fR and \fBTcl_GetNumberFromObj\fR perform +the same function. They differ only in how the arguments present the Tcl +value to be examined. \fBTcl_GetNumber\fR accepts a counted string +value in the arguments \fIbytes\fR and \fInumBytes\fR (or a +\fBNUL\fR-terminated string value when \fInumBytes\fR is +\fBTCL_INDEX_NONE\fR). \fBTcl_GetNumberFromObj\fR accepts the Tcl value +in \fIobjPtr\fR. + +Both routines examine the Tcl value and determine whether Tcl recognizes +it as a number. If not, both routines return \fBTCL_ERROR\fR and (when +\fIinterp\fR is not NULL) record an error message and error code +in \fIinterp\fR. + +If the examined value is recognized as a number, both routines return +\fBTCL_OK\fR, and use the pointer arguments \fIclientDataPtr\fR +and \fItypePtr\fR (which may not be NULL) to report information the +caller can use to retrieve the numeric representation. In all cases, +both routines write to *\fIclientDataPtr\fR a pointer to the internal +storage location where Tcl holds the numeric value. When that +internal storage is of type \fBdouble\fR + + + +.SH "SEE ALSO" +Tcl_GetDouble, Tcl_GetDoubleFromObj, Tcl_GetWideIntFromObj +.SH KEYWORDS +double, double value, double type, integer, integer value, integer type, +internal representation, value, value type, string representation -- cgit v0.12 From eea655f8511157d811dc0b7be61de559c52ab81a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 29 Sep 2022 06:45:20 +0000 Subject: Remove "unknown" constraint, since it now works --- tests/lseq.test | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/lseq.test b/tests/lseq.test index 48adfa0..45e3cd3 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -65,7 +65,7 @@ test lseq-1.10 {integer lseq with step} { lseq 1 to 10 by 2 } {1 3 5 7 9} -test lseq-1.11 {error case: increasing wrong step direction} knownBug { +test lseq-1.11 {error case: increasing wrong step direction} { lseq 1 to 10 by -2 } {} @@ -113,7 +113,7 @@ test lseq-1.19 {too many arguments extra numeric value} -body { lseq 12 to 24 by 2 7 } -returnCodes 1 -result {wrong # args: should be "lseq n ??op? n ??by? n??"} -test lseq-1.20 {bug: wrong length computed} knownBug { +test lseq-1.20 {bug: wrong length computed} { lseq 1 to 10 -1 } {} @@ -128,11 +128,11 @@ test lseq-1.22 {n n by -n} { # # Short-hand use cases # -test lseq-2.2 {step magnitude} knownBug { +test lseq-2.2 {step magnitude} { lseq 10 1 2 ;# this is an empty case since step has wrong sign } {} -test lseq-2.3 {step wrong sign} {arithSeriesDouble knownBug} { +test lseq-2.3 {step wrong sign} arithSeriesDouble { lseq 25. 5. 5 ;# ditto - empty list } {} @@ -166,7 +166,7 @@ test lseq-2.10 {integer lseq with step} { lseq 1 10 2 } {1 3 5 7 9} -test lseq-2.11 {error case: increasing wrong step direction} knownBug { +test lseq-2.11 {error case: increasing wrong step direction} { lseq 1 10 -2 } {} @@ -196,7 +196,7 @@ test lseq-2.17 {large numbers} arithSeriesDouble { # Covered: {10 1 2 } {1 10 2} {1 10 -2} {1 1 1} {1 1 1} {-5 17 3} # Missing: {- - +} {- - -} {- + -} {+ - -} {- - +} {+ + -} -test lseq-2.18 {signs} knownBug { +test lseq-2.18 {signs} { list [lseq -10 -1 2] \ [lseq -10 -1 -1] \ [lseq -10 1 -3] \ @@ -390,7 +390,7 @@ test lseq-3.28 {lreverse bug in ArithSeries} {} { list $r $rr [string equal $r [lreverse $rr]] } {{-5 -2 1 4 7 10 13 16} {16 13 10 7 4 1 -2 -5} 1} -test lseq-3.29 {edge case: negative count} knownBug { +test lseq-3.29 {edge case: negative count} { lseq -15 } {} @@ -425,7 +425,7 @@ test lseq-4.2 {start expressions} { ## lseq 1 to 10 by -2 ## # -> lseq: invalid step = -2 with a = 1 and b = 10 -test lseq-4.3 {TIP examples} knownBug { +test lseq-4.3 {TIP examples} { set examples {# Examples from TIP-629 # --- Begin --- lseq 10 .. 1 -- cgit v0.12 From bec96305308d0c234215d25b194f1ff8417dc8b4 Mon Sep 17 00:00:00 2001 From: griffin Date: Thu, 29 Sep 2022 16:10:07 +0000 Subject: Fix bug-99e834bf33 --- generic/tclExecute.c | 2 +- tests/lseq.test | 10 ++++++++++ 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 5f29bfa..fa0dfa2 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4938,7 +4938,7 @@ TEBCresume( /* Decode end-offset index values. */ - index = TclIndexDecode(opnd, length); + index = TclIndexDecode(opnd, length-1); /* Compute value @ index */ if (index >= 0 && index < length) { diff --git a/tests/lseq.test b/tests/lseq.test index e05b32d..518a7bb 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -489,9 +489,19 @@ test lseq-4.4 {lseq corner case} -body { lappend res $s $e } eval $tcmd +} -cleanup { + unset res } -result {0 10 1 {max length of a Tcl list exceeded} 1 {max length of a Tcl list exceeded} 0 10 0 2147483638} +# Ticket 99e834bf33 - lseq, lindex end off by one + +test lseq-4.5 {lindex off by one} -body { + lappend res [eval {lindex [lseq 1 4] end}] + lappend res [eval {lindex [lseq 1 4] end-1}] +} -result {4 3} + + # cleanup ::tcltest::cleanupTests return -- cgit v0.12 From 9e7c607db1c09acf473b8b10df55452b1e907499 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 29 Sep 2022 20:53:43 +0000 Subject: Complete documentation for the TIP 638 routines. --- doc/Number.3 | 53 ++++++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 44 insertions(+), 9 deletions(-) diff --git a/doc/Number.3 b/doc/Number.3 index 65a1332..f93d75d 100644 --- a/doc/Number.3 +++ b/doc/Number.3 @@ -57,7 +57,7 @@ header file, \fBtcl.h\fR, and is equivalent to the C standard type \fBlong long\fR on most platforms. The \fBmp_int\fR type is declared in the header file \fBtclTomMath.h\fR, and implemented by the LibTomMath multiple-precision integer library, included with Tcl. - +.PP The routines \fBTcl_GetNumber\fR and \fBTcl_GetNumberFromObj\fR perform the same function. They differ only in how the arguments present the Tcl value to be examined. \fBTcl_GetNumber\fR accepts a counted string @@ -65,22 +65,57 @@ value in the arguments \fIbytes\fR and \fInumBytes\fR (or a \fBNUL\fR-terminated string value when \fInumBytes\fR is \fBTCL_INDEX_NONE\fR). \fBTcl_GetNumberFromObj\fR accepts the Tcl value in \fIobjPtr\fR. - +.PP Both routines examine the Tcl value and determine whether Tcl recognizes it as a number. If not, both routines return \fBTCL_ERROR\fR and (when \fIinterp\fR is not NULL) record an error message and error code in \fIinterp\fR. - -If the examined value is recognized as a number, both routines return +.PP +If Tcl does recognize the examined value as a number, both routines return \fBTCL_OK\fR, and use the pointer arguments \fIclientDataPtr\fR and \fItypePtr\fR (which may not be NULL) to report information the caller can use to retrieve the numeric representation. Both routines write to *\fIclientDataPtr\fR a pointer to the internal storage location -where Tcl holds the converted numeric value. When that internal storage -is of type \fBdouble\fR - - - +where Tcl holds the converted numeric value. +.PP +When the converted numeric value is stored as a \fBdouble\fR, +a call to math library routine \fBisnan\fR determines whether that +value is not a number (NaN). If so, both \fBTcl_GetNumber\fR and +\fBTcl_GetNumberFromObj\fR write the value \fBTCL_NUMBER_NAN\fR +to *\fItypePtr\fR. If not, both routines write the value +\fBTCL_NUMBER_DOUBLE\fR to *\fItypePtr\fR. These routines report +different type values in these cases because \fBTcl_GetDoubleFromObj\fR +raises an error on NaN values. For both reported type values, +the storage pointer may be cast to type \fBconst double *\fR and +the \fBdouble\fR numeric value may be read through it. +.PP +When the converted numeric value is stored as a \fBTcl_WideInt\fR, +both \fBTcl_GetNumber\fR and \fBTcl_GetNumberFromObj\fR write the +value \fBTCL_NUMBER_INT\fR to *\fItypePtr\fR. +The storage pointer may be cast to type \fBconst Tcl_WideInt *\fR and +the \fBTcl_WideInt\fR numeric value may be read through it. +.PP +When the converted numeric value is stored as an \fBmp_int\fR, +both \fBTcl_GetNumber\fR and \fBTcl_GetNumberFromObj\fR write the +value \fBTCL_NUMBER_BIG\fR to *\fItypePtr\fR. +The storage pointer may be cast to type \fBconst mp_int *\fR and +the \fBmp_int\fR numeric value may be read through it. +.PP +Future releases of Tcl might expand or revise the recognition of +values as numbers. If additional storage representations are +adopted, these routines will add new values to be written to +*\fItypePtr\fR to identify them. Callers should consider how +they should react to unknown values written to *\fItypePtr\fR. +.PP +When callers of these routines read numeric values through the +reported storage pointer, they are accessing memory that belongs +to the Tcl library. The Tcl library has the power to overwrite +or free this memory. The storage pointer reported by a call to +\fBTcl_GetNumber\fR or \fBTcl_GetNumberFromObj\fR should not be +used after the same thread has possibly returned control to the +Tcl library. If longer term access to the numeric value is needed, +it should be copied into memory controlled by the caller. Callers +must not attempt to write through or free the storage pointer. .SH "SEE ALSO" Tcl_GetDouble, Tcl_GetDoubleFromObj, Tcl_GetWideIntFromObj .SH KEYWORDS -- cgit v0.12 From b01f9536cb1fe19d6b97c9a81b4dac4fb98dd5dd Mon Sep 17 00:00:00 2001 From: griffin Date: Fri, 30 Sep 2022 00:03:55 +0000 Subject: Fix various issues with refCounts. --- generic/tclArithSeries.c | 6 ++---- generic/tclCmdAH.c | 7 +++++++ generic/tclListObj.c | 2 -- tests/lseq.test | 14 ++++++++++++-- 4 files changed, 21 insertions(+), 8 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 61b4a9b..ee201fa 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -392,6 +392,7 @@ TclArithSeriesObjStep( } else { *stepObj = Tcl_NewWideIntObj(arithSeriesRepPtr->step); } + Tcl_IncrRefCount(*stepObj); return TCL_OK; } @@ -436,6 +437,7 @@ TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **ele } else { *elementObj = Tcl_NewWideIntObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); } + Tcl_IncrRefCount(*elementObj); return TCL_OK; } @@ -722,11 +724,8 @@ TclArithSeriesObjRange( } TclArithSeriesObjIndex(arithSeriesPtr, fromIdx, &startObj); - Tcl_IncrRefCount(startObj); TclArithSeriesObjIndex(arithSeriesPtr, toIdx, &endObj); - Tcl_IncrRefCount(endObj); TclArithSeriesObjStep(arithSeriesPtr, &stepObj); - Tcl_IncrRefCount(stepObj); if (Tcl_IsShared(arithSeriesPtr) || ((arithSeriesPtr->refCount > 1))) { @@ -857,7 +856,6 @@ TclArithSeriesGetElements( } return TCL_ERROR; } - Tcl_IncrRefCount(objv[i]); } } } else { diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 07541bd..3048e82 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -3027,6 +3027,13 @@ ForeachAssignments( varValuePtr = Tcl_ObjSetVar2(interp, statePtr->varvList[i][v], NULL, valuePtr, TCL_LEAVE_ERR_MSG); + if (isarithseries) { + /* arith values have implicit reference + ** Make sure value is cleaned up when var goes away + */ + Tcl_DecrRefCount(valuePtr); + } + if (varValuePtr == NULL) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (setting %s loop variable \"%s\")", diff --git a/generic/tclListObj.c b/generic/tclListObj.c index d18ad59..598ff6f 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -2641,7 +2641,6 @@ TclLindexFlat( } if (i==0) { TclArithSeriesObjIndex(listObj, index, &elemObj); - Tcl_IncrRefCount(elemObj); } else if (index > 0) { Tcl_DecrRefCount(elemObj); TclNewObj(elemObj); @@ -3304,7 +3303,6 @@ SetListFromAny( if (TclArithSeriesObjIndex(objPtr, j, &elemPtrs[j]) != TCL_OK) { return TCL_ERROR; } - Tcl_IncrRefCount(elemPtrs[j]);/* Since list now holds ref to it. */ } } else { diff --git a/tests/lseq.test b/tests/lseq.test index 518a7bb..7daa59c 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -223,6 +223,8 @@ test lseq-3.1 {experiement} { if {$ans eq {}} { set ans OK } + unset factor + unset l set ans } {OK} @@ -376,13 +378,18 @@ test lseq-3.26 {lsort shimmer} arithSeriesShimmer { list ${rep-before} $lexical_sort ${rep-after} } {arithseries {0 1 10 11 12 13 14 15 2 3 4 5 6 7 8 9} arithseries} -test lseq-3.27 {lreplace shimmer} arithSeriesShimmer { +test lseq-3.27 {lreplace shimmer} -constraints arithSeriesShimmer -body { set r [lseq 15 0] set rep-before [lindex [tcl::unsupported::representation $r] 3] set lexical_sort [lreplace $r 3 5 A B C] set rep-after [lindex [tcl::unsupported::representation $r] 3] list ${rep-before} $lexical_sort ${rep-after} -} {arithseries {15 14 13 A B C 9 8 7 6 5 4 3 2 1 0} arithseries} +} -cleanup { + unset r + unset rep-before + unset lexical_sort + unset rep-after +} -result {arithseries {15 14 13 A B C 9 8 7 6 5 4 3 2 1 0} arithseries} test lseq-3.28 {lreverse bug in ArithSeries} {} { set r [lseq -5 17 3] @@ -499,11 +506,14 @@ test lseq-4.4 {lseq corner case} -body { test lseq-4.5 {lindex off by one} -body { lappend res [eval {lindex [lseq 1 4] end}] lappend res [eval {lindex [lseq 1 4] end-1}] +} -cleanup { + unset res } -result {4 3} # cleanup ::tcltest::cleanupTests + return # Local Variables: -- cgit v0.12 From f9753a5e4109e31176bc1da885ff5ec23839662b Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 30 Sep 2022 11:30:11 +0000 Subject: Replace incorrect use of TclGetNumberFromObj --- generic/tclArithSeries.c | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 1302780..51f27b2 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -307,12 +307,9 @@ TclNewArithSeriesObj( assignNumber(useDoubles, &end, &dend, endObj); } if (lenObj) { - int tcl_number_type; - Tcl_WideInt *valuePtr; - if (TclGetNumberFromObj(interp, lenObj, (ClientData*)&valuePtr, &tcl_number_type) != TCL_OK) { + if (TCL_OK != Tcl_GetWideIntFromObj(interp, lenObj, &len)) { return TCL_ERROR; } - len = *valuePtr; } if (startObj && endObj) { -- cgit v0.12 From 2d5ed059a0d65242470b8ef41870bbadaa67e927 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 4 Oct 2022 15:52:13 +0000 Subject: TIP #641 implementation: Let Tcl_GetBoolean(FromObj) handle (C99) bool --- doc/BoolObj.3 | 12 ++++++------ generic/tclDecls.h | 14 ++++++++++++++ generic/tclTest.c | 50 +++++++++++++++++++++++++++----------------------- generic/tclTestObj.c | 15 ++++++++------- win/tclWinSock.c | 18 ++++++------------ 5 files changed, 61 insertions(+), 48 deletions(-) diff --git a/doc/BoolObj.3 b/doc/BoolObj.3 index 47a2189..71580af 100644 --- a/doc/BoolObj.3 +++ b/doc/BoolObj.3 @@ -20,7 +20,7 @@ Tcl_Obj * \fBTcl_SetBooleanObj\fR(\fIobjPtr, intValue\fR) .sp int -\fBTcl_GetBooleanFromObj\fR(\fIinterp, objPtr, intPtr\fR) +\fBTcl_GetBooleanFromObj\fR(\fIinterp, objPtr, boolPtr\fR) .sp int \fBTcl_GetBoolFromObj\fR(\fIinterp, objPtr, flags. charPtr\fR) @@ -35,7 +35,7 @@ retrieve a boolean value. If a boolean value cannot be retrieved, an error message is left in the interpreter's result value unless \fIinterp\fR is NULL. -.AP int *intPtr out +.AP "bool \&| int" *boolPtr out Points to place where \fBTcl_GetBooleanFromObj\fR stores the boolean value (0 or 1) obtained from \fIobjPtr\fR. .AP char *charPtr out @@ -71,13 +71,13 @@ any former value stored in \fI*objPtr\fR. from the value stored in \fI*objPtr\fR. If \fIobjPtr\fR holds a string value recognized by \fBTcl_GetBoolean\fR, then the recognized boolean value is written at the address given -by \fIintPtr\fR. +by \fIboolPtr\fR. If \fIobjPtr\fR holds any value recognized as a number by Tcl, then if that value is zero a 0 is written at -the address given by \fIintPtr\fR and if that -value is non-zero a 1 is written at the address given by \fIintPtr\fR. +the address given by \fIboolPtr\fR and if that +value is non-zero a 1 is written at the address given by \fIboolPtr\fR. In all cases where a value is written at the address given -by \fIintPtr\fR, \fBTcl_GetBooleanFromObj\fR returns \fBTCL_OK\fR. +by \fIboolPtr\fR, \fBTcl_GetBooleanFromObj\fR returns \fBTCL_OK\fR. If the value of \fIobjPtr\fR does not meet any of the conditions above, then \fBTCL_ERROR\fR is returned and an error message is left in the interpreter's result unless \fIinterp\fR is NULL. diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 2d18bcc..74c74db 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4344,6 +4344,8 @@ static TCL_DEPRECATED_API("Use Tcl_DiscardInterpState") void Tcl_DiscardResult_( Tcl_GetUnicodeFromObj(objPtr, (int *)NULL) #undef Tcl_GetBytesFromObj #undef Tcl_GetIndexFromObjStruct +#undef Tcl_GetBooleanFromObj +#undef Tcl_GetBoolean #ifdef TCL_NO_DEPRECATED #undef Tcl_GetStringFromObj #undef Tcl_GetUnicodeFromObj @@ -4354,6 +4356,12 @@ static TCL_DEPRECATED_API("Use Tcl_DiscardInterpState") void Tcl_DiscardResult_( (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tclGetBytesFromObj(interp, objPtr, (int *)(sizePtr)) : tclStubsPtr->tcl_GetBytesFromObj(interp, objPtr, (size_t *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) +#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ + (sizeof(*(boolPtr)) == sizeof(int) ? tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \ + ((sizeof(*(boolPtr)) == sizeof(char)) ? Tcl_GetBoolFromObj(interp, objPtr, 0, (char *)(boolPtr)) : (Tcl_Panic("Wrong bool var for %s", "Tcl_GetBooleanFromObj"), TCL_ERROR))) +#define Tcl_GetBoolean(interp, src, boolPtr) \ + (sizeof(*(boolPtr)) == sizeof(int) ? tclStubsPtr->tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \ + ((sizeof(*(boolPtr)) == sizeof(char)) ? Tcl_GetBool(interp, src, 0, (char *)(boolPtr)) : (Tcl_Panic("Wrong bool var for %s", "Tcl_GetBoolean"), TCL_ERROR))) #ifdef TCL_NO_DEPRECATED #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? tclStubsPtr->tcl_GetStringFromObj(objPtr, (int *)(sizePtr)) : tclStubsPtr->tclGetStringFromObj(objPtr, (size_t *)(sizePtr))) @@ -4367,6 +4375,12 @@ static TCL_DEPRECATED_API("Use Tcl_DiscardInterpState") void Tcl_DiscardResult_( (sizeof(*(sizePtr)) <= sizeof(int) ? (TclGetBytesFromObj)(interp, objPtr, (int *)(sizePtr)) : (Tcl_GetBytesFromObj)(interp, objPtr, (size_t *)(sizePtr))) #define Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags, indexPtr) \ ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) +#define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ + (sizeof(*(boolPtr)) == sizeof(int) ? Tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \ + ((sizeof(*(boolPtr)) == sizeof(char)) ? Tcl_GetBoolFromObj(interp, objPtr, 0, (char *)(boolPtr)) : (Tcl_Panic("Wrong bool var for %s", "Tcl_GetBooleanFromObj"), TCL_ERROR))) +#define Tcl_GetBoolean(interp, src, boolPtr) \ + (sizeof(*(boolPtr)) == sizeof(int) ? Tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \ + ((sizeof(*(boolPtr)) == sizeof(char)) ? Tcl_GetBool(interp, src, 0, (char *)(boolPtr)) : (Tcl_Panic("Wrong bool var for %s", "Tcl_GetBoolean"), TCL_ERROR))) #ifdef TCL_NO_DEPRECATED #define Tcl_GetStringFromObj(objPtr, sizePtr) \ (sizeof(*(sizePtr)) <= sizeof(int) ? (Tcl_GetStringFromObj)(objPtr, (int *)(sizePtr)) : (TclGetStringFromObj)(objPtr, (size_t *)(sizePtr))) diff --git a/generic/tclTest.c b/generic/tclTest.c index 8218a33..30ea4e5 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -33,6 +33,7 @@ #endif #include "tclOO.h" #include +#include /* * Required for Testregexp*Cmd @@ -2326,7 +2327,7 @@ TesteventProc( Tcl_Obj *command = ev->command; int result = Tcl_EvalObjEx(interp, command, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); - char retval; + bool retval; if (result != TCL_OK) { Tcl_AddErrorInfo(interp, @@ -2334,8 +2335,8 @@ TesteventProc( Tcl_BackgroundException(interp, TCL_ERROR); return 1; /* Avoid looping on errors */ } - if (Tcl_GetBoolFromObj(interp, Tcl_GetObjResult(interp), - 0, &retval) != TCL_OK) { + if (Tcl_GetBooleanFromObj(interp, Tcl_GetObjResult(interp), + &retval) != TCL_OK) { Tcl_AddErrorInfo(interp, " (return value from \"testevent\" callback)"); Tcl_BackgroundException(interp, TCL_ERROR); @@ -2898,7 +2899,8 @@ TestlinkCmd( static Tcl_WideUInt uwideVar = 123; static int created = 0; char buffer[2*TCL_DOUBLE_SPACE]; - int writable, flag; + bool writable; + int flag; Tcl_Obj *tmp; if (argc < 2) { @@ -2935,7 +2937,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "int", &intVar, TCL_LINK_INT | flag) != TCL_OK) { return TCL_ERROR; @@ -2943,7 +2945,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "real", &realVar, TCL_LINK_DOUBLE | flag) != TCL_OK) { return TCL_ERROR; @@ -2951,7 +2953,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "bool", &boolVar, TCL_LINK_BOOLEAN | flag) != TCL_OK) { return TCL_ERROR; @@ -2959,7 +2961,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "string", &stringVar, TCL_LINK_STRING | flag) != TCL_OK) { return TCL_ERROR; @@ -2967,7 +2969,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[6], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "wide", &wideVar, TCL_LINK_WIDE_INT | flag) != TCL_OK) { return TCL_ERROR; @@ -2975,7 +2977,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[7], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "char", &charVar, TCL_LINK_CHAR | flag) != TCL_OK) { return TCL_ERROR; @@ -2983,7 +2985,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[8], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "uchar", &ucharVar, TCL_LINK_UCHAR | flag) != TCL_OK) { return TCL_ERROR; @@ -2991,7 +2993,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[9], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "short", &shortVar, TCL_LINK_SHORT | flag) != TCL_OK) { return TCL_ERROR; @@ -2999,7 +3001,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[10], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "ushort", &ushortVar, TCL_LINK_USHORT | flag) != TCL_OK) { return TCL_ERROR; @@ -3007,7 +3009,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[11], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "uint", &uintVar, TCL_LINK_UINT | flag) != TCL_OK) { return TCL_ERROR; @@ -3015,7 +3017,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[12], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "long", &longVar, TCL_LINK_LONG | flag) != TCL_OK) { return TCL_ERROR; @@ -3023,7 +3025,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[13], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "ulong", &ulongVar, TCL_LINK_ULONG | flag) != TCL_OK) { return TCL_ERROR; @@ -3031,7 +3033,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[14], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "float", &floatVar, TCL_LINK_FLOAT | flag) != TCL_OK) { return TCL_ERROR; @@ -3039,7 +3041,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[15], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "uwide", &uwideVar, TCL_LINK_WIDE_UINT | flag) != TCL_OK) { return TCL_ERROR; @@ -5531,7 +5533,7 @@ TestsaveresultCmd( { Interp* iPtr = (Interp*) interp; int result, index; - char discard; + bool discard; Tcl_SavedResult state; Tcl_Obj *objPtr; static const char *const optionStrings[] = { @@ -5553,7 +5555,7 @@ TestsaveresultCmd( &index) != TCL_OK) { return TCL_ERROR; } - if (Tcl_GetBoolFromObj(interp, objv[3], 0, &discard) != TCL_OK) { + if (Tcl_GetBooleanFromObj(interp, objv[3], &discard) != TCL_OK) { return TCL_ERROR; } @@ -6515,7 +6517,7 @@ TestSocketCmd( if ((cmdName[0] == 't') && (strncmp(cmdName, "testflags", len) == 0)) { Tcl_Channel hChannel; int modePtr; - int testMode; + bool testMode; TcpState *statePtr; /* Set test value in the socket driver */ @@ -6739,7 +6741,8 @@ TestFilesystemObjCmd( int objc, Tcl_Obj *const objv[]) { - int res, boolVal; + int res; + bool boolVal; const char *msg; if (objc != 2) { @@ -7110,7 +7113,8 @@ TestSimpleFilesystemObjCmd( int objc, Tcl_Obj *const objv[]) { - int res, boolVal; + int res; + bool boolVal; const char *msg; if (objc != 2) { diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index a03a60a..6c9d04b 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -24,6 +24,7 @@ # include "tclTomMath.h" #endif #include "tclStringRep.h" +#include #ifdef __GNUC__ /* @@ -292,9 +293,9 @@ TestbignumobjCmd( return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetWideIntObj(varPtr[varIndex], mp_iszero(&bignumValue)); + Tcl_SetBooleanObj(varPtr[varIndex], mp_iszero(&bignumValue)); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(mp_iszero(&bignumValue))); + SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(mp_iszero(&bignumValue))); } mp_clear(&bignumValue); break; @@ -353,7 +354,7 @@ TestbooleanobjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { size_t varIndex; - int boolValue; + bool boolValue; const char *subCmd; Tcl_Obj **varPtr; @@ -387,9 +388,9 @@ TestbooleanobjCmd( */ if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetWideIntObj(varPtr[varIndex], boolValue != 0); + Tcl_SetWideIntObj(varPtr[varIndex], boolValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(boolValue != 0)); + SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(boolValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "get") == 0) { @@ -412,9 +413,9 @@ TestbooleanobjCmd( return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetWideIntObj(varPtr[varIndex], boolValue == 0); + Tcl_SetBooleanObj(varPtr[varIndex], !boolValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(boolValue == 0)); + SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(!boolValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else { diff --git a/win/tclWinSock.c b/win/tclWinSock.c index f1a6a5e..3962859 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -1206,15 +1206,12 @@ TcpSetOptionProc( sock = statePtr->sockets->fd; if (!strcasecmp(optionName, "-keepalive")) { - BOOL val = FALSE; - int boolVar, rtn; + BOOL val; + int rtn; - if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) { + if (Tcl_GetBoolean(interp, value, &val) != TCL_OK) { return TCL_ERROR; } - if (boolVar) { - val = TRUE; - } rtn = setsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (const char *) &val, sizeof(BOOL)); if (rtn != 0) { @@ -1228,15 +1225,12 @@ TcpSetOptionProc( } return TCL_OK; } else if (!strcasecmp(optionName, "-nagle")) { - BOOL val = FALSE; - int boolVar, rtn; + BOOL val; + int rtn; - if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) { + if (Tcl_GetBoolean(interp, value, &val) != TCL_OK) { return TCL_ERROR; } - if (!boolVar) { - val = TRUE; - } rtn = setsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (const char *) &val, sizeof(BOOL)); if (rtn != 0) { -- cgit v0.12 From 3f371a5084c05daba396645abd9a25deb3d023d1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 4 Oct 2022 15:56:08 +0000 Subject: =?UTF-8?q?Fix=20g++=20warning:=20tclEvent.c:1519:10:=20warning:?= =?UTF-8?q?=20declaration=20of=20=E2=80=98enum=20Tcl=5FVwaitObjCmd(void*,?= =?UTF-8?q?=20Tcl=5FInterp*,=20int,=20Tcl=5FObj*=20const*)::options?= =?UTF-8?q?=E2=80=99=20shadows=20a=20previous=20local=20[-Wshadow]?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- generic/tclEvent.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 183ac82..1e2e7bf 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1511,12 +1511,12 @@ Tcl_VwaitObjCmd( Tcl_Channel chan; Tcl_WideInt diff = -1; VwaitItem localItems[32], *vwaitItems = localItems; - static const char *const options[] = { + static const char *const vWaitOptionStrings[] = { "-all", "-extended", "-nofileevents", "-noidleevents", "-notimerevents", "-nowindowevents", "-readable", "-timeout", "-variable", "-writable", "--", NULL }; - enum options { + enum vWaitOptions { OPT_ALL, OPT_EXTD, OPT_NO_FEVTS, OPT_NO_IEVTS, OPT_NO_TEVTS, OPT_NO_WEVTS, OPT_READABLE, OPT_TIMEOUT, OPT_VARIABLE, OPT_WRITABLE, OPT_LAST @@ -1541,7 +1541,7 @@ Tcl_VwaitObjCmd( if (name[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, + if (Tcl_GetIndexFromObj(interp, objv[i], vWaitOptionStrings, "option", 0, &index) != TCL_OK) { result = TCL_ERROR; goto done; @@ -1570,7 +1570,7 @@ Tcl_VwaitObjCmd( needArg: Tcl_ResetResult(interp); Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "argument required for \"%s\"", options[index])); + "argument required for \"%s\"", vWaitOptionStrings[index])); Tcl_SetErrorCode(interp, "TCL", "EVENT", "ARGUMENT", NULL); result = TCL_ERROR; goto done; -- cgit v0.12 From dfa6b32e11082614f40cc86e0aab004b8e7aad83 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 4 Oct 2022 18:25:18 +0000 Subject: silence compiler warning --- generic/tclParse.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclParse.c b/generic/tclParse.c index 95458ea..df218a7 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -1480,7 +1480,7 @@ Tcl_ParseVarName( TCL_SUBST_ALL, parsePtr)) { goto error; } - if ((parsePtr->term == src+numBytes)){ + if (parsePtr->term == src+numBytes){ if (parsePtr->interp != NULL) { Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( "missing )", -1)); -- cgit v0.12 From 00199ad335823ec6b18983d1188f70b0b065b25e Mon Sep 17 00:00:00 2001 From: griffin Date: Tue, 4 Oct 2022 20:15:38 +0000 Subject: Fix some bugs in lseq --- generic/tclArithSeries.c | 9 +++++++-- generic/tclCmdAH.c | 17 +++++------------ generic/tclExecute.c | 7 ++++++- generic/tclListObj.c | 8 ++++---- tests/lseq.test | 2 +- 5 files changed, 23 insertions(+), 20 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index ee201fa..6a02caa 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -392,7 +392,6 @@ TclArithSeriesObjStep( } else { *stepObj = Tcl_NewWideIntObj(arithSeriesRepPtr->step); } - Tcl_IncrRefCount(*stepObj); return TCL_OK; } @@ -437,7 +436,6 @@ TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **ele } else { *elementObj = Tcl_NewWideIntObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); } - Tcl_IncrRefCount(*elementObj); return TCL_OK; } @@ -724,8 +722,11 @@ TclArithSeriesObjRange( } TclArithSeriesObjIndex(arithSeriesPtr, fromIdx, &startObj); + Tcl_IncrRefCount(startObj); TclArithSeriesObjIndex(arithSeriesPtr, toIdx, &endObj); + Tcl_IncrRefCount(endObj); TclArithSeriesObjStep(arithSeriesPtr, &stepObj); + Tcl_IncrRefCount(stepObj); if (Tcl_IsShared(arithSeriesPtr) || ((arithSeriesPtr->refCount > 1))) { @@ -856,6 +857,7 @@ TclArithSeriesGetElements( } return TCL_ERROR; } + Tcl_IncrRefCount(objv[i]); } } } else { @@ -912,8 +914,11 @@ TclArithSeriesObjReverse( len = arithSeriesRepPtr->len; TclArithSeriesObjIndex(arithSeriesPtr, (len-1), &startObj); + Tcl_IncrRefCount(startObj); TclArithSeriesObjIndex(arithSeriesPtr, 0, &endObj); + Tcl_IncrRefCount(endObj); TclArithSeriesObjStep(arithSeriesPtr, &stepObj); + Tcl_IncrRefCount(stepObj); if (isDouble) { Tcl_GetDoubleFromObj(NULL, startObj, &dstart); diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 3048e82..a5c5330 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2866,13 +2866,13 @@ EachloopCmd( /* Values */ if (TclHasInternalRep(objv[2+i*2],&tclArithSeriesType)) { /* Special case for Arith Series */ - statePtr->vCopyList[i] = TclArithSeriesObjCopy(interp, objv[2+i*2]); - if (statePtr->vCopyList[i] == NULL) { + statePtr->aCopyList[i] = TclArithSeriesObjCopy(interp, objv[2+i*2]); + if (statePtr->aCopyList[i] == NULL) { result = TCL_ERROR; goto done; } /* Don't compute values here, wait until the last momement */ - statePtr->argcList[i] = TclArithSeriesObjLength(statePtr->vCopyList[i]); + statePtr->argcList[i] = TclArithSeriesObjLength(statePtr->aCopyList[i]); } else { /* List values */ statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]); @@ -3005,12 +3005,12 @@ ForeachAssignments( Tcl_Obj *valuePtr, *varValuePtr; for (i=0 ; inumLists ; i++) { - int isarithseries = TclHasInternalRep(statePtr->vCopyList[i],&tclArithSeriesType); + int isarithseries = TclHasInternalRep(statePtr->aCopyList[i],&tclArithSeriesType); for (v=0 ; vvarcList[i] ; v++) { k = statePtr->index[i]++; if (k < statePtr->argcList[i]) { if (isarithseries) { - if (TclArithSeriesObjIndex(statePtr->vCopyList[i], k, &valuePtr) != TCL_OK) { + if (TclArithSeriesObjIndex(statePtr->aCopyList[i], k, &valuePtr) != TCL_OK) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (setting %s loop variable \"%s\")", (statePtr->resultList != NULL ? "lmap" : "foreach"), @@ -3027,13 +3027,6 @@ ForeachAssignments( varValuePtr = Tcl_ObjSetVar2(interp, statePtr->varvList[i][v], NULL, valuePtr, TCL_LEAVE_ERR_MSG); - if (isarithseries) { - /* arith values have implicit reference - ** Make sure value is cleaned up when var goes away - */ - Tcl_DecrRefCount(valuePtr); - } - if (varValuePtr == NULL) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (setting %s loop variable \"%s\")", diff --git a/generic/tclExecute.c b/generic/tclExecute.c index fa0dfa2..7c7bbfd 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4883,6 +4883,7 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } + Tcl_IncrRefCount(objResultPtr); // reference held here goto lindexDone; } @@ -5187,7 +5188,11 @@ TEBCresume( */ do { - Tcl_ListObjIndex(NULL, value2Ptr, i, &o); + if (isArithSeries) { + TclArithSeriesObjIndex(value2Ptr, i, &o); + } else { + Tcl_ListObjIndex(NULL, value2Ptr, i, &o); + } if (o != NULL) { s2 = TclGetStringFromObj(o, &s2len); } else { diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 598ff6f..62bc162 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1369,6 +1369,9 @@ TclListObjCopy( Tcl_Obj *copyObj; if (!TclHasInternalRep(listObj, &tclListType)) { + if (TclHasInternalRep(listObj,&tclArithSeriesType)) { + return TclArithSeriesObjCopy(interp, listObj); + } if (SetListFromAny(interp, listObj) != TCL_OK) { return NULL; } @@ -1943,10 +1946,6 @@ Tcl_ListObjIndex( Tcl_Obj **elemObjs; ListSizeT numElems; - if (TclHasInternalRep(listObj,&tclArithSeriesType)) { - return TclArithSeriesObjIndex(listObj, index, objPtrPtr); - } - /* * TODO * Unlike the original list code, this does not optimize for lindex'ing @@ -2642,6 +2641,7 @@ TclLindexFlat( if (i==0) { TclArithSeriesObjIndex(listObj, index, &elemObj); } else if (index > 0) { + /* ArithSeries cannot be a list of lists */ Tcl_DecrRefCount(elemObj); TclNewObj(elemObj); Tcl_IncrRefCount(elemObj); diff --git a/tests/lseq.test b/tests/lseq.test index 7daa59c..2e5d7e1 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { testConstraint arithSeriesDouble 1 testConstraint arithSeriesShimmer 1 -testConstraint arithSeriesShimmerOk 0 +testConstraint arithSeriesShimmerOk 1 ## Arg errors test lseq-1.1 {error cases} -body { -- cgit v0.12 From 4b1d6e9ae2d95e94f8d3c2113e43a9dbc45f4597 Mon Sep 17 00:00:00 2001 From: griffin Date: Tue, 4 Oct 2022 22:05:19 +0000 Subject: Fix some bugs in lseq --- generic/tclCmdAH.c | 10 +++++----- tests/lseq.test | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 6a45a0b..d1756de 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2720,13 +2720,13 @@ EachloopCmd( /* Values */ if (TclHasInternalRep(objv[2+i*2],&tclArithSeriesType)) { /* Special case for Arith Series */ - statePtr->vCopyList[i] = TclArithSeriesObjCopy(interp, objv[2+i*2]); - if (statePtr->vCopyList[i] == NULL) { + statePtr->aCopyList[i] = TclArithSeriesObjCopy(interp, objv[2+i*2]); + if (statePtr->aCopyList[i] == NULL) { result = TCL_ERROR; goto done; } /* Don't compute values here, wait until the last momement */ - statePtr->argcList[i] = TclArithSeriesObjLength(statePtr->vCopyList[i]); + statePtr->argcList[i] = TclArithSeriesObjLength(statePtr->aCopyList[i]); } else { /* List values */ statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]); @@ -2860,12 +2860,12 @@ ForeachAssignments( Tcl_Obj *valuePtr, *varValuePtr; for (i=0 ; inumLists ; i++) { - int isarithseries = TclHasInternalRep(statePtr->vCopyList[i],&tclArithSeriesType); + int isarithseries = TclHasInternalRep(statePtr->aCopyList[i],&tclArithSeriesType); for (v=0 ; vvarcList[i] ; v++) { k = statePtr->index[i]++; if (k < statePtr->argcList[i]) { if (isarithseries) { - if (TclArithSeriesObjIndex(statePtr->vCopyList[i], k, &valuePtr) != TCL_OK) { + if (TclArithSeriesObjIndex(statePtr->aCopyList[i], k, &valuePtr) != TCL_OK) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (setting %s loop variable \"%s\")", (statePtr->resultList != NULL ? "lmap" : "foreach"), diff --git a/tests/lseq.test b/tests/lseq.test index 8bd8114..19ae348 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { testConstraint arithSeriesDouble 1 testConstraint arithSeriesShimmer 1 -testConstraint arithSeriesShimmerOk 0 +testConstraint arithSeriesShimmerOk 1 ## Arg errors test lseq-1.1 {error cases} -body { -- cgit v0.12 From 3cb6c489a3c0515c7b3aade0aaa139e637400559 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 5 Oct 2022 06:41:28 +0000 Subject: Missing error-check in Tcl_GetWideIntFromObj (backported from 9.0, was already fixed there) --- generic/tclArithSeries.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 6a02caa..11a4254 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -306,7 +306,9 @@ TclNewArithSeriesObj( assignNumber(useDoubles, &end, &dend, endObj); } if (lenObj) { - Tcl_GetWideIntFromObj(NULL, lenObj, &len); + if (TCL_OK != Tcl_GetWideIntFromObj(interp, lenObj, &len)) { + return TCL_ERROR; + } } if (startObj && endObj) { @@ -339,7 +341,7 @@ TclNewArithSeriesObj( } } - if (len > ListSizeT_MAX) { + if (TCL_MAJOR_VERSION < 9 && len > ListSizeT_MAX) { Tcl_SetObjResult( interp, Tcl_NewStringObj("max length of a Tcl list exceeded", -1)); -- cgit v0.12 From 4721ffe64fe11287997ec892d58c375a73e3876d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 5 Oct 2022 15:31:31 +0000 Subject: Fix [1599352cca] and related issues --- generic/tclDictObj.c | 51 ++++++++++++++++++++++++++------------------------- generic/tclInt.h | 2 +- generic/tclListObj.c | 7 ++++--- generic/tclUtil.c | 13 +++++++------ 4 files changed, 38 insertions(+), 35 deletions(-) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index ba9ab98..3fe1800 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -265,7 +265,7 @@ DeleteChainTable( ChainEntry *cPtr; for (cPtr=dict->entryChainHead ; cPtr!=NULL ; cPtr=cPtr->nextPtr) { - Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry); + Tcl_Obj *valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); TclDecrRefCount(valuePtr); } @@ -312,7 +312,7 @@ DeleteChainEntry( if (cPtr == NULL) { return 0; } else { - Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry); + Tcl_Obj *valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); TclDecrRefCount(valuePtr); } @@ -364,7 +364,7 @@ DupDictInternalRep( Tcl_Obj *copyPtr) { Dict *oldDict = DICT(srcPtr); - Dict *newDict = ckalloc(sizeof(Dict)); + Dict *newDict = (Dict *)ckalloc(sizeof(Dict)); ChainEntry *cPtr; /* @@ -373,8 +373,8 @@ DupDictInternalRep( InitChainTable(newDict); for (cPtr=oldDict->entryChainHead ; cPtr!=NULL ; cPtr=cPtr->nextPtr) { - Tcl_Obj *key = Tcl_GetHashKey(&oldDict->table, &cPtr->entry); - Tcl_Obj *valuePtr = Tcl_GetHashValue(&cPtr->entry); + Tcl_Obj *key = (Tcl_Obj *)Tcl_GetHashKey(&oldDict->table, &cPtr->entry); + Tcl_Obj *valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); int n; Tcl_HashEntry *hPtr = CreateChainEntry(newDict, key, &n); @@ -492,7 +492,8 @@ UpdateStringOfDict( Dict *dict = DICT(dictPtr); ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; - int i, length, bytesNeeded = 0; + int i, length; + unsigned int bytesNeeded = 0; const char *elem; char *dst; @@ -517,7 +518,7 @@ UpdateStringOfDict( if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; } else { - flagPtr = ckalloc(numElems); + flagPtr = (char *)ckalloc(numElems); } for (i=0,cPtr=dict->entryChainHead; inextPtr) { /* @@ -526,22 +527,22 @@ UpdateStringOfDict( */ flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); - keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry); + keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry); elem = TclGetStringFromObj(keyPtr, &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i); - if (bytesNeeded < 0) { + if (bytesNeeded > INT_MAX) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } flagPtr[i+1] = TCL_DONT_QUOTE_HASH; - valuePtr = Tcl_GetHashValue(&cPtr->entry); + valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); elem = TclGetStringFromObj(valuePtr, &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i+1); - if (bytesNeeded < 0) { + if (bytesNeeded > INT_MAX) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } } - if (bytesNeeded > INT_MAX - numElems + 1) { + if (bytesNeeded + numElems > INT_MAX + 1U) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } bytesNeeded += numElems; @@ -555,13 +556,13 @@ UpdateStringOfDict( dst = dictPtr->bytes; for (i=0,cPtr=dict->entryChainHead; inextPtr) { flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); - keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry); + keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry); elem = TclGetStringFromObj(keyPtr, &length); dst += TclConvertElement(elem, length, dst, flagPtr[i]); *dst++ = ' '; flagPtr[i+1] |= TCL_DONT_QUOTE_HASH; - valuePtr = Tcl_GetHashValue(&cPtr->entry); + valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); elem = TclGetStringFromObj(valuePtr, &length); dst += TclConvertElement(elem, length, dst, flagPtr[i+1]); *dst++ = ' '; @@ -600,7 +601,7 @@ SetDictFromAny( { Tcl_HashEntry *hPtr; int isNew; - Dict *dict = ckalloc(sizeof(Dict)); + Dict *dict = (Dict *)ckalloc(sizeof(Dict)); InitChainTable(dict); @@ -625,7 +626,7 @@ SetDictFromAny( /* Store key and value in the hash table we're building. */ hPtr = CreateChainEntry(dict, objv[i], &isNew); if (!isNew) { - Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr); + Tcl_Obj *discardedValue = (Tcl_Obj *)Tcl_GetHashValue(hPtr); /* * Not really a well-formed dictionary as there are duplicate @@ -690,7 +691,7 @@ SetDictFromAny( /* Store key and value in the hash table we're building. */ hPtr = CreateChainEntry(dict, keyPtr, &isNew); if (!isNew) { - Tcl_Obj *discardedValue = Tcl_GetHashValue(hPtr); + Tcl_Obj *discardedValue = (Tcl_Obj *)Tcl_GetHashValue(hPtr); TclDecrRefCount(keyPtr); TclDecrRefCount(discardedValue); @@ -809,7 +810,7 @@ TclTraceDictPath( Tcl_IncrRefCount(tmpObj); Tcl_SetHashValue(hPtr, tmpObj); } else { - tmpObj = Tcl_GetHashValue(hPtr); + tmpObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr); if (tmpObj->typePtr != &tclDictType && SetDictFromAny(interp, tmpObj) != TCL_OK) { return NULL; @@ -919,7 +920,7 @@ Tcl_DictObjPut( hPtr = CreateChainEntry(dict, keyPtr, &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { - Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr); + Tcl_Obj *oldValuePtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr); TclDecrRefCount(oldValuePtr); } @@ -969,7 +970,7 @@ Tcl_DictObjGet( if (hPtr == NULL) { *valuePtrPtr = NULL; } else { - *valuePtrPtr = Tcl_GetHashValue(hPtr); + *valuePtrPtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr); } return TCL_OK; } @@ -1115,10 +1116,10 @@ Tcl_DictObjFirst( searchPtr->next = cPtr->nextPtr; dict->refCount++; if (keyPtrPtr != NULL) { - *keyPtrPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry); + *keyPtrPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry); } if (valuePtrPtr != NULL) { - *valuePtrPtr = Tcl_GetHashValue(&cPtr->entry); + *valuePtrPtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); } } return TCL_OK; @@ -1181,7 +1182,7 @@ Tcl_DictObjNext( Tcl_Panic("concurrent dictionary modification and search"); } - cPtr = searchPtr->next; + cPtr = (ChainEntry *)searchPtr->next; if (cPtr == NULL) { Tcl_DictObjDone(searchPtr); *donePtr = 1; @@ -1191,11 +1192,11 @@ Tcl_DictObjNext( searchPtr->next = cPtr->nextPtr; *donePtr = 0; if (keyPtrPtr != NULL) { - *keyPtrPtr = Tcl_GetHashKey( + *keyPtrPtr = (Tcl_Obj *)Tcl_GetHashKey( &((Dict *)searchPtr->dictionaryPtr)->table, &cPtr->entry); } if (valuePtrPtr != NULL) { - *valuePtrPtr = Tcl_GetHashValue(&cPtr->entry); + *valuePtrPtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); } } diff --git a/generic/tclInt.h b/generic/tclInt.h index 63fcf62..8c3efb5 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3146,7 +3146,7 @@ MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, int reStrLen, Tcl_DString *dsPtr, int *flagsPtr, int *quantifiersFoundPtr); -MODULE_SCOPE int TclScanElement(const char *string, int length, +MODULE_SCOPE unsigned int TclScanElement(const char *string, int length, char *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 88a332f..a994fd7 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1945,7 +1945,8 @@ UpdateStringOfList( char localFlags[LOCAL_SIZE], *flagPtr = NULL; List *listRepPtr = ListRepPtr(listPtr); int numElems = listRepPtr->elemCount; - int i, length, bytesNeeded = 0; + int i, length; + unsigned int bytesNeeded = 0; const char *elem; char *dst; Tcl_Obj **elemPtrs; @@ -1986,11 +1987,11 @@ UpdateStringOfList( flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0); elem = TclGetStringFromObj(elemPtrs[i], &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i); - if (bytesNeeded < 0) { + if (bytesNeeded > INT_MAX) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } } - if (bytesNeeded > INT_MAX - numElems + 1) { + if (bytesNeeded + numElems > INT_MAX + 1U) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } bytesNeeded += numElems; diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 8d2347b..cacd23e 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1010,7 +1010,7 @@ Tcl_ScanCountedElement( *---------------------------------------------------------------------- */ -int +unsigned int TclScanElement( const char *src, /* String to convert to Tcl list element. */ int length, /* Number of bytes in src, or -1. */ @@ -1026,7 +1026,7 @@ TclScanElement( int extra = 0; /* Count of number of extra bytes needed for * formatted element, assuming we use escape * sequences in formatting. */ - int bytesNeeded; /* Buffer length computed to complete the + unsigned int bytesNeeded; /* Buffer length computed to complete the * element formatting in the selected mode. */ #if COMPAT int preferEscape = 0; /* Use preferences to track whether to use */ @@ -1290,7 +1290,7 @@ TclScanElement( *flagPtr = CONVERT_NONE; overflowCheck: - if (bytesNeeded < 0) { + if (bytesNeeded > INT_MAX) { Tcl_Panic("TclScanElement: string length overflow"); } return bytesNeeded; @@ -1568,7 +1568,8 @@ Tcl_Merge( { #define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; - int i, bytesNeeded = 0; + int i; + unsigned int bytesNeeded = 0; char *result, *dst; /* @@ -1594,11 +1595,11 @@ Tcl_Merge( for (i = 0; i < argc; i++) { flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]); - if (bytesNeeded < 0) { + if (bytesNeeded > INT_MAX) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } } - if (bytesNeeded > INT_MAX - argc + 1) { + if (bytesNeeded + argc > INT_MAX + 1U) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } bytesNeeded += argc; -- cgit v0.12 From 9dd5a63f35590c88db321bf5f70429c61ed5a3b5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 6 Oct 2022 13:12:11 +0000 Subject: TIP #640: Remove Tcl_SaveResult (in Tcl 8.7 it's only removed when compiled with -DTCL_NO_DEPRECATED) --- doc/SaveInterpState.3 | 85 ++++++++++++++++++++++++++++++++++++ doc/SaveResult.3 | 85 ------------------------------------ generic/tcl.h | 2 + generic/tclDecls.h | 29 +++--------- generic/tclTest.c | 8 ++++ macosx/Tcl.xcodeproj/project.pbxproj | 4 +- win/tcl.dsp | 2 +- 7 files changed, 105 insertions(+), 110 deletions(-) create mode 100644 doc/SaveInterpState.3 delete mode 100644 doc/SaveResult.3 diff --git a/doc/SaveInterpState.3 b/doc/SaveInterpState.3 new file mode 100644 index 0000000..804f9ec --- /dev/null +++ b/doc/SaveInterpState.3 @@ -0,0 +1,85 @@ +'\" +'\" Copyright (c) 1997 Sun Microsystems, Inc. +'\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright) +'\" Copyright (c) 2018 Nathan Coulter. +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +.TH Tcl_SaveResult 3 8.1 Tcl "Tcl Library Procedures" +.so man.macros +.BS +.SH NAME +Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState, +Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- Save and restore the +state of an an interpreter. +.SH SYNOPSIS +.nf +\fB#include \fR +.sp +Tcl_InterpState +\fBTcl_SaveInterpState\fR(\fIinterp, status\fR) +.sp +int +\fBTcl_RestoreInterpState\fR(\fIinterp, state\fR) +.sp +\fBTcl_DiscardInterpState\fR(\fIstate\fR) +.sp +\fBTcl_SaveResult\fR(\fIinterp, savedPtr\fR) +.sp +\fBTcl_RestoreResult\fR(\fIinterp, savedPtr\fR) +.sp +\fBTcl_DiscardResult\fR(\fIsavedPtr\fR) +.SH ARGUMENTS +.AS Tcl_InterpState savedPtr +.AP Tcl_Interp *interp in +The interpreter for the operation. +.AP int status in +The return code for the state. +.AP Tcl_InterpState state in +A token for saved state. +.AP Tcl_SavedResult *savedPtr in +A pointer to storage for saved state. +.BE +.SH DESCRIPTION +.PP +These routines save the state of an interpreter before a call to a routine such +as \fBTcl_Eval\fR, and restore the state afterwards. +.PP +\fBTcl_SaveInterpState\fR saves the parts of \fIinterp\fR that comprise the +result of a script, including the resulting value, the return code passed as +\fIstatus\fR, and any options such as \fB\-errorinfo\fR and \fB\-errorcode\fR. +It returns a token for the saved state. The interpreter result is not reset +and no interpreter state is changed. +.PP +\fBTcl_RestoreInterpState\fR restores the state indicated by \fIstate\fR and +returns the \fIstatus\fR originally passed in the corresponding call to +\fBTcl_SaveInterpState\fR. +.PP +If a saved state is not restored, \fBTcl_DiscardInterpState\fR must be called +to release it. A token used to discard or restore state must not be used +again. +.PP +\fBTcl_SaveResult\fR, \fBTcl_RestoreResult\fR, and \fBTcl_DiscardResult\fR are +deprecated. Instead use \fBTcl_SaveInterpState\fR, +\fBTcl_RestoreInterpState\fR, and \fBTcl_DiscardInterpState\fR, which are more +capable. +.PP +\fBTcl_SaveResult\fR moves the result of \fIinterp\fR to the location +\fIstatePtr\fR points to and returns the interpreter result to its initial +state. It does not save options such as \fB\-errorcode\fR or +\fB\-errorinfo\fR. +.PP +\fBTcl_RestoreResult\fR clears any existing result or error in \fIinterp\fR and +moves the result from \fIstatePtr\fR back to \fIinterp\fR. \fIstatePtr\fR is +then in an undefined state and must not be used until passed again to +\fBTcl_SaveResult\fR. +.PP +\fBTcl_DiscardResult\fR releases the state stored at \fBstatePtr\fR, which is +then in an undefined state and must not be used until passed again to +\fBTcl_SaveResult\fR. +.PP +If a saved result is not restored, \fBTcl_DiscardResult\fR must be called to +release it. +.SH KEYWORDS +result, state, interp diff --git a/doc/SaveResult.3 b/doc/SaveResult.3 deleted file mode 100644 index 804f9ec..0000000 --- a/doc/SaveResult.3 +++ /dev/null @@ -1,85 +0,0 @@ -'\" -'\" Copyright (c) 1997 Sun Microsystems, Inc. -'\" Contributions from Don Porter, NIST, 2004. (not subject to US copyright) -'\" Copyright (c) 2018 Nathan Coulter. -'\" -'\" See the file "license.terms" for information on usage and redistribution -'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. -'\" -.TH Tcl_SaveResult 3 8.1 Tcl "Tcl Library Procedures" -.so man.macros -.BS -.SH NAME -Tcl_SaveInterpState, Tcl_RestoreInterpState, Tcl_DiscardInterpState, -Tcl_SaveResult, Tcl_RestoreResult, Tcl_DiscardResult \- Save and restore the -state of an an interpreter. -.SH SYNOPSIS -.nf -\fB#include \fR -.sp -Tcl_InterpState -\fBTcl_SaveInterpState\fR(\fIinterp, status\fR) -.sp -int -\fBTcl_RestoreInterpState\fR(\fIinterp, state\fR) -.sp -\fBTcl_DiscardInterpState\fR(\fIstate\fR) -.sp -\fBTcl_SaveResult\fR(\fIinterp, savedPtr\fR) -.sp -\fBTcl_RestoreResult\fR(\fIinterp, savedPtr\fR) -.sp -\fBTcl_DiscardResult\fR(\fIsavedPtr\fR) -.SH ARGUMENTS -.AS Tcl_InterpState savedPtr -.AP Tcl_Interp *interp in -The interpreter for the operation. -.AP int status in -The return code for the state. -.AP Tcl_InterpState state in -A token for saved state. -.AP Tcl_SavedResult *savedPtr in -A pointer to storage for saved state. -.BE -.SH DESCRIPTION -.PP -These routines save the state of an interpreter before a call to a routine such -as \fBTcl_Eval\fR, and restore the state afterwards. -.PP -\fBTcl_SaveInterpState\fR saves the parts of \fIinterp\fR that comprise the -result of a script, including the resulting value, the return code passed as -\fIstatus\fR, and any options such as \fB\-errorinfo\fR and \fB\-errorcode\fR. -It returns a token for the saved state. The interpreter result is not reset -and no interpreter state is changed. -.PP -\fBTcl_RestoreInterpState\fR restores the state indicated by \fIstate\fR and -returns the \fIstatus\fR originally passed in the corresponding call to -\fBTcl_SaveInterpState\fR. -.PP -If a saved state is not restored, \fBTcl_DiscardInterpState\fR must be called -to release it. A token used to discard or restore state must not be used -again. -.PP -\fBTcl_SaveResult\fR, \fBTcl_RestoreResult\fR, and \fBTcl_DiscardResult\fR are -deprecated. Instead use \fBTcl_SaveInterpState\fR, -\fBTcl_RestoreInterpState\fR, and \fBTcl_DiscardInterpState\fR, which are more -capable. -.PP -\fBTcl_SaveResult\fR moves the result of \fIinterp\fR to the location -\fIstatePtr\fR points to and returns the interpreter result to its initial -state. It does not save options such as \fB\-errorcode\fR or -\fB\-errorinfo\fR. -.PP -\fBTcl_RestoreResult\fR clears any existing result or error in \fIinterp\fR and -moves the result from \fIstatePtr\fR back to \fIinterp\fR. \fIstatePtr\fR is -then in an undefined state and must not be used until passed again to -\fBTcl_SaveResult\fR. -.PP -\fBTcl_DiscardResult\fR releases the state stored at \fBstatePtr\fR, which is -then in an undefined state and must not be used until passed again to -\fBTcl_SaveResult\fR. -.PP -If a saved result is not restored, \fBTcl_DiscardResult\fR must be called to -release it. -.SH KEYWORDS -result, state, interp diff --git a/generic/tcl.h b/generic/tcl.h index f17d43e..c8a76c5 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -817,6 +817,7 @@ typedef struct Tcl_Obj { * typically allocated on the stack. */ +#ifndef TCL_NO_DEPRECATED typedef struct Tcl_SavedResult { char *result; Tcl_FreeProc *freeProc; @@ -826,6 +827,7 @@ typedef struct Tcl_SavedResult { int appendUsed; char resultSpace[200+1]; } Tcl_SavedResult; +#endif /* *---------------------------------------------------------------------------- diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 25adc95..62b9604 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -14,6 +14,10 @@ #include /* for size_t */ +#ifdef TCL_NO_DEPRECATED +# define Tcl_SavedResult void +#endif /* TCL_NO_DEPRECATED */ + #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl # define TCL_STORAGE_CLASS DLLEXPORT @@ -4231,30 +4235,8 @@ extern const TclStubs *tclStubsPtr; #define Tcl_GlobalEval(interp, objPtr) \ Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, TCL_EVAL_GLOBAL) #undef Tcl_SaveResult -static TCL_DEPRECATED_API("Use Tcl_SaveInterpState") void Tcl_SaveResult_(void) {} -#define Tcl_SaveResult(interp, statePtr) \ - do { \ - Tcl_SaveResult_(); \ - (statePtr)->objResultPtr = Tcl_GetObjResult(interp); \ - Tcl_IncrRefCount((statePtr)->objResultPtr); \ - Tcl_SetObjResult(interp, Tcl_NewObj()); \ - } while(0) #undef Tcl_RestoreResult -static TCL_DEPRECATED_API("Use Tcl_RestoreInterpState") void Tcl_RestoreResult_(void) {} -#define Tcl_RestoreResult(interp, statePtr) \ - do { \ - Tcl_RestoreResult_(); \ - Tcl_ResetResult(interp); \ - Tcl_SetObjResult(interp, (statePtr)->objResultPtr); \ - Tcl_DecrRefCount((statePtr)->objResultPtr); \ - } while(0) #undef Tcl_DiscardResult -static TCL_DEPRECATED_API("Use Tcl_DiscardInterpState") void Tcl_DiscardResult_(void) {} -#define Tcl_DiscardResult(statePtr) \ - do { \ - Tcl_DiscardResult_(); \ - Tcl_DecrRefCount((statePtr)->objResultPtr); \ - } while(0) #undef Tcl_SetResult #define Tcl_SetResult(interp, result, freeProc) \ do { \ @@ -4492,6 +4474,9 @@ static TCL_DEPRECATED_API("Use Tcl_DiscardInterpState") void Tcl_DiscardResult_( * Deprecated Tcl procedures: */ +#ifdef TCL_NO_DEPRECATED +# undef Tcl_SavedResult +#endif /* TCL_NO_DEPRECATED */ #undef Tcl_EvalObj #define Tcl_EvalObj(interp, objPtr) \ Tcl_EvalObjEx(interp, objPtr, 0) diff --git a/generic/tclTest.c b/generic/tclTest.c index 354ea9c..95f4d2f 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -145,7 +145,9 @@ typedef struct { * was called for a result. */ +#ifndef TCL_NO_DEPRECATED static int freeCount; +#endif /* TCL_NO_DEPRECATED */ /* * Boolean flag used by the "testsetmainloop" and "testexitmainloop" commands. @@ -297,8 +299,10 @@ static Tcl_ObjCmdProc TestregexpObjCmd; static Tcl_ObjCmdProc TestreturnObjCmd; static void TestregexpXflags(const char *string, int length, int *cflagsPtr, int *eflagsPtr); +#ifndef TCL_NO_DEPRECATED static Tcl_ObjCmdProc TestsaveresultCmd; static void TestsaveresultFree(char *blockPtr); +#endif /* TCL_NO_DEPRECATED */ static Tcl_CmdProc TestsetassocdataCmd; static Tcl_CmdProc TestsetCmd; static Tcl_CmdProc Testset2Cmd; @@ -690,8 +694,10 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, NULL, NULL); +#ifndef TCL_NO_DEPRECATED Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, NULL, NULL); +#endif Tcl_CreateCommand(interp, "testservicemode", TestServiceModeCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, @@ -5522,6 +5528,7 @@ Testset2Cmd( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED static int TestsaveresultCmd( TCL_UNUSED(void *), @@ -5635,6 +5642,7 @@ TestsaveresultFree( { freeCount++; } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- diff --git a/macosx/Tcl.xcodeproj/project.pbxproj b/macosx/Tcl.xcodeproj/project.pbxproj index 90896e2..4143128 100644 --- a/macosx/Tcl.xcodeproj/project.pbxproj +++ b/macosx/Tcl.xcodeproj/project.pbxproj @@ -376,7 +376,7 @@ F96D3E9108F272A6004A47F5 /* rename.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = rename.n; sourceTree = ""; }; F96D3E9208F272A6004A47F5 /* return.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = return.n; sourceTree = ""; }; F96D3E9308F272A6004A47F5 /* safe.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = safe.n; sourceTree = ""; }; - F96D3E9408F272A6004A47F5 /* SaveResult.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SaveResult.3; sourceTree = ""; }; + F96D3E9408F272A6004A47F5 /* SaveInterpState.3 */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = SaveInterpState.3; sourceTree = ""; }; F96D3E9508F272A6004A47F5 /* scan.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = scan.n; sourceTree = ""; }; F96D3E9608F272A6004A47F5 /* seek.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = seek.n; sourceTree = ""; }; F96D3E9708F272A6004A47F5 /* set.n */ = {isa = PBXFileReference; explicitFileType = text.man; fileEncoding = 4; path = set.n; sourceTree = ""; }; @@ -1123,7 +1123,7 @@ F96D3E9108F272A6004A47F5 /* rename.n */, F96D3E9208F272A6004A47F5 /* return.n */, F96D3E9308F272A6004A47F5 /* safe.n */, - F96D3E9408F272A6004A47F5 /* SaveResult.3 */, + F96D3E9408F272A6004A47F5 /* SaveInterpState.3 */, F96D3E9508F272A6004A47F5 /* scan.n */, F96D3E9608F272A6004A47F5 /* seek.n */, F93599D80DF1F98300E04F67 /* self.n */, diff --git a/win/tcl.dsp b/win/tcl.dsp index cc9d173..aff1000 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -760,7 +760,7 @@ SOURCE=..\doc\safe.n # End Source File # Begin Source File -SOURCE=..\doc\SaveResult.3 +SOURCE=..\doc\SaveInterpState.3 # End Source File # Begin Source File -- cgit v0.12 From 6f2284ab12177714d29ad979fa1f1420e61f836b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 Oct 2022 10:18:33 +0000 Subject: Follow-up to [1599352cca]: Tcl_Merge(): out-of-bounds write, more signed integer overflow. Better panic message when argc < 0. --- generic/tclUtil.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index cacd23e..a8bf795 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1577,7 +1577,10 @@ Tcl_Merge( * simpler. */ - if (argc == 0) { + if (argc <= 0) { + if (argc < 0) { + Tcl_Panic("Tcl_Merge called with negative argc (%d)", argc); + } result = (char *)ckalloc(1); result[0] = '\0'; return result; -- cgit v0.12 From 948f556e5200e88aa563402d1f0ad7019d0c291b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 Oct 2022 11:02:05 +0000 Subject: More -1 -> TCL_INDEX_NONE --- generic/tclUtil.c | 131 ++++++++++++++++++++++++++++-------------------------- 1 file changed, 68 insertions(+), 63 deletions(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 2b1305c..f10187b 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -375,10 +375,10 @@ static const Tcl_ObjType endOffsetType = { * * Given 'bytes' pointing to 'numBytes' bytes, scan through them and * count the number of whitespace runs that could be list element - * separators. If 'numBytes' is -1, scan to the terminating '\0'. Not a - * full list parser. Typically used to get a quick and dirty overestimate - * of length size in order to allocate space for an actual list parser to - * operate with. + * separators. If 'numBytes' is TCL_INDEX_NONE, scan to the terminating + * '\0'. Not a full list parser. Typically used to get a quick and dirty + * overestimate of length size in order to allocate space for an actual + * list parser to operate with. * * Results: * Returns the largest number of list elements that could possibly be in @@ -399,7 +399,7 @@ TclMaxListLength( { int count = 0; - if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) { + if ((numBytes == 0) || ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0'))) { /* Empty string case - quick exit */ goto done; } @@ -415,7 +415,7 @@ TclMaxListLength( */ while (numBytes) { - if ((numBytes == -1) && (*bytes == '\0')) { + if ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0')) { break; } if (TclIsSpaceProcM(*bytes)) { @@ -426,9 +426,9 @@ TclMaxListLength( count++; do { bytes++; - numBytes -= (numBytes != -1); + numBytes -= (numBytes != TCL_INDEX_NONE); } while (numBytes && TclIsSpaceProcM(*bytes)); - if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) { + if ((numBytes == 0) || ((numBytes == TCL_INDEX_NONE) && (*bytes == '\0'))) { break; } @@ -437,7 +437,7 @@ TclMaxListLength( */ } bytes++; - numBytes -= (numBytes != -1); + numBytes -= (numBytes != TCL_INDEX_NONE); } /* @@ -874,7 +874,7 @@ Tcl_SplitList( * string gets re-purposed to hold '\0' characters in the argv array. */ - size = TclMaxListLength(list, -1, &end) + 1; + size = TclMaxListLength(list, TCL_INDEX_NONE, &end) + 1; length = end - list; argv = (const char **)ckalloc((size * sizeof(char *)) + length + 1); @@ -897,7 +897,7 @@ Tcl_SplitList( ckfree(argv); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "internal error in Tcl_SplitList", -1)); + "internal error in Tcl_SplitList", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList", NULL); } @@ -945,9 +945,9 @@ int Tcl_ScanElement( const char *src, /* String to convert to list element. */ int *flagPtr) /* Where to store information to guide - * Tcl_ConvertCountedElement. */ + * Tcl_ConvertCountedElement. */ { - return Tcl_ScanCountedElement(src, -1, flagPtr); + return Tcl_ScanCountedElement(src, TCL_INDEX_NONE, flagPtr); } /* @@ -958,8 +958,8 @@ Tcl_ScanElement( * This function is a companion function to Tcl_ConvertCountedElement. It * scans a string to see what needs to be done to it (e.g. add * backslashes or enclosing braces) to make the string into a valid Tcl - * list element. If length is -1, then the string is scanned from src up - * to the first null byte. + * list element. If length is TCL_INDEX_NONE, then the string is scanned + * from src up to the first null byte. * * Results: * The return value is an overestimate of the number of bytes that will @@ -976,7 +976,7 @@ Tcl_ScanElement( int Tcl_ScanCountedElement( const char *src, /* String to convert to Tcl list element. */ - int length, /* Number of bytes in src, or -1. */ + int length, /* Number of bytes in src, or TCL_INDEX_NONE. */ int *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { @@ -995,7 +995,7 @@ Tcl_ScanCountedElement( * This function is a companion function to TclConvertElement. It scans a * string to see what needs to be done to it (e.g. add backslashes or * enclosing braces) to make the string into a valid Tcl list element. If - * length is -1, then the string is scanned from src up to the first null + * length is TCL_INDEX_NONE, then the string is scanned from src up to the first null * byte. A NULL value for src is treated as an empty string. The incoming * value of *flagPtr is a report from the caller what additional flags it * will pass to TclConvertElement(). @@ -1017,10 +1017,10 @@ Tcl_ScanCountedElement( *---------------------------------------------------------------------- */ -unsigned int +TCL_HASH_TYPE TclScanElement( const char *src, /* String to convert to Tcl list element. */ - int length, /* Number of bytes in src, or -1. */ + int length, /* Number of bytes in src, or TCL_INDEX_NONE. */ char *flagPtr) /* Where to store information to guide * Tcl_ConvertElement. */ { @@ -1033,7 +1033,7 @@ TclScanElement( int extra = 0; /* Count of number of extra bytes needed for * formatted element, assuming we use escape * sequences in formatting. */ - unsigned int bytesNeeded; /* Buffer length computed to complete the + TCL_HASH_TYPE bytesNeeded; /* Buffer length computed to complete the * element formatting in the selected mode. */ #if COMPAT int preferEscape = 0; /* Use preferences to track whether to use */ @@ -1041,7 +1041,7 @@ TclScanElement( int braceCount = 0; /* Count of all braces '{' '}' seen. */ #endif /* COMPAT */ - if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == -1))) { + if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == TCL_INDEX_NONE))) { /* * Empty string element must be brace quoted. */ @@ -1124,7 +1124,7 @@ TclScanElement( break; case '\\': /* TYPE_SUBS */ extra++; /* Escape '\' => '\\' */ - if ((length == 1) || ((length == -1) && (p[1] == '\0'))) { + if ((length == 1) || ((length == TCL_INDEX_NONE) && (p[1] == '\0'))) { /* * Final backslash. Cannot format with brace quoting. */ @@ -1155,7 +1155,7 @@ TclScanElement( #endif /* COMPAT */ break; case '\0': /* TYPE_SUBS */ - if (length == -1) { + if (length == TCL_INDEX_NONE) { goto endOfString; } /* TODO: Panic on improper encoding? */ @@ -1330,7 +1330,7 @@ Tcl_ConvertElement( char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ { - return Tcl_ConvertCountedElement(src, -1, dst, flags); + return Tcl_ConvertCountedElement(src, TCL_INDEX_NONE, dst, flags); } /* @@ -1357,7 +1357,7 @@ Tcl_ConvertElement( int Tcl_ConvertCountedElement( const char *src, /* Source information for list element. */ - int length, /* Number of bytes in src, or -1. */ + int length, /* Number of bytes in src, or TCL_INDEX_NONE. */ char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ { @@ -1390,7 +1390,7 @@ Tcl_ConvertCountedElement( int TclConvertElement( const char *src, /* Source information for list element. */ - int length, /* Number of bytes in src, or -1. */ + int length, /* Number of bytes in src, or TCL_INDEX_NONE. */ char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ { @@ -1409,7 +1409,7 @@ TclConvertElement( * No matter what the caller demands, empty string must be braced! */ - if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) { + if ((src == NULL) || (length == 0) || (*src == '\0' && length == TCL_INDEX_NONE)) { p[0] = '{'; p[1] = '}'; return 2; @@ -1436,7 +1436,7 @@ TclConvertElement( */ if (conversion == CONVERT_NONE) { - if (length == -1) { + if (length == TCL_INDEX_NONE) { /* TODO: INT_MAX overflow? */ while (*src) { *p++ = *src++; @@ -1455,7 +1455,7 @@ TclConvertElement( if (conversion == CONVERT_BRACE) { *p = '{'; p++; - if (length == -1) { + if (length == TCL_INDEX_NONE) { /* TODO: INT_MAX overflow? */ while (*src) { *p++ = *src++; @@ -1528,7 +1528,7 @@ TclConvertElement( p++; continue; case '\0': - if (length == -1) { + if (length == TCL_INDEX_NONE) { return p - dst; } @@ -1604,7 +1604,7 @@ Tcl_Merge( } for (i = 0; i < argc; i++) { flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); - bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]); + bytesNeeded += TclScanElement(argv[i], TCL_INDEX_NONE, &flagPtr[i]); if (bytesNeeded > INT_MAX) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } @@ -1622,7 +1622,7 @@ Tcl_Merge( dst = result; for (i = 0; i < argc; i++) { flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); - dst += TclConvertElement(argv[i], -1, dst, flagPtr[i]); + dst += TclConvertElement(argv[i], TCL_INDEX_NONE, dst, flagPtr[i]); *dst = ' '; dst++; } @@ -2665,8 +2665,8 @@ Tcl_DStringInit( char * Tcl_DStringAppend( Tcl_DString *dsPtr, /* Structure describing dynamic string. */ - const char *bytes, /* String to append. If length is -1 then this - * must be null-terminated. */ + const char *bytes, /* String to append. If length is + * < 0 then this must be null-terminated. */ int length) /* Number of bytes from "bytes" to append. If * < 0, then append all of bytes, up to null * at end. */ @@ -2692,18 +2692,18 @@ Tcl_DStringAppend( memcpy(newString, dsPtr->string, dsPtr->length); dsPtr->string = newString; } else { - int offset = -1; + int index = TCL_INDEX_NONE; /* See [16896d49fd] */ if (bytes >= dsPtr->string && bytes <= dsPtr->string + dsPtr->length) { - offset = bytes - dsPtr->string; + index = bytes - dsPtr->string; } dsPtr->string = (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl); - if (offset >= 0) { - bytes = dsPtr->string + offset; + if (index >= 0) { + bytes = dsPtr->string + index; } } } @@ -2802,7 +2802,7 @@ Tcl_DStringAppendElement( if (!quoteHash) { flags |= TCL_DONT_QUOTE_HASH; } - newSize = dsPtr->length + needSpace + TclScanElement(element, -1, &flags); + newSize = dsPtr->length + needSpace + TclScanElement(element, TCL_INDEX_NONE, &flags); if (!quoteHash) { flags |= TCL_DONT_QUOTE_HASH; } @@ -2851,7 +2851,7 @@ Tcl_DStringAppendElement( dsPtr->length++; } - dsPtr->length += TclConvertElement(element, -1, dst, flags); + dsPtr->length += TclConvertElement(element, TCL_INDEX_NONE, dst, flags); dsPtr->string[dsPtr->length] = '\0'; return dsPtr->string; } @@ -3263,7 +3263,7 @@ Tcl_PrintDouble( */ if (*precisionPtr == 0) { - digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST, + digits = TclDoubleDigits(value, TCL_INDEX_NONE, TCL_DD_SHORTEST, &exponent, &signum, &end); } else { /* @@ -3637,11 +3637,11 @@ TclFormatInt( static int GetWideForIndex( Tcl_Interp *interp, /* Interpreter to use for error reporting. If - * NULL, then no error message is left after - * errors. */ + * NULL, then no error message is left after + * errors. */ Tcl_Obj *objPtr, /* Points to the value to be parsed */ size_t endValue, /* The value to be stored at *widePtr if - * objPtr holds "end". + * objPtr holds "end". * NOTE: this value may be TCL_INDEX_NONE. */ Tcl_WideInt *widePtr) /* Location filled in with a wide integer * representing an index. */ @@ -3673,21 +3673,26 @@ GetWideForIndex( * * Tcl_GetIntForIndex -- * - * This function returns an integer corresponding to the list index held - * in a Tcl object. The Tcl object's value is expected to be in the - * format integer([+-]integer)? or the format end([+-]integer)?. + * Provides an integer corresponding to the list index held in a Tcl + * object. The string value 'objPtr' is expected have the format + * integer([+-]integer)? or end([+-]integer)?. * - * Results: - * The return value is normally TCL_OK, which means that the index was - * successfully stored into the location referenced by "indexPtr". If the - * Tcl object referenced by "objPtr" has the value "end", the value - * stored is "endValue". If "objPtr"s values is not of one of the - * expected formats, TCL_ERROR is returned and, if "interp" is non-NULL, - * an error message is left in the interpreter's result object. + * Value + * TCL_OK * - * Side effects: - * The object referenced by "objPtr" might be converted to an integer, - * wide integer, or end-based-index object. + * The index is stored at the address given by by 'indexPtr'. If + * 'objPtr' has the value "end", the value stored is 'endValue'. + * + * TCL_ERROR + * + * The value of 'objPtr' does not have one of the expected formats. If + * 'interp' is non-NULL, an error message is left in the interpreter's + * result object. + * + * Effect + * + * The object referenced by 'objPtr' is converted, as needed, to an + * integer, wide integer, or end-based-index object. * *---------------------------------------------------------------------- */ @@ -3711,7 +3716,7 @@ Tcl_GetIntForIndex( } if (indexPtr != NULL) { if ((wide < 0) && (endValue >= 0)) { - *indexPtr = -1; + *indexPtr = TCL_INDEX_NONE; } else if (wide > INT_MAX) { *indexPtr = INT_MAX; } else if (wide < INT_MIN) { @@ -3788,7 +3793,7 @@ GetEndOffsetFromObj( * Quick scan to see if multi-value list is even possible. * This relies on TclGetString() returning a NUL-terminated string. */ - if ((TclMaxListLength(bytes, -1, NULL) > 1) + if ((TclMaxListLength(bytes, TCL_INDEX_NONE, NULL) > 1) /* If it's possible, do the full list parse. */ && (TCL_OK == TclListObjLengthM(NULL, objPtr, &length)) @@ -3797,7 +3802,7 @@ GetEndOffsetFromObj( } /* Passed the list screen, so parse for index arithmetic expression */ - if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, -1, &opPtr, + if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, TCL_INDEX_NONE, &opPtr, TCL_PARSE_INTEGER_ONLY)) { Tcl_WideInt w1=0, w2=0; @@ -3813,7 +3818,7 @@ GetEndOffsetFromObj( } if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, opPtr + 1, - -1, NULL, TCL_PARSE_INTEGER_ONLY)) { + TCL_INDEX_NONE, NULL, TCL_PARSE_INTEGER_ONLY)) { /* ... value concludes with second valid integer */ /* Save second integer as wide if possible */ @@ -4172,7 +4177,7 @@ TclCheckBadOctal( */ Tcl_AppendToObj(Tcl_GetObjResult(interp), - " (looks like invalid octal number)", -1); + " (looks like invalid octal number)", TCL_INDEX_NONE); } return 1; } @@ -4794,7 +4799,7 @@ TclReToGlob( invalidGlob: if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL); } Tcl_DStringFree(dsPtr); -- cgit v0.12 From a9fba66be576e55d089b69f8531d514cdc05c61e Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 7 Oct 2022 11:23:18 +0000 Subject: Add memory leak/refcount tests for lists, spans and lseq --- generic/tclTestObj.c | 323 ++++++++++++++++++++++++++++++++++----------------- tests/listObj.test | 68 +++++++++++ 2 files changed, 284 insertions(+), 107 deletions(-) diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index a03a60a..93af3c0 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -841,6 +841,35 @@ TestintobjCmd( * test a few possible corner cases in list object manipulation from * C code that cannot occur at the Tcl level. * + * Following new commands are added for 8.7 as regression tests for + * memory leaks and use-after-free. Unlike 8.6, 8.7 has multiple internal + * representations for lists. It has to be ensured that corresponding + * implementations obey the invariants of the C list API. The script + * level tests do not suffice as Tcl list commands do not execute + * the same exact code path as the exported C API. + * + * Note these new commands are only useful when Tcl is compiled with + * TCL_MEM_DEBUG defined. + * + * indexmemcheck - loops calling Tcl_ListObjIndex on each element. This + * is to test that abstract lists returning elements do not depend + * on caller to free them. The test case should check allocated counts + * with the following sequence: + * set before + * testobj set VARINDEX [list a b c] (or lseq etc.) + * testlistobj indexnoop VARINDEX + * testobj unset VARINDEX + * set after + * after calling this command AND freeing the passed list. The targeted + * bug is if Tcl_LOI returns a ephemeral Tcl_Obj with no other reference + * resulting in a memory leak. Conversely, the command also checks + * that the Tcl_Obj returned by Tcl_LOI does not have a zero reference + * count since it is supposed to have at least one reference held + * by the list implementation. Returns a message in interp otherwise. + * + * getelementsmemcheck - as above but for Tcl_ListObjGetElements + + * * Results: * A standard Tcl object result. * @@ -861,25 +890,36 @@ TestlistobjCmd( const char* subcommands[] = { "set", "get", - "replace" + "replace", + "indexmemcheck", + "getelementsmemcheck", + NULL }; enum listobjCmdIndex { LISTOBJ_SET, LISTOBJ_GET, - LISTOBJ_REPLACE + LISTOBJ_REPLACE, + LISTOBJ_INDEXMEMCHECK, + LISTOBJ_GETELEMENTSMEMCHECK, } cmdIndex; size_t varIndex; /* Variable number converted to binary */ Tcl_WideInt first; /* First index in the list */ Tcl_WideInt count; /* Count of elements in a list */ Tcl_Obj **varPtr; + int i; +#if TCL_VERSION_MAJOR < 9 + int len; +#else + size_t len; +#endif if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg...?"); return TCL_ERROR; } varPtr = GetVarPtr(interp); - if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command", @@ -923,6 +963,58 @@ TestlistobjCmd( Tcl_ResetResult(interp); return Tcl_ListObjReplace(interp, varPtr[varIndex], first, count, objc-5, objv+5); + + case LISTOBJ_INDEXMEMCHECK: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varPtr, varIndex)) { + return TCL_ERROR; + } + if (Tcl_ListObjLength(interp, varPtr[varIndex], &len) != TCL_OK) { + return TCL_ERROR; + } + for (i = 0; i < len; ++i) { + Tcl_Obj *objP; + if (Tcl_ListObjIndex(interp, varPtr[varIndex], i, &objP) + != TCL_OK) { + return TCL_ERROR; + } + if (objP->refCount <= 0) { + Tcl_SetResult( + interp, + "Tcl_ListObjIndex returned object with ref count <= 0", + TCL_STATIC); + /* Keep looping since we are also looping for leaks */ + } + } + break; + + case LISTOBJ_GETELEMENTSMEMCHECK: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "varIndex"); + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varPtr, varIndex)) { + return TCL_ERROR; + } else { + Tcl_Obj **elems; + if (Tcl_ListObjGetElements(interp, varPtr[varIndex], &len, &elems) + != TCL_OK) { + return TCL_ERROR; + } + for (i = 0; i < len; ++i) { + if (elems[i]->refCount <= 0) { + Tcl_SetResult( + interp, + "Tcl_ListObjGetElements element has ref count <= 0", + TCL_STATIC); + break; + } + } + } + break; } return TCL_OK; } @@ -953,9 +1045,21 @@ TestobjCmd( { size_t varIndex, destIndex; int i; - const char *subCmd; const Tcl_ObjType *targetType; Tcl_Obj **varPtr; + const char *subcommands[] = { + "freeallvars", "bug3598580", "types", + "objtype", "newobj", "set", + "assign", "convert", "duplicate", + "invalidateStringRep", "refcount", "type", + NULL + }; + enum testobjCmdIndex { + TESTOBJ_FREEALLVARS, TESTOBJ_BUG3598580, TESTOBJ_TYPES, + TESTOBJ_OBJTYPE, TESTOBJ_NEWOBJ, TESTOBJ_SET, + TESTOBJ_ASSIGN, TESTOBJ_CONVERT, TESTOBJ_DUPLICATE, + TESTOBJ_INVALIDATESTRINGREP, TESTOBJ_REFCOUNT, TESTOBJ_TYPE, + } cmdIndex; if (objc < 2) { wrongNumArgs: @@ -964,142 +1068,159 @@ TestobjCmd( } varPtr = GetVarPtr(interp); - subCmd = Tcl_GetString(objv[1]); - if (strcmp(subCmd, "assign") == 0) { - if (objc != 4) { + if (Tcl_GetIndexFromObj( + interp, objv[1], subcommands, "command", 0, &cmdIndex) + != TCL_OK) { + return TCL_ERROR; + } + switch (cmdIndex) { + case TESTOBJ_FREEALLVARS: + if (objc != 2) { goto wrongNumArgs; } - if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { - return TCL_ERROR; + for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { + if (varPtr[i] != NULL) { + Tcl_DecrRefCount(varPtr[i]); + varPtr[i] = NULL; + } } - if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) { - return TCL_ERROR; + return TCL_OK; + case TESTOBJ_BUG3598580: + if (objc != 2) { + goto wrongNumArgs; + } else { + Tcl_Obj *listObjPtr, *elemObjPtr; + elemObjPtr = Tcl_NewWideIntObj(123); + listObjPtr = Tcl_NewListObj(1, &elemObjPtr); + /* Replace the single list element through itself, nonsense but + * legal. */ + Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr); + Tcl_SetObjResult(interp, listObjPtr); } - SetVarToObj(varPtr, destIndex, varPtr[varIndex]); - Tcl_SetObjResult(interp, varPtr[destIndex]); - } else if (strcmp(subCmd, "bug3598580") == 0) { - Tcl_Obj *listObjPtr, *elemObjPtr; + return TCL_OK; + case TESTOBJ_TYPES: if (objc != 2) { goto wrongNumArgs; + } else { + Tcl_Obj *typesObj = Tcl_NewListObj(0, NULL); + Tcl_AppendAllObjTypes(interp, typesObj); + Tcl_SetObjResult(interp, typesObj); } - elemObjPtr = Tcl_NewWideIntObj(123); - listObjPtr = Tcl_NewListObj(1, &elemObjPtr); - /* Replace the single list element through itself, nonsense but legal. */ - Tcl_ListObjReplace(interp, listObjPtr, 0, 1, 1, &elemObjPtr); - Tcl_SetObjResult(interp, listObjPtr); return TCL_OK; - } else if (strcmp(subCmd, "convert") == 0) { + case TESTOBJ_OBJTYPE: + /* + * Return an object containing the name of the argument's type of + * internal rep. If none exists, return "none". + */ - if (objc != 4) { + if (objc != 3) { goto wrongNumArgs; + } else { + const char *typeName; + + if (objv[2]->typePtr == NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1)); + } + else { + typeName = objv[2]->typePtr->name; + if (!strcmp(typeName, "utf32string")) + typeName = "string"; +#ifndef TCL_WIDE_INT_IS_LONG + else if (!strcmp(typeName, "wideInt")) typeName = "int"; +#endif + Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1)); + } } - if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { - return TCL_ERROR; - } - if ((targetType = Tcl_GetObjType(Tcl_GetString(objv[3]))) == NULL) { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "no type ", Tcl_GetString(objv[3]), " found", NULL); - return TCL_ERROR; + return TCL_OK; + case TESTOBJ_NEWOBJ: + if (objc != 3) { + goto wrongNumArgs; } - if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType) - != TCL_OK) { + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } + SetVarToObj(varPtr, varIndex, Tcl_NewObj()); Tcl_SetObjResult(interp, varPtr[varIndex]); - } else if (strcmp(subCmd, "duplicate") == 0) { + return TCL_OK; + case TESTOBJ_SET: if (objc != 4) { goto wrongNumArgs; } if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { return TCL_ERROR; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { - return TCL_ERROR; + SetVarToObj(varPtr, varIndex, objv[3]); + return TCL_OK; + + default: + break; + } + + /* All further commands expect an occupied varindex argument */ + if (objc < 3) { + goto wrongNumArgs; + } + + if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { + return TCL_ERROR; + } + if (CheckIfVarUnset(interp, varPtr, varIndex)) { + return TCL_ERROR; + } + + switch (cmdIndex) { + case TESTOBJ_ASSIGN: + if (objc != 4) { + goto wrongNumArgs; } if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) { return TCL_ERROR; } - SetVarToObj(varPtr, destIndex, Tcl_DuplicateObj(varPtr[varIndex])); + SetVarToObj(varPtr, destIndex, varPtr[varIndex]); Tcl_SetObjResult(interp, varPtr[destIndex]); - } else if (strcmp(subCmd, "freeallvars") == 0) { - if (objc != 2) { - goto wrongNumArgs; - } - for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) { - if (varPtr[i] != NULL) { - Tcl_DecrRefCount(varPtr[i]); - varPtr[i] = NULL; - } - } - } else if (strcmp(subCmd, "invalidateStringRep") == 0) { - if (objc != 3) { + break; + case TESTOBJ_CONVERT: + if (objc != 4) { goto wrongNumArgs; } - if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { + if ((targetType = Tcl_GetObjType(Tcl_GetString(objv[3]))) == NULL) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "no type ", Tcl_GetString(objv[3]), " found", NULL); return TCL_ERROR; } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { + if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType) + != TCL_OK) { return TCL_ERROR; } - Tcl_InvalidateStringRep(varPtr[varIndex]); Tcl_SetObjResult(interp, varPtr[varIndex]); - } else if (strcmp(subCmd, "newobj") == 0) { - if (objc != 3) { + break; + case TESTOBJ_DUPLICATE: + if (objc != 4) { goto wrongNumArgs; } - if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { + if (GetVariableIndex(interp, objv[3], &destIndex) != TCL_OK) { return TCL_ERROR; } - SetVarToObj(varPtr, varIndex, Tcl_NewObj()); - Tcl_SetObjResult(interp, varPtr[varIndex]); - } else if (strcmp(subCmd, "objtype") == 0) { - const char *typeName; - - /* - * Return an object containing the name of the argument's type of - * internal rep. If none exists, return "none". - */ - + SetVarToObj(varPtr, destIndex, Tcl_DuplicateObj(varPtr[varIndex])); + Tcl_SetObjResult(interp, varPtr[destIndex]); + break; + case TESTOBJ_INVALIDATESTRINGREP: if (objc != 3) { goto wrongNumArgs; } - if (objv[2]->typePtr == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1)); - } else { - typeName = objv[2]->typePtr->name; - if (!strcmp(typeName, "utf32string")) typeName = "string"; -#ifndef TCL_WIDE_INT_IS_LONG - else if (!strcmp(typeName, "wideInt")) typeName = "int"; -#endif - Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1)); - } - } else if (strcmp(subCmd, "refcount") == 0) { + Tcl_InvalidateStringRep(varPtr[varIndex]); + Tcl_SetObjResult(interp, varPtr[varIndex]); + break; + case TESTOBJ_REFCOUNT: if (objc != 3) { goto wrongNumArgs; } - if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { - return TCL_ERROR; - } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(varPtr[varIndex]->refCount)); - } else if (strcmp(subCmd, "type") == 0) { + break; + case TESTOBJ_TYPE: if (objc != 3) { goto wrongNumArgs; } - if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { - return TCL_ERROR; - } - if (CheckIfVarUnset(interp, varPtr,varIndex)) { - return TCL_ERROR; - } if (varPtr[varIndex]->typePtr == NULL) { /* a string! */ Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1); #ifndef TCL_WIDE_INT_IS_LONG @@ -1111,21 +1232,9 @@ TestobjCmd( Tcl_AppendToObj(Tcl_GetObjResult(interp), varPtr[varIndex]->typePtr->name, -1); } - } else if (strcmp(subCmd, "types") == 0) { - if (objc != 2) { - goto wrongNumArgs; - } - if (Tcl_AppendAllObjTypes(interp, - Tcl_GetObjResult(interp)) != TCL_OK) { - return TCL_ERROR; - } - } else { - Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "bad option \"", Tcl_GetString(objv[1]), - "\": must be assign, convert, duplicate, freeallvars, " - "newobj, objcount, objtype, refcount, type, or types", NULL); - return TCL_ERROR; + break; } + return TCL_OK; } diff --git a/tests/listObj.test b/tests/listObj.test index 0b64635..0f43648 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -20,6 +20,7 @@ if {"::tcltest" ni [namespace children]} { catch [list package require -exact tcl::test [info patchlevel]] testConstraint testobj [llength [info commands testobj]] +testConstraint memory [llength [info commands memory]] catch {unset x} test listobj-1.1 {Tcl_GetListObjType} emptyTest { @@ -210,6 +211,73 @@ test listobj-11.1 {Bug 3598580: Tcl_ListObjReplace refcount management} testobj testobj bug3598580 } 123 +# Stolen from dict.test +proc listobjmemcheck script { + set end [lindex [split [memory info] \n] 3 3] + for {set i 0} {$i < 5} {incr i} { + uplevel 1 $script + set tmp $end + set end [lindex [split [memory info] \n] 3 3] + } + expr {$end - $tmp} +} + +test listobj-12.1 {Tcl_ListObjIndex memory leaks for native lists} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [lrepeat 1000 x] + set errorMessage [testlistobj indexmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} +test listobj-12.2 {Tcl_ListObjIndex memory leaks for native lists with spans} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [testlistrep new 1000 100 100] + set errorMessage [testlistobj indexmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} +test listobj-12.3 {Tcl_ListObjIndex memory leaks for lseq} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [lseq 1000] + set errorMessage [testlistobj indexmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} + +test listobj-13.1 {Tcl_ListObjGetElements memory leaks for native lists} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [lrepeat 1000 x] + set errorMessage [testlistobj getelementsmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} +test listobj-13.2 {Tcl_ListObjElements memory leaks for native lists with spans} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [testlistrep new 1000 100 100] + set errorMessage [testlistobj getelementsmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} +test listobj-13.3 {Tcl_ListObjElements memory leaks for lseq} -constraints { + testobj memory +} -body { + list [listobjmemcheck { + testobj set 1 [lseq 1000] + set errorMessage [testlistobj getelementsmemcheck 1] + testobj freeallvars + }] $errorMessage +} -result {0 {}} + # cleanup ::tcltest::cleanupTests return -- cgit v0.12 From 4b6d8abfe47494263e6fde30cbb9e9d9f880086e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 Oct 2022 15:18:36 +0000 Subject: Use GotFlag/SetFlag/ResetFlag macro's wherever appropriate --- generic/tclIO.c | 42 +++++++++++++++++++++--------------------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 5dff604..408a1d3 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -1478,7 +1478,7 @@ Tcl_GetChannel( chanPtr = (Channel *)Tcl_GetHashValue(hPtr); chanPtr = chanPtr->state->bottomChanPtr; if (modePtr != NULL) { - *modePtr = chanPtr->state->flags & (TCL_READABLE|TCL_WRITABLE); + *modePtr = GotFlag(chanPtr->state, TCL_READABLE|TCL_WRITABLE); } return (Tcl_Channel) chanPtr; @@ -1572,7 +1572,7 @@ TclGetChannelFromObj( *channelPtr = (Tcl_Channel) statePtr->bottomChanPtr; if (modePtr != NULL) { - *modePtr = statePtr->flags & (TCL_READABLE|TCL_WRITABLE); + *modePtr = GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE); } return TCL_OK; @@ -1877,7 +1877,7 @@ Tcl_StackChannel( * --+---+---+---+----+ */ - if ((mask & (statePtr->flags & (TCL_READABLE | TCL_WRITABLE))) == 0) { + if ((mask & GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE)) == 0) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "reading and writing both disallowed for channel \"%s\"", @@ -2170,8 +2170,8 @@ Tcl_UnstackChannel( * TIP #220: This is done with maximum privileges (as created). */ - statePtr->flags &= ~(TCL_READABLE|TCL_WRITABLE); - statePtr->flags |= statePtr->maxPerms; + ResetFlag(statePtr, TCL_READABLE|TCL_WRITABLE); + SetFlag(statePtr, statePtr->maxPerms); result = ChanClose(chanPtr, interp); ChannelFree(chanPtr); @@ -2378,7 +2378,7 @@ Tcl_GetChannelMode( ChannelState *statePtr = ((Channel *) chan)->state; /* State of actual channel. */ - return (statePtr->flags & (TCL_READABLE | TCL_WRITABLE)); + return GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE); } /* @@ -2481,12 +2481,12 @@ Tcl_RemoveChannelMode( emsg = "Illegal mode value."; goto error; } - if (0 == (statePtr->flags & (TCL_READABLE | TCL_WRITABLE) & ~mode)) { + if (0 == (GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE) & ~mode)) { emsg = "Bad mode, would make channel inacessible"; goto error; } - statePtr->flags &= ~mode; + ResetFlag(statePtr, mode); return TCL_OK; error: @@ -3706,7 +3706,7 @@ Tcl_CloseEx( * opened for that direction). */ - if (!(statePtr->flags & (TCL_READABLE | TCL_WRITABLE) & flags)) { + if (!(GotFlag(statePtr, TCL_READABLE|TCL_WRITABLE) & flags)) { const char *msg; if (flags & TCL_CLOSE_READ) { @@ -6416,7 +6416,7 @@ ReadChars( return 1; } - } else if (statePtr->flags & CHANNEL_EOF) { + } else if (GotFlag(statePtr, CHANNEL_EOF)) { /* * The bare \r is the only char and we will never read a * subsequent char to make the determination. @@ -6682,7 +6682,7 @@ TranslateInputEOL( char *dst = dstStart; int lesser; - if ((statePtr->flags & INPUT_SAW_CR) && srcLen) { + if (GotFlag(statePtr, INPUT_SAW_CR) && srcLen) { if (*src == '\n') { src++; srcLen--; } ResetFlag(statePtr, INPUT_SAW_CR); } @@ -7452,7 +7452,7 @@ CheckChannelErrors( * Fail if the channel is not opened for desired operation. */ - if ((statePtr->flags & direction) == 0) { + if (GotFlag(statePtr, direction) == 0) { Tcl_SetErrno(EACCES); return -1; } @@ -9138,7 +9138,7 @@ Tcl_FileEventObjCmd( } chanPtr = (Channel *) chan; statePtr = chanPtr->state; - if ((statePtr->flags & mask) == 0) { + if (GotFlag(statePtr, mask) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("channel is not %s", (mask == TCL_READABLE) ? "readable" : "writable")); return TCL_ERROR; @@ -9305,8 +9305,8 @@ TclCopyChannel( * Make sure the output side is unbuffered. */ - outStatePtr->flags = (outStatePtr->flags & ~CHANNEL_LINEBUFFERED) - | CHANNEL_UNBUFFERED; + ResetFlag(outStatePtr, CHANNEL_LINEBUFFERED); + SetFlag(outStatePtr, CHANNEL_UNBUFFERED); /* * Test for conditions where we know we can just move bytes from input @@ -10085,7 +10085,7 @@ DoRead( * There's no more buffered data... */ - if (statePtr->flags & CHANNEL_EOF) { + if (GotFlag(statePtr, CHANNEL_EOF)) { /* * ...and there never will be. */ @@ -10093,7 +10093,7 @@ DoRead( *p++ = '\r'; bytesToRead--; bufPtr->nextRemoved++; - } else if (statePtr->flags & CHANNEL_BLOCKED) { + } else if (GotFlag(statePtr, CHANNEL_BLOCKED)) { /* * ...and we cannot get more now. */ @@ -10226,20 +10226,20 @@ StopCopy( */ nonBlocking = csPtr->readFlags & CHANNEL_NONBLOCKING; - if (nonBlocking != (inStatePtr->flags & CHANNEL_NONBLOCKING)) { + if (nonBlocking != GotFlag(inStatePtr, CHANNEL_NONBLOCKING)) { SetBlockMode(NULL, csPtr->readPtr, nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING); } if (csPtr->readPtr != csPtr->writePtr) { nonBlocking = csPtr->writeFlags & CHANNEL_NONBLOCKING; - if (nonBlocking != (outStatePtr->flags & CHANNEL_NONBLOCKING)) { + if (nonBlocking != GotFlag(outStatePtr, CHANNEL_NONBLOCKING)) { SetBlockMode(NULL, csPtr->writePtr, nonBlocking ? TCL_MODE_NONBLOCKING : TCL_MODE_BLOCKING); } } ResetFlag(outStatePtr, CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); - outStatePtr->flags |= - csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); + SetFlag(outStatePtr, + csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED)); if (csPtr->cmdPtr) { Tcl_DeleteChannelHandler(inChan, CopyEventProc, csPtr); -- cgit v0.12 From 12f23af5456f4a87b8bc4d58f9dcfc0edf2c9676 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 7 Oct 2022 15:19:36 +0000 Subject: On Windows, env(HOME) should be handled case-insensitive in fCmd.test --- tests/fCmd.test | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/fCmd.test b/tests/fCmd.test index 73118f4..8c9f799 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -2598,8 +2598,8 @@ test fCmd-31.6 {file home USER} -body { # Note - as in 8.x this form does NOT necessarily give same result as # env(HOME) even when user is current user. Assume result contains user # name, else not sure how to check - file home $::tcl_platform(user) -} -match glob -result "*$::tcl_platform(user)*" + string tolower [file home $::tcl_platform(user)] +} -match glob -result [string tolower "*$::tcl_platform(user)*"] test fCmd-31.7 {file home UNKNOWNUSER} -body { file home nosuchuser } -returnCodes error -result {user "nosuchuser" doesn't exist} @@ -2640,8 +2640,8 @@ test fCmd-32.5 {file tildeexpand ~USER} -body { # Note - as in 8.x this form does NOT necessarily give same result as # env(HOME) even when user is current user. Assume result contains user # name, else not sure how to check - file tildeexpand ~$::tcl_platform(user) -} -match glob -result "*$::tcl_platform(user)*" + string tolower [file tildeexpand ~$::tcl_platform(user)] +} -match glob -result [string tolower "*$::tcl_platform(user)*"] test fCmd-32.6 {file tildeexpand ~UNKNOWNUSER} -body { file tildeexpand ~nosuchuser } -returnCodes error -result {user "nosuchuser" doesn't exist} @@ -2655,8 +2655,8 @@ test fCmd-32.9 {file tildeexpand ~USER/bar} -body { # Note - as in 8.x this form does NOT necessarily give same result as # env(HOME) even when user is current user. Assume result contains user # name, else not sure how to check - file tildeexpand ~$::tcl_platform(user)/bar -} -match glob -result "*$::tcl_platform(user)*/bar" + string tolower [file tildeexpand ~$::tcl_platform(user)/bar] +} -match glob -result [string tolower "*$::tcl_platform(user)*/bar"] test fCmd-32.10 {file tildeexpand ~UNKNOWNUSER} -body { file tildeexpand ~nosuchuser/foo } -returnCodes error -result {user "nosuchuser" doesn't exist} @@ -2679,8 +2679,8 @@ test fCmd-32.16 {file tildeexpand ~USER\\bar} -body { # Note - as in 8.x this form does NOT necessarily give same result as # env(HOME) even when user is current user. Assume result contains user # name, else not sure how to check - file tildeexpand ~$::tcl_platform(user)\\bar -} -constraints win -match glob -result "*$::tcl_platform(user)*/bar" + string tolower [file tildeexpand ~$::tcl_platform(user)\\bar] +} -constraints win -match glob -result [string tolower "*$::tcl_platform(user)*/bar"] # cleanup -- cgit v0.12 From 5e4013330a16bddc87cd9179fce996982e333f20 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 8 Oct 2022 00:10:13 +0000 Subject: -nocomplainencoding and -strictencoding are incompatible --- generic/tclIO.c | 23 +++++++++++++++++++++-- generic/tclIO.h | 2 ++ 2 files changed, 23 insertions(+), 2 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 85067f2..ca12d63 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8009,7 +8009,8 @@ Tcl_GetChannelOption( if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-nocomplainencoding"); } - Tcl_DStringAppendElement(dsPtr,"1"); + Tcl_DStringAppendElement(dsPtr, + (flags & CHANNEL_ENCODING_STRICT) ? "0" : "1"); if (len > 0) { return TCL_OK; } @@ -8283,7 +8284,17 @@ Tcl_SetChannelOption( if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { return TCL_ERROR; } - if (!newMode) { + if (newMode) { + if (statePtr->flags & CHANNEL_ENCODING_STRICT) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "-nocomplainencoding cannot be used with -strictencoding", + -1)); + } + return TCL_ERROR; + } + statePtr->flags |= CHANNEL_ENCODING_NOCOMPLAIN; + } else { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -nocomplainencoding: only true allowed", @@ -8299,6 +8310,14 @@ Tcl_SetChannelOption( return TCL_ERROR; } if (newMode) { + if (statePtr->flags & CHANNEL_ENCODING_NOCOMPLAIN) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "-strictencoding cannot be used with -nocomplainencoding", + -1)); + } + return TCL_ERROR; + } statePtr->flags |= CHANNEL_ENCODING_STRICT; } return TCL_OK; diff --git a/generic/tclIO.h b/generic/tclIO.h index b86dc1d..e8d2736 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -273,6 +273,8 @@ typedef struct ChannelState { * changes. */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ +#define CHANNEL_ENCODING_NOCOMPLAIN (1<<17) /* set if option + * -nocomplaincoding is set to 1 */ #define CHANNEL_ENCODING_STRICT (1<<18) /* set if option * -strictencoding is set to 1 */ #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. -- cgit v0.12 From bd8e0ee8b7e71085e6e3ff9a22dbc8b2b28a77f7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 8 Oct 2022 17:01:35 +0000 Subject: TIP #346 bugfix: -strictencoding should be resetable too --- generic/tclIO.c | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/generic/tclIO.c b/generic/tclIO.c index 42c9e18..a13f32c 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4399,6 +4399,8 @@ Write( if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) { statePtr->outputEncodingFlags |= TCL_ENCODING_STRICT; + } else { + statePtr->outputEncodingFlags &= ~TCL_ENCODING_STRICT; } /* @@ -4722,6 +4724,8 @@ Tcl_GetsObj( if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) { statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT; + } else { + statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT; } /* @@ -5487,6 +5491,8 @@ FilterInputBytes( if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) { statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT; + } else { + statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT; } result = Tcl_ExternalToUtf(NULL, gsPtr->encoding, raw, rawLen, @@ -6267,6 +6273,8 @@ ReadChars( if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) { statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT; + } else { + statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT; } /* @@ -8276,6 +8284,8 @@ Tcl_SetChannelOption( } if (newMode) { SetFlag(statePtr, CHANNEL_ENCODING_STRICT); + } else { + ResetFlag(statePtr, CHANNEL_ENCODING_STRICT); } return TCL_OK; } else if (HaveOpt(1, "-translation")) { -- cgit v0.12 From 6def8b0f5838db2823d34a3210e018e1a59faee7 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 9 Oct 2022 18:11:44 +0000 Subject: TIP 643 code. Docs, tests pending --- generic/tcl.decls | 5 +++++ generic/tclDecls.h | 5 +++++ generic/tclEncoding.c | 27 +++++++++++++++++++++++++++ generic/tclStubInit.c | 1 + generic/tclTest.c | 24 ++++++++++++++++++++++-- 5 files changed, 60 insertions(+), 2 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 95cecdf..cbafa6d 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2541,6 +2541,11 @@ declare 682 { # ----- BASELINE -- FOR -- 8.7.0 ----- # +# TIP 643 +declare 683 { + int Tcl_GetEncodingNulLength(Tcl_Encoding encoding) +} + ############################################################################## # Define the platform specific public Tcl interface. These functions are only diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 80131e8..849a596 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -2013,6 +2013,8 @@ EXTERN int Tcl_NRCallObjProc2(Tcl_Interp *interp, /* 682 */ EXTERN int Tcl_RemoveChannelMode(Tcl_Interp *interp, Tcl_Channel chan, int mode); +/* 683 */ +EXTERN int Tcl_GetEncodingNulLength(Tcl_Encoding encoding); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2731,6 +2733,7 @@ typedef struct TclStubs { void (*reserved680)(void); void (*reserved681)(void); int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 682 */ + int (*tcl_GetEncodingNulLength) (Tcl_Encoding encoding); /* 683 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4125,6 +4128,8 @@ extern const TclStubs *tclStubsPtr; /* Slot 681 is reserved */ #define Tcl_RemoveChannelMode \ (tclStubsPtr->tcl_RemoveChannelMode) /* 682 */ +#define Tcl_GetEncodingNulLength \ + (tclStubsPtr->tcl_GetEncodingNulLength) /* 683 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 52b02fc..efe4b43 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -983,6 +983,33 @@ Tcl_GetEncodingNames( } /* + *------------------------------------------------------------------------- + * + * Tcl_GetEncodingNulLength -- + * + * Given an encoding, return the number of nul bytes used for the + * string termination. + * + * Results: + * The name of the encoding. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +int +Tcl_GetEncodingNulLength( + Tcl_Encoding encoding) +{ + if (encoding == NULL) { + encoding = systemEncoding; + } + + return ((Encoding *) encoding)->nullSize; +} + +/* *------------------------------------------------------------------------ * * Tcl_SetSystemEncoding -- diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index c7f178f..17254b8 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -2048,6 +2048,7 @@ const TclStubs tclStubs = { 0, /* 680 */ 0, /* 681 */ Tcl_RemoveChannelMode, /* 682 */ + Tcl_GetEncodingNulLength, /* 683 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 95f4d2f..ae765aa 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -1996,12 +1996,17 @@ TestencodingObjCmd( const char *string; TclEncoding *encodingPtr; static const char *const optionStrings[] = { - "create", "delete", NULL + "create", "delete", "nullength", NULL }; enum options { - ENC_CREATE, ENC_DELETE + ENC_CREATE, ENC_DELETE, ENC_NULLENGTH }; + if (objc < 2) { + Tcl_WrongNumArgs(interp, 2, objv, "?encoding?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, &index) != TCL_OK) { return TCL_ERROR; @@ -2012,6 +2017,7 @@ TestencodingObjCmd( Tcl_EncodingType type; if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "name toutfcmd fromutfcmd"); return TCL_ERROR; } encodingPtr = (TclEncoding*)ckalloc(sizeof(TclEncoding)); @@ -2048,6 +2054,20 @@ TestencodingObjCmd( Tcl_FreeEncoding(encoding); /* Free to match CREATE */ TclFreeInternalRep(objv[2]); /* Free the cached ref */ break; + + case ENC_NULLENGTH: + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?encoding?"); + return TCL_ERROR; + } + encoding = + Tcl_GetEncoding(interp, objc == 2 ? NULL : Tcl_GetString(objv[2])); + if (encoding == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, + Tcl_NewIntObj(Tcl_GetEncodingNulLength(encoding))); + Tcl_FreeEncoding(encoding); } return TCL_OK; } -- cgit v0.12 From a2b119cac88f2853439b6781404687c40acae4d2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 9 Oct 2022 20:57:30 +0000 Subject: Tcl_NewWideIntObj -> Tcl_NewBooleanObj where appropriate --- generic/tclTest.c | 28 ++++++++++++++-------------- generic/tclTestObj.c | 12 ++++++------ generic/tclTestProcBodyObj.c | 2 +- 3 files changed, 21 insertions(+), 21 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 95f4d2f..539c90f 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -2941,7 +2941,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "int", &intVar, TCL_LINK_INT | flag) != TCL_OK) { return TCL_ERROR; @@ -2949,7 +2949,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "real", &realVar, TCL_LINK_DOUBLE | flag) != TCL_OK) { return TCL_ERROR; @@ -2957,7 +2957,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "bool", &boolVar, TCL_LINK_BOOLEAN | flag) != TCL_OK) { return TCL_ERROR; @@ -2965,7 +2965,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "string", &stringVar, TCL_LINK_STRING | flag) != TCL_OK) { return TCL_ERROR; @@ -2973,7 +2973,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[6], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "wide", &wideVar, TCL_LINK_WIDE_INT | flag) != TCL_OK) { return TCL_ERROR; @@ -2981,7 +2981,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[7], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "char", &charVar, TCL_LINK_CHAR | flag) != TCL_OK) { return TCL_ERROR; @@ -2989,7 +2989,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[8], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "uchar", &ucharVar, TCL_LINK_UCHAR | flag) != TCL_OK) { return TCL_ERROR; @@ -2997,7 +2997,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[9], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "short", &shortVar, TCL_LINK_SHORT | flag) != TCL_OK) { return TCL_ERROR; @@ -3005,7 +3005,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[10], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "ushort", &ushortVar, TCL_LINK_USHORT | flag) != TCL_OK) { return TCL_ERROR; @@ -3013,7 +3013,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[11], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "uint", &uintVar, TCL_LINK_UINT | flag) != TCL_OK) { return TCL_ERROR; @@ -3021,7 +3021,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[12], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "long", &longVar, TCL_LINK_LONG | flag) != TCL_OK) { return TCL_ERROR; @@ -3029,7 +3029,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[13], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "ulong", &ulongVar, TCL_LINK_ULONG | flag) != TCL_OK) { return TCL_ERROR; @@ -3037,7 +3037,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[14], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "float", &floatVar, TCL_LINK_FLOAT | flag) != TCL_OK) { return TCL_ERROR; @@ -3045,7 +3045,7 @@ TestlinkCmd( if (Tcl_GetBoolean(interp, argv[15], &writable) != TCL_OK) { return TCL_ERROR; } - flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY; + flag = writable ? 0 : TCL_LINK_READ_ONLY; if (Tcl_LinkVar(interp, "uwide", &uwideVar, TCL_LINK_WIDE_UINT | flag) != TCL_OK) { return TCL_ERROR; diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 721237b..c9a910a 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -292,9 +292,9 @@ TestbignumobjCmd( return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetWideIntObj(varPtr[varIndex], mp_iszero(&bignumValue)); + Tcl_SetBooleanObj(varPtr[varIndex], mp_iszero(&bignumValue)); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(mp_iszero(&bignumValue))); + SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(mp_iszero(&bignumValue))); } mp_clear(&bignumValue); break; @@ -387,9 +387,9 @@ TestbooleanobjCmd( */ if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetWideIntObj(varPtr[varIndex], boolValue != 0); + Tcl_SetBooleanObj(varPtr[varIndex], boolValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(boolValue != 0)); + SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(boolValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "get") == 0) { @@ -412,9 +412,9 @@ TestbooleanobjCmd( return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetWideIntObj(varPtr[varIndex], boolValue == 0); + Tcl_SetBooleanObj(varPtr[varIndex], !boolValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(boolValue == 0)); + SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(!boolValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else { diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index 38cfaaa..844ff1b 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -340,7 +340,7 @@ ProcBodyTestCheckObjCmd( } version = Tcl_PkgPresent(interp, packageName, packageVersion, 1); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj( + Tcl_SetObjResult(interp, Tcl_NewBooleanObj( strcmp(version, packageVersion) == 0)); return TCL_OK; } -- cgit v0.12 From 3f7f7c5584f701f2fee77dc372b824b15b1a7739 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 10 Oct 2022 11:08:38 +0000 Subject: Slight improvement to TIP #346/#633 combination: Now -strictencoding 1 automatically sets -nocomplainencoding to 0, while -nocomplainencoding 1 automatically sets strictencoding to 0. This way, they can never both be set. --- generic/tclIO.c | 30 +++++++++--------------------- 1 file changed, 9 insertions(+), 21 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 407b586..6a9c306 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8320,25 +8320,20 @@ Tcl_SetChannelOption( return TCL_ERROR; } if (newMode) { - if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "-nocomplainencoding cannot be used with -strictencoding", - -1)); - } - return TCL_ERROR; - } + ResetFlag(statePtr, CHANNEL_ENCODING_STRICT); SetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); } else { #ifdef TCL_NO_DEPRECATED ResetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); #else - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad value for -nocomplainencoding: only true allowed", - -1)); + if (SetFlag(statePtr, CHANNEL_ENCODING_STRICT)) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -nocomplainencoding: only true allowed", + TCL_INDEX_NONE)); + } + return TCL_ERROR; } - return TCL_ERROR; #endif } return TCL_OK; @@ -8349,14 +8344,7 @@ Tcl_SetChannelOption( return TCL_ERROR; } if (newMode) { - if (GotFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN)) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "-strictencoding cannot be used with -nocomplainencoding", - -1)); - } - return TCL_ERROR; - } + ResetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); SetFlag(statePtr, CHANNEL_ENCODING_STRICT); } else { ResetFlag(statePtr, CHANNEL_ENCODING_STRICT); -- cgit v0.12 From 23900950d5ad3b15b790aacb18f9e0220836b132 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 10 Oct 2022 13:52:29 +0000 Subject: Tests and docs for Tcl_GetEncodingNulLength --- doc/Encoding.3 | 6 ++++++ generic/tclTest.c | 2 +- tests/encoding.test | 11 +++++++++++ 3 files changed, 18 insertions(+), 1 deletion(-) diff --git a/doc/Encoding.3 b/doc/Encoding.3 index 86c5a78..c183b73 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -52,6 +52,9 @@ const char * \fBTcl_GetEncodingName\fR(\fIencoding\fR) .sp int +\fBTcl_GetEncodingNulLength\fR(\fIencoding\fR) +.sp +int \fBTcl_SetSystemEncoding\fR(\fIinterp, name\fR) .sp const char * @@ -292,6 +295,9 @@ was used to create the encoding. The string returned by \fBTcl_GetEncodingName\fR is only guaranteed to persist until the \fIencoding\fR is deleted. The caller must not modify this string. .PP +\fBTcl_GetEncodingNulLength\fR returns the length of the terminating +nul byte sequence for strings in the specified encoding. +.PP \fBTcl_SetSystemEncoding\fR sets the default encoding that should be used whenever the user passes a NULL value for the \fIencoding\fR argument to any of the other encoding functions. If \fIname\fR is NULL, the system diff --git a/generic/tclTest.c b/generic/tclTest.c index ae765aa..2764ced 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -2003,7 +2003,7 @@ TestencodingObjCmd( }; if (objc < 2) { - Tcl_WrongNumArgs(interp, 2, objv, "?encoding?"); + Tcl_WrongNumArgs(interp, 1, objv, "command ?args?"); return TCL_ERROR; } diff --git a/tests/encoding.test b/tests/encoding.test index c8f409e..8e529af 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -841,6 +841,17 @@ runtests } +test encoding-29.0 {get encoding nul terminator lengths} -constraints { + testencoding +} -body { + list \ + [testencoding nullength ascii] \ + [testencoding nullength utf-16] \ + [testencoding nullength utf-32] \ + [testencoding nullength gb12345] \ + [testencoding nullength ksc5601] +} -result {1 2 4 2 2} + # cleanup namespace delete ::tcl::test::encoding ::tcltest::cleanupTests -- cgit v0.12 From f2b3bc2aa5ebb89635fdb896e9ec4f67bbff445c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 10 Oct 2022 15:19:59 +0000 Subject: Use Tcl_ObjCmdProc in stead of full signature --- generic/tclClock.c | 64 +++--- generic/tclExecute.c | 4 +- generic/tclIndexObj.c | 12 +- generic/tclInt.h | 452 +++++++++++-------------------------------- generic/tclProcess.c | 24 +-- generic/tclTestProcBodyObj.c | 6 +- generic/tclThreadTest.c | 4 +- generic/tclVar.c | 54 +++--- 8 files changed, 178 insertions(+), 442 deletions(-) diff --git a/generic/tclClock.c b/generic/tclClock.c index 86eed73..a9ba70c 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -160,39 +160,19 @@ static void GetJulianDayFromEraYearWeekDay(TclDateFields *, int); static void GetJulianDayFromEraYearMonthDay(TclDateFields *, int); static int IsGregorianLeapYear(TclDateFields *); static int WeekdayOnOrBefore(int, int); -static int ClockClicksObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int ClockConvertlocaltoutcObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int ClockGetdatefieldsObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int ClockGetjuliandayfromerayearmonthdayObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int ClockGetjuliandayfromerayearweekdayObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int ClockGetenvObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int ClockMicrosecondsObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int ClockMillisecondsObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int ClockParseformatargsObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int ClockSecondsObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc ClockClicksObjCmd; +static Tcl_ObjCmdProc ClockConvertlocaltoutcObjCmd; +static Tcl_ObjCmdProc ClockGetdatefieldsObjCmd; +static Tcl_ObjCmdProc ClockGetjuliandayfromerayearmonthdayObjCmd; +static Tcl_ObjCmdProc ClockGetjuliandayfromerayearweekdayObjCmd; +static Tcl_ObjCmdProc ClockGetenvObjCmd; +static Tcl_ObjCmdProc ClockMicrosecondsObjCmd; +static Tcl_ObjCmdProc ClockMillisecondsObjCmd; +static Tcl_ObjCmdProc ClockParseformatargsObjCmd; +static Tcl_ObjCmdProc ClockSecondsObjCmd; static struct tm * ThreadSafeLocalTime(const time_t *); static void TzsetIfNecessary(void); -static void ClockDeleteCmdProc(ClientData); +static void ClockDeleteCmdProc(void *); /* * Structure containing description of "native" clock commands to create. @@ -331,7 +311,7 @@ TclClockInit( static int ClockConvertlocaltoutcObjCmd( - ClientData clientData, /* Client data */ + void *clientData, /* Client data */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const *objv) /* Parameter vector */ @@ -423,7 +403,7 @@ ClockConvertlocaltoutcObjCmd( int ClockGetdatefieldsObjCmd( - ClientData clientData, /* Opaque pointer to literal pool, etc. */ + void *clientData, /* Opaque pointer to literal pool, etc. */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const *objv) /* Parameter vector */ @@ -577,7 +557,7 @@ FetchIntField( static int ClockGetjuliandayfromerayearmonthdayObjCmd( - ClientData clientData, /* Opaque pointer to literal pool, etc. */ + void *clientData, /* Opaque pointer to literal pool, etc. */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const *objv) /* Parameter vector */ @@ -661,7 +641,7 @@ ClockGetjuliandayfromerayearmonthdayObjCmd( static int ClockGetjuliandayfromerayearweekdayObjCmd( - ClientData clientData, /* Opaque pointer to literal pool, etc. */ + void *clientData, /* Opaque pointer to literal pool, etc. */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const *objv) /* Parameter vector */ @@ -1645,7 +1625,7 @@ WeekdayOnOrBefore( int ClockGetenvObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1748,7 +1728,7 @@ ThreadSafeLocalTime( int ClockClicksObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const *objv) /* Parameter values */ @@ -1818,7 +1798,7 @@ ClockClicksObjCmd( int ClockMillisecondsObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const *objv) /* Parameter values */ @@ -1855,7 +1835,7 @@ ClockMillisecondsObjCmd( int ClockMicrosecondsObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const *objv) /* Parameter values */ @@ -1888,7 +1868,7 @@ ClockMicrosecondsObjCmd( static int ClockParseformatargsObjCmd( - ClientData clientData, /* Client data containing literal pool */ + void *clientData, /* Client data containing literal pool */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const objv[]) /* Parameter vector */ @@ -2006,7 +1986,7 @@ ClockParseformatargsObjCmd( int ClockSecondsObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const *objv) /* Parameter values */ @@ -2106,7 +2086,7 @@ TzsetIfNecessary(void) static void ClockDeleteCmdProc( - ClientData clientData) /* Opaque pointer to the client data */ + void *clientData) /* Opaque pointer to the client data */ { ClockClientData *data = (ClockClientData *)clientData; int i; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 7c7bbfd..a063aae 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -670,9 +670,7 @@ static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt); */ #ifdef TCL_COMPILE_STATS -static int EvalStatsCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc EvalStatsCmd; #endif /* TCL_COMPILE_STATS */ #ifdef TCL_COMPILE_DEBUG static const char * GetOpcodeName(const unsigned char *pc); diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 70c50cd..79be731 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -25,15 +25,9 @@ static int GetIndexFromObjList(Tcl_Interp *interp, static void UpdateStringOfIndex(Tcl_Obj *objPtr); static void DupIndex(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void FreeIndex(Tcl_Obj *objPtr); -static int PrefixAllObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int PrefixLongestObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int PrefixMatchObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc PrefixAllObjCmd; +static Tcl_ObjCmdProc PrefixLongestObjCmd; +static Tcl_ObjCmdProc PrefixMatchObjCmd; static void PrintUsage(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable); diff --git a/generic/tclInt.h b/generic/tclInt.h index e43e627..471892b 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3223,17 +3223,12 @@ MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr); MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); -MODULE_SCOPE int TclInfoExistsCmd(void *dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclInfoCoroutineCmd(void *dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclInfoExistsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclInfoCoroutineCmd; MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr); -MODULE_SCOPE int TclInfoGlobalsCmd(void *dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclInfoLocalsCmd(void *dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclInfoVarsCmd(void *dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclInfoGlobalsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclInfoLocalsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclInfoVarsCmd; MODULE_SCOPE void TclInitAlloc(void); MODULE_SCOPE void TclInitDbCkalloc(void); MODULE_SCOPE void TclInitDoubleConversion(void); @@ -3544,61 +3539,31 @@ MODULE_SCOPE int TclIsSpaceProc(int byte); *---------------------------------------------------------------- */ -MODULE_SCOPE int Tcl_AfterObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_AppendObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ApplyObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_AfterObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_AppendObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ApplyObjCmd; MODULE_SCOPE Tcl_Command TclInitArrayCmd(Tcl_Interp *interp); MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_BreakObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_BreakObjCmd; #if !defined(TCL_NO_DEPRECATED) -MODULE_SCOPE int Tcl_CaseObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_CaseObjCmd; #endif -MODULE_SCOPE int Tcl_CatchObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_CdObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_CatchObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_CdObjCmd; MODULE_SCOPE Tcl_Command TclInitChanCmd(Tcl_Interp *interp); -MODULE_SCOPE int TclChanCreateObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int TclChanPostEventObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int TclChanPopObjCmd(void *clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int TclChanPushObjCmd(void *clientData, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclChanCreateObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclChanPostEventObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclChanPopObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclChanPushObjCmd; MODULE_SCOPE void TclClockInit(Tcl_Interp *interp); -MODULE_SCOPE int TclClockOldscanObjCmd( - void *clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_CloseObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ConcatObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ContinueObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclClockOldscanObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_CloseObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ConcatObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ContinueObjCmd; MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler( Tcl_Time *timePtr, Tcl_TimerProc *proc, void *clientData); -MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd( - void *clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclDefaultBgErrorHandlerObjCmd; MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp); MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, @@ -3606,244 +3571,91 @@ MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, int pathc, Tcl_Obj *const pathv[]); -MODULE_SCOPE int Tcl_DisassembleObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_DisassembleObjCmd; /* Assemble command function */ -MODULE_SCOPE int Tcl_AssembleObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int TclNRAssembleObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_AssembleObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRAssembleObjCmd; MODULE_SCOPE Tcl_Command TclInitEncodingCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_EofObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ErrorObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_EvalObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ExecObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ExitObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ExprObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FblockedObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FconfigureObjCmd( - void *clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FcopyObjCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_EofObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ErrorObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_EvalObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ExecObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ExitObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ExprObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_FblockedObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_FconfigureObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_FcopyObjCmd; MODULE_SCOPE Tcl_Command TclInitFileCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_FileEventObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FlushObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ForObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ForeachObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_FormatObjCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_GetsObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_GlobalObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_GlobObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_IfObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_IncrObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_FileEventObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_FlushObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ForObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ForeachObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_FormatObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_GetsObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_GlobalObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_GlobObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_IfObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_IncrObjCmd; MODULE_SCOPE Tcl_Command TclInitInfoCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_InterpObjCmd(void *clientData, - Tcl_Interp *interp, int argc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_JoinObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LappendObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LassignObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LeditObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LindexObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LinsertObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LlengthObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ListObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LmapObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LoadObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LpopObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LrangeObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LremoveObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LrepeatObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LreplaceObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LreverseObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LsearchObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LseqObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LsetObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_LsortObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_InterpObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_JoinObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LappendObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LassignObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LeditObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LindexObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LinsertObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LlengthObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ListObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LmapObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LoadObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LpopObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LrangeObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LremoveObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LrepeatObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LreplaceObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LreverseObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LsearchObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LseqObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LsetObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_LsortObjCmd; MODULE_SCOPE Tcl_Command TclInitNamespaceCmd(Tcl_Interp *interp); -MODULE_SCOPE int TclNamespaceEnsembleCmd(void *dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_OpenObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_PackageObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_PidObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclNamespaceEnsembleCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_OpenObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_PackageObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_PidObjCmd; MODULE_SCOPE Tcl_Command TclInitPrefixCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_PutsObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_PwdObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ReadObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_RegexpObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_RegsubObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_RenameObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_RepresentationCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ReturnObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ScanObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SeekObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SetObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SplitObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SocketObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SourceObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_PutsObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_PwdObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ReadObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_RegexpObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_RegsubObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_RenameObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_RepresentationCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ReturnObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ScanObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_SeekObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_SetObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_SplitObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_SocketObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_SourceObjCmd; MODULE_SCOPE Tcl_Command TclInitStringCmd(Tcl_Interp *interp); -MODULE_SCOPE int Tcl_SubstObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_SwitchObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TellObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_ThrowObjCmd(void *dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TimeObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TimeRateObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TraceObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_TryObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UnloadObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UnsetObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UpdateObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UplevelObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_UpvarObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_VariableObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_VwaitObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_WhileObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc Tcl_SubstObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_SwitchObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_TellObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_ThrowObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_TimeObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_TimeRateObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_TraceObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_TryObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_UnloadObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_UnsetObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_UpdateObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_UplevelObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_UpvarObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_VariableObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_VwaitObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc Tcl_WhileObjCmd; /* *---------------------------------------------------------------- @@ -4173,105 +3985,71 @@ MODULE_SCOPE int TclCompileBasicMin2ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclInvertOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclInvertOpCmd; MODULE_SCOPE int TclCompileInvertOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclNotOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclNotOpCmd; MODULE_SCOPE int TclCompileNotOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclAddOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclAddOpCmd; MODULE_SCOPE int TclCompileAddOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclMulOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclMulOpCmd; MODULE_SCOPE int TclCompileMulOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclAndOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclAndOpCmd; MODULE_SCOPE int TclCompileAndOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclOrOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclOrOpCmd; MODULE_SCOPE int TclCompileOrOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclXorOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclXorOpCmd; MODULE_SCOPE int TclCompileXorOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclPowOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclPowOpCmd; MODULE_SCOPE int TclCompilePowOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclLshiftOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclLshiftOpCmd; MODULE_SCOPE int TclCompileLshiftOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclRshiftOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclRshiftOpCmd; MODULE_SCOPE int TclCompileRshiftOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclModOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclModOpCmd; MODULE_SCOPE int TclCompileModOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclNeqOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclNeqOpCmd; MODULE_SCOPE int TclCompileNeqOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclStrneqOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclStrneqOpCmd; MODULE_SCOPE int TclCompileStrneqOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclInOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclInOpCmd; MODULE_SCOPE int TclCompileInOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclNiOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclNiOpCmd; MODULE_SCOPE int TclCompileNiOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclMinusOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclMinusOpCmd; MODULE_SCOPE int TclCompileMinusOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclDivOpCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TclDivOpCmd; MODULE_SCOPE int TclCompileDivOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/generic/tclProcess.c b/generic/tclProcess.c index 65c087c..aec8c0a 100644 --- a/generic/tclProcess.c +++ b/generic/tclProcess.c @@ -51,18 +51,10 @@ static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid, int options, int *codePtr, Tcl_Obj **msgPtr, Tcl_Obj **errorObjPtr); static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info); -static int ProcessListObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int ProcessStatusObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int ProcessPurgeObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int ProcessAutopurgeObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc ProcessListObjCmd; +static Tcl_ObjCmdProc ProcessStatusObjCmd; +static Tcl_ObjCmdProc ProcessPurgeObjCmd; +static Tcl_ObjCmdProc ProcessAutopurgeObjCmd; /* *---------------------------------------------------------------------- @@ -402,7 +394,7 @@ BuildProcessStatusObj( static int ProcessListObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -453,7 +445,7 @@ ProcessListObjCmd( static int ProcessStatusObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -601,7 +593,7 @@ ProcessStatusObjCmd( static int ProcessPurgeObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -701,7 +693,7 @@ ProcessPurgeObjCmd( static int ProcessAutopurgeObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index 844ff1b..9b6aa1d 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -45,10 +45,8 @@ typedef struct CmdTable { * Declarations for functions defined in this file. */ -static int ProcBodyTestProcObjCmd(void *dummy, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int ProcBodyTestCheckObjCmd(void *dummy, - Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc ProcBodyTestProcObjCmd; +static Tcl_ObjCmdProc ProcBodyTestCheckObjCmd; static int ProcBodyTestInitInternal(Tcl_Interp *interp, int isSafe); static int RegisterCommand(Tcl_Interp* interp, const char *namesp, const CmdTable *cmdTablePtr); diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index cf9d0da..03446c2 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -119,9 +119,7 @@ static char *errorProcString; TCL_DECLARE_MUTEX(threadMutex) -static int ThreadObjCmd(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc ThreadObjCmd; static int ThreadCreate(Tcl_Interp *interp, const char *script, int joinable); static int ThreadList(Tcl_Interp *interp); diff --git a/generic/tclVar.c b/generic/tclVar.c index 2ef51b2..2a96fb6 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -212,9 +212,7 @@ static void UnsetVarStruct(Var *varPtr, Var *arrayPtr, * TIP #508: [array default] */ -static int ArrayDefaultCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc ArrayDefaultCmd; static void DeleteArrayVar(Var *arrayPtr); static void SetArrayDefault(Var *arrayPtr, Tcl_Obj *defaultObj); @@ -1524,7 +1522,7 @@ TclPtrGetVarIdx( int Tcl_SetObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp,/* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2818,7 +2816,7 @@ UnsetVarStruct( int Tcl_UnsetObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2885,7 +2883,7 @@ Tcl_UnsetObjCmd( int Tcl_AppendObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2950,7 +2948,7 @@ Tcl_AppendObjCmd( int Tcl_LappendObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3156,7 +3154,7 @@ ArrayObjNext( static int ArrayForObjCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3166,7 +3164,7 @@ ArrayForObjCmd( static int ArrayForNRCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -3237,7 +3235,7 @@ ArrayForNRCmd( static int ArrayForLoopCallback( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -3395,7 +3393,7 @@ ArrayPopulateSearch( static int ArrayStartSearchCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -3490,7 +3488,7 @@ ArrayDoneSearch( static int ArrayAnyMoreCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -3568,7 +3566,7 @@ ArrayAnyMoreCmd( static int ArrayNextElementCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -3648,7 +3646,7 @@ ArrayNextElementCmd( static int ArrayDoneSearchCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -3708,7 +3706,7 @@ ArrayDoneSearchCmd( static int ArrayExistsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -3748,7 +3746,7 @@ ArrayExistsCmd( static int ArrayGetCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -3907,7 +3905,7 @@ ArrayGetCmd( static int ArrayNamesCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -4074,7 +4072,7 @@ TclFindArrayPtrElements( static int ArraySetCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -4249,7 +4247,7 @@ ArraySetCmd( static int ArraySizeCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -4308,7 +4306,7 @@ ArraySizeCmd( static int ArrayStatsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -4362,7 +4360,7 @@ ArrayStatsCmd( static int ArrayUnsetCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -4987,7 +4985,7 @@ Tcl_GetVariableFullName( int Tcl_GlobalObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -5091,7 +5089,7 @@ Tcl_GlobalObjCmd( int Tcl_VariableObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -5224,7 +5222,7 @@ Tcl_VariableObjCmd( int Tcl_UpvarObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -6036,7 +6034,7 @@ ObjFindNamespaceVar( int TclInfoVarsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -6227,7 +6225,7 @@ TclInfoVarsCmd( int TclInfoGlobalsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -6320,7 +6318,7 @@ TclInfoGlobalsCmd( int TclInfoLocalsCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -6625,7 +6623,7 @@ CompareVarKeys( static int ArrayDefaultCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ -- cgit v0.12 From 763c581edb801f34c61cce8eadcf7d8904b3cce9 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 10 Oct 2022 15:37:23 +0000 Subject: Bugfix library/http/http.tcl for connection request header - tcllib/websocket ticket [d01de3281f]. Revise header order in 3 tests. --- library/http/http.tcl | 37 ++++++++++++++++++++++++++++++------- tests/http.test | 6 +++--- 2 files changed, 33 insertions(+), 10 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 326aede..88685ec 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -1260,6 +1260,7 @@ proc http::CreateToken {url args} { [GetFieldValue $state(-headers) Upgrade]] set state(upgradeRequest) [expr { "upgrade" in $connectionValues && [llength $upgradeValues] >= 1}] + set state(connectionValues) $connectionValues if {$isQuery || $isQueryChannel} { # It's a POST. @@ -2104,24 +2105,25 @@ proc http::Connected {token proto phost srvurl} { if {($state(-protocol) > 1.0) && $state(-keepalive)} { # Send this header, because a 1.1 server is not compelled to treat # this as the default. - SendHeader $token Connection keep-alive - } - if {($state(-protocol) > 1.0) && !$state(-keepalive)} { - SendHeader $token Connection close ;# RFC2616 sec 8.1.2.1 - } - if {($state(-protocol) < 1.1)} { + set ConnVal keep-alive + } elseif {($state(-protocol) > 1.0)} { + # RFC2616 sec 8.1.2.1 + set ConnVal close + } else { + # ($state(-protocol) <= 1.0) # RFC7230 A.1 # Some server implementations of HTTP/1.0 have a faulty # implementation of RFC 2068 Keep-Alive. # Don't leave this to chance. # For HTTP/1.0 we have already "set state(connection) close" # and "state(-keepalive) 0". - SendHeader $token Connection close + set ConnVal close } # RFC7230 A.1 - "clients are encouraged not to send the # Proxy-Connection header field in any requests" set accept_encoding_seen 0 set content_type_seen 0 + set connection_seen 0 foreach {key value} $state(-headers) { set value [string map [list \n "" \r ""] $value] set key [string map {" " -} [string trim $key]] @@ -2141,6 +2143,24 @@ proc http::Connected {token proto phost srvurl} { set contDone 1 set state(querylength) $value } + if {[string equal -nocase $key "connection"]} { + # Remove "close" or "keep-alive" and use our own value. + # In an upgrade request, the upgrade is not guaranteed. + # Value "close" or "keep-alive" tells the server what to do + # if it refuses the upgrade. We send a single "Connection" + # header because some websocket servers, e.g. civetweb, reject + # multiple headers. Bug [d01de3281f] of tcllib/websocket. + set connection_seen 1 + set listVal $state(connectionValues) + if {[set pos [lsearch $listVal close]] != -1} { + set listVal [lreplace $listVal $pos $pos] + } + if {[set pos [lsearch $listVal keep-alive]] != -1} { + set listVal [lreplace $listVal $pos $pos] + } + lappend listVal $ConnVal + set value [join $listVal {, }] + } if {[string length $key]} { SendHeader $token $key $value } @@ -2159,6 +2179,9 @@ proc http::Connected {token proto phost srvurl} { SendHeader $token Accept-Encoding identity } else { } + if {!$connection_seen} { + SendHeader $token Connection $ConnVal + } if {$isQueryChannel && ($state(querylength) == 0)} { # Try to determine size of data in channel. If we cannot seek, the # surrounding catch will trap us diff --git a/tests/http.test b/tests/http.test index e88210a..1218536 100644 --- a/tests/http.test +++ b/tests/http.test @@ -409,10 +409,10 @@ test http-3.27 {http::geturl: -headers override -type} -body { http::cleanup $token } -match regexp -result {(?n)Host .* User-Agent .* -Connection close Content-Type {text/plain;charset=utf-8} Accept \*/\* Accept-Encoding .* +Connection close Content-Length 5} test http-3.28 {http::geturl: -headers override -type default} -body { set token [http::geturl $url/headers -query dummy \ @@ -422,10 +422,10 @@ test http-3.28 {http::geturl: -headers override -type default} -body { http::cleanup $token } -match regexp -result {(?n)Host .* User-Agent .* -Connection close Content-Type {text/plain;charset=utf-8} Accept \*/\* Accept-Encoding .* +Connection close Content-Length 5} test http-3.29 {http::geturl IPv6 address} -body { # We only want to see if the URL gets parsed correctly. This is @@ -462,9 +462,9 @@ test http-3.32 {http::geturl: -headers override -accept default} -body { http::cleanup $token } -match regexp -result {(?n)Host .* User-Agent .* -Connection close Accept text/plain,application/tcl-test-value Accept-Encoding .* +Connection close Content-Type application/x-www-form-urlencoded Content-Length 5} # Bug 838e99a76d -- cgit v0.12 From b17bb4724c7bee03cf081b87436b936da78681c5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 11 Oct 2022 06:22:10 +0000 Subject: Making a start fixing [6978c01b65]: Channel encoding difference 8.6 <-> 9.0 --- generic/tclIO.c | 12 +++++++++++- generic/tclIO.h | 2 ++ 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 6a9c306..097b6ee 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4466,7 +4466,7 @@ Write( * current output encoding and strict encoding is active. */ - if (result == TCL_CONVERT_UNKNOWN) { + if (result == TCL_CONVERT_UNKNOWN || result == TCL_CONVERT_SYNTAX) { encodingError = 1; result = TCL_OK; } @@ -5516,6 +5516,11 @@ FilterInputBytes( &statePtr->inputEncodingState, dst, spaceLeft, &gsPtr->rawRead, &gsPtr->bytesWrote, &gsPtr->charsWrote); + if (result == TCL_CONVERT_UNKNOWN || result == TCL_CONVERT_SYNTAX) { + SetFlag(statePtr, CHANNEL_ENCODING_ERROR); + result = TCL_OK; + } + /* * Make sure that if we go through 'gets', that we reset the * TCL_ENCODING_START flag still. [Bug #523988] @@ -6344,6 +6349,11 @@ ReadChars( flags, &statePtr->inputEncodingState, dst, dstLimit, &srcRead, &dstDecoded, &numChars); + if (code == TCL_CONVERT_UNKNOWN || code == TCL_CONVERT_SYNTAX) { + SetFlag(statePtr, CHANNEL_ENCODING_ERROR); + code = TCL_OK; + } + /* * Perform the translation transformation in place. Read no more than * the dstDecoded bytes the encoding transformation actually produced. diff --git a/generic/tclIO.h b/generic/tclIO.h index e8d2736..8f30cf0 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -271,6 +271,8 @@ typedef struct ChannelState { * delivered for buffered data until * the state of the channel * changes. */ +#define CHANNEL_ENCODING_ERROR (1<<15) /* set if channel + * encountered an encoding error */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ #define CHANNEL_ENCODING_NOCOMPLAIN (1<<17) /* set if option -- cgit v0.12 From 0d0cf6602a9b466d777c22736156422c586c8c94 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 11 Oct 2022 06:26:44 +0000 Subject: There's a duplicate set of io-75.* testcases, so renumber one of them --- tests/io.test | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/tests/io.test b/tests/io.test index 96abadd..f928cd3 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9052,7 +9052,7 @@ test io-75.5 {incomplete shiftjis encoding read is ignored} -setup { -test io-75.0 {channel modes} -setup { +test io-76.0 {channel modes} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile r] } -constraints testchannel -body { @@ -9062,7 +9062,7 @@ test io-75.0 {channel modes} -setup { removeFile dummy } -result {read {}} -test io-75.1 {channel modes} -setup { +test io-76.1 {channel modes} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile w] } -constraints testchannel -body { @@ -9072,7 +9072,7 @@ test io-75.1 {channel modes} -setup { removeFile dummy } -result {{} write} -test io-75.2 {channel modes} -setup { +test io-76.2 {channel modes} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile r+] } -constraints testchannel -body { @@ -9082,7 +9082,7 @@ test io-75.2 {channel modes} -setup { removeFile dummy } -result {read write} -test io-75.3 {channel mode dropping} -setup { +test io-76.3 {channel mode dropping} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile r] } -constraints testchannel -body { @@ -9093,7 +9093,7 @@ test io-75.3 {channel mode dropping} -setup { removeFile dummy } -result {{read {}} {read {}}} -test io-75.4 {channel mode dropping} -setup { +test io-76.4 {channel mode dropping} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile r] } -constraints testchannel -body { @@ -9103,7 +9103,7 @@ test io-75.4 {channel mode dropping} -setup { removeFile dummy } -match glob -result {Tcl_RemoveChannelMode error: Bad mode, would make channel inacessible. Channel: "*"} -test io-75.5 {channel mode dropping} -setup { +test io-76.5 {channel mode dropping} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile w] } -constraints testchannel -body { @@ -9114,7 +9114,7 @@ test io-75.5 {channel mode dropping} -setup { removeFile dummy } -result {{{} write} {{} write}} -test io-75.6 {channel mode dropping} -setup { +test io-76.6 {channel mode dropping} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile w] } -constraints testchannel -body { @@ -9124,7 +9124,7 @@ test io-75.6 {channel mode dropping} -setup { removeFile dummy } -match glob -result {Tcl_RemoveChannelMode error: Bad mode, would make channel inacessible. Channel: "*"} -test io-75.7 {channel mode dropping} -setup { +test io-76.7 {channel mode dropping} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile r+] } -constraints testchannel -body { @@ -9135,7 +9135,7 @@ test io-75.7 {channel mode dropping} -setup { removeFile dummy } -result {{{} write} {read write}} -test io-75.8 {channel mode dropping} -setup { +test io-76.8 {channel mode dropping} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile r+] } -constraints testchannel -body { @@ -9146,7 +9146,7 @@ test io-75.8 {channel mode dropping} -setup { removeFile dummy } -result {{read {}} {read write}} -test io-75.9 {channel mode dropping} -setup { +test io-76.9 {channel mode dropping} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile r+] } -constraints testchannel -body { @@ -9157,7 +9157,7 @@ test io-75.9 {channel mode dropping} -setup { removeFile dummy } -match glob -result {Tcl_RemoveChannelMode error: Bad mode, would make channel inacessible. Channel: "*"} -test io-75.10 {channel mode dropping} -setup { +test io-76.10 {channel mode dropping} -setup { set datafile [makeFile {some characters} dummy] set f [open $datafile r+] } -constraints testchannel -body { -- cgit v0.12 From 6b05e4086f08a1a91dc39467e9421a011ba91768 Mon Sep 17 00:00:00 2001 From: sbron Date: Tue, 11 Oct 2022 10:37:03 +0000 Subject: Update Tcl_TraceVar manual page. --- doc/TraceVar.3 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/doc/TraceVar.3 b/doc/TraceVar.3 index 649565a..2a3c58d 100644 --- a/doc/TraceVar.3 +++ b/doc/TraceVar.3 @@ -137,9 +137,11 @@ trace was created. \fIclientData\fR typically points to an application-specific data structure that describes what to do when \fIproc\fR is invoked. -\fIName1\fR and \fIname2\fR give the name of the traced variable -in the normal two-part form (see the description of \fBTcl_TraceVar2\fR -below for details). +\fIName1\fR and \fIname2\fR give the name of the variable that +triggered the callback in the normal two-part form (see the description +of \fBTcl_TraceVar2\fR below for details). In case \fIname1\fR is an +alias to an array element (created through facilities such as \fBupvar\fR), +\fIname2\fR holds the index of the array element, rather than NULL. \fIFlags\fR is an OR-ed combination of bits providing several pieces of information. One of the bits \fBTCL_TRACE_READS\fR, \fBTCL_TRACE_WRITES\fR, -- cgit v0.12 From 75ba8ac33bf8e8e9c0dfed189d177ebb6710dd15 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 11 Oct 2022 11:02:45 +0000 Subject: Format errors in vwait.n --- doc/vwait.n | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/vwait.n b/doc/vwait.n index 5f240d6..d67c16d 100644 --- a/doc/vwait.n +++ b/doc/vwait.n @@ -13,7 +13,7 @@ vwait \- Process events until a variable is written .SH SYNOPSIS \fBvwait\fR \fIvarName\fR .PP -\fBvwait\fR ?\Ioptions\fR? ?\fIvarName ...\fR? +\fBvwait\fR ?\fIoptions\fR? ?\fIvarName ...\fR? .BE .SH DESCRIPTION .PP @@ -66,7 +66,7 @@ Events of the windowing system are not handled during the wait operation. \fIChannel\fR must name a Tcl channel open for reading. If \fIchannel\fR is or becomes readable the wait operation completes. .TP -\fB\-timeout\fR milliseconds\fR +\fB\-timeout\fR \fImilliseconds\fR . The wait operation is constrained to \fImilliseconds\fR. .TP -- cgit v0.12 From d4c0a2c2ae26239197650eaaf6388d7ccdc51e48 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 11 Oct 2022 14:22:17 +0000 Subject: Few more formatting errors --- doc/http.n | 6 +----- doc/vwait.n | 2 +- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/doc/http.n b/doc/http.n index c08d221..59f15b6 100644 --- a/doc/http.n +++ b/doc/http.n @@ -613,13 +613,11 @@ The "request line" is the first line of a HTTP client request, and has three elements separated by spaces: the HTTP method, the URL relative to the server, and the HTTP version. Examples: .PP -.DS .RS GET / HTTP/1.1 GET /introduction.html?subject=plumbing HTTP/1.1 POST /forms/order.html HTTP/1.1 .RE -.DE .TP \fB::http::requestHeaders\fR \fItoken\fR ?\fIheaderName\fR? . @@ -650,12 +648,10 @@ elements separated by spaces: the HTTP version, a three-digit numerical "status code", and a "reason phrase". Only the reason phrase may contain spaces. Examples: .PP -.DS .RS HTTP/1.1 200 OK HTTP/1.0 404 Not Found .RE -.DE .RS The "status code" is a three-digit number in the range 100 to 599. A value of 200 is the normal return from a GET request, and its matching @@ -1589,7 +1585,7 @@ that \fB::tls::socketCmd\fR has this value, it replaces it with the value i.e. if the script or the Tcl installation has replaced the value "::socket" with the name of a different command, then http does not change the value. The script or installation that modified \fB::tls::socketCmd\fR is responsible -for integrating \fR::http::socket\fR into its own replacement command. +for integrating \fB::http::socket\fR into its own replacement command. .PP .SS "WITH A CHILD INTERPRETER" .PP diff --git a/doc/vwait.n b/doc/vwait.n index d67c16d..e595a74 100644 --- a/doc/vwait.n +++ b/doc/vwait.n @@ -12,7 +12,7 @@ vwait \- Process events until a variable is written .SH SYNOPSIS \fBvwait\fR \fIvarName\fR -.PP +.sp \fBvwait\fR ?\fIoptions\fR? ?\fIvarName ...\fR? .BE .SH DESCRIPTION -- cgit v0.12 From 4391b633d94f7d36fc07107753bac88a29504488 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 11 Oct 2022 15:07:33 +0000 Subject: TIP 644 - Make Tcl_ObjType extensible --- generic/tcl.h | 5 +++++ generic/tclArithSeries.c | 3 ++- generic/tclAssembly.c | 3 ++- generic/tclBinary.c | 3 ++- generic/tclCompile.c | 4 +++- generic/tclDictObj.c | 3 ++- generic/tclDisassemble.c | 1 + generic/tclEncoding.c | 8 +++++++- generic/tclEnsemble.c | 3 ++- generic/tclExecute.c | 5 +++-- generic/tclIO.c | 3 ++- generic/tclIndexObj.c | 3 ++- generic/tclLink.c | 3 ++- generic/tclListObj.c | 3 ++- generic/tclNamesp.c | 3 ++- generic/tclOOCall.c | 3 ++- generic/tclObj.c | 15 ++++++++++----- generic/tclPathObj.c | 3 ++- generic/tclProc.c | 8 +++++--- generic/tclRegexp.c | 3 ++- generic/tclStringObj.c | 3 ++- generic/tclUtil.c | 3 ++- generic/tclVar.c | 4 ++-- 23 files changed, 66 insertions(+), 29 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 80494f3..f1d27ef 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -616,7 +616,12 @@ typedef struct Tcl_ObjType { /* Called to convert the object's internal rep * to this type. Frees the internal rep of the * old type. Returns TCL_ERROR on failure. */ + unsigned char version; } Tcl_ObjType; +#define TCL_OBJTYPE_V0 0 /* Pre-Tcl 9. Set to 0 so compiler will auto-init + * when existing code that does not init this field + * is compiled with Tcl9 headers */ +#define TCL_OBJTYPE_CURRENT TCL_OBJTYPE_V0 /* * The following structure stores an internal representation (internalrep) for diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index d88c8ed..65807c3 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -75,7 +75,8 @@ const Tcl_ObjType tclArithSeriesType = { FreeArithSeriesInternalRep, /* freeIntRepProc */ DupArithSeriesInternalRep, /* dupIntRepProc */ UpdateStringOfArithSeries, /* updateStringProc */ - SetArithSeriesFromAny /* setFromAnyProc */ + SetArithSeriesFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index b7bfd2d..9448162 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -325,7 +325,8 @@ static const Tcl_ObjType assembleCodeType = { FreeAssembleCodeInternalRep, /* freeIntRepProc */ DupAssembleCodeInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* diff --git a/generic/tclBinary.c b/generic/tclBinary.c index a7d6617..7e2634c 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -162,7 +162,8 @@ static const Tcl_ObjType properByteArrayType = { FreeProperByteArrayInternalRep, DupProperByteArrayInternalRep, UpdateStringOfByteArray, - NULL + NULL, + TCL_OBJTYPE_V0 }; /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a57743c..fc2b6b7 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -708,7 +708,8 @@ const Tcl_ObjType tclByteCodeType = { FreeByteCodeInternalRep, /* freeIntRepProc */ DupByteCodeInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetByteCodeFromAny /* setFromAnyProc */ + SetByteCodeFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* @@ -722,6 +723,7 @@ static const Tcl_ObjType substCodeType = { DupByteCodeInternalRep, /* dupIntRepProc - shared with bytecode */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; #define SubstFlags(objPtr) (objPtr)->internalRep.twoPtrValue.ptr2 diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index ca2501c..26f98e1 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -146,7 +146,8 @@ const Tcl_ObjType tclDictType = { FreeDictInternalRep, /* freeIntRepProc */ DupDictInternalRep, /* dupIntRepProc */ UpdateStringOfDict, /* updateStringProc */ - SetDictFromAny /* setFromAnyProc */ + SetDictFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; #define DictSetInternalRep(objPtr, dictRepPtr) \ diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 8fd90a3..9670b84 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -42,6 +42,7 @@ static const Tcl_ObjType instNameType = { NULL, /* dupIntRepProc */ UpdateStringOfInstName, /* updateStringProc */ NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0, }; #define InstNameSetInternalRep(objPtr, inst) \ diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index e366904..7e7c1a6 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -236,8 +236,14 @@ static Tcl_EncodingConvertProc Iso88591ToUtfProc; */ static const Tcl_ObjType encodingType = { - "encoding", FreeEncodingInternalRep, DupEncodingInternalRep, NULL, NULL + "encoding", + FreeEncodingInternalRep, + DupEncodingInternalRep, + NULL, + NULL, + TCL_OBJTYPE_V0, }; + #define EncodingSetInternalRep(objPtr, encoding) \ do { \ Tcl_ObjInternalRep ir; \ diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 8bb90da..44179cf 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -81,7 +81,8 @@ static const Tcl_ObjType ensembleCmdType = { FreeEnsembleCmdRep, /* freeIntRepProc */ DupEnsembleCmdRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; #define ECRSetInternalRep(objPtr, ecRepPtr) \ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 4b9ed0d..2ec0337 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -663,7 +663,8 @@ static const Tcl_ObjType exprCodeType = { FreeExprCodeInternalRep, /* freeIntRepProc */ DupExprCodeInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* @@ -674,7 +675,7 @@ static const Tcl_ObjType exprCodeType = { static const Tcl_ObjType dictIteratorType = { "dictIterator", ReleaseDictIterator, - NULL, NULL, NULL + NULL, NULL, NULL, TCL_OBJTYPE_V0 }; /* diff --git a/generic/tclIO.c b/generic/tclIO.c index 5f831c9..8d54045 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -332,7 +332,8 @@ static const Tcl_ObjType chanObjType = { FreeChannelInternalRep, /* freeIntRepProc */ DupChannelInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; #define ChanSetInternalRep(objPtr, resPtr) \ diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index aab7820..58bcc04 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -41,7 +41,8 @@ static const Tcl_ObjType indexType = { FreeIndex, /* freeIntRepProc */ DupIndex, /* dupIntRepProc */ UpdateStringOfIndex, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* diff --git a/generic/tclLink.c b/generic/tclLink.c index 2649d12..d184700 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -114,7 +114,8 @@ static Tcl_ObjType invalidRealType = { NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 14f6132..06a316f 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -155,7 +155,8 @@ const Tcl_ObjType tclListType = { FreeListInternalRep, /* freeIntRepProc */ DupListInternalRep, /* dupIntRepProc */ UpdateStringOfList, /* updateStringProc */ - SetListFromAny /* setFromAnyProc */ + SetListFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* Macros to manipulate the List internal rep */ diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 979426c..1882e0a 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -130,7 +130,8 @@ static const Tcl_ObjType nsNameType = { FreeNsNameInternalRep, /* freeIntRepProc */ DupNsNameInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetNsNameFromAny /* setFromAnyProc */ + SetNsNameFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; #define NsNameSetInternalRep(objPtr, nnPtr) \ diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 912c368..450fc9f 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -150,7 +150,8 @@ static const Tcl_ObjType methodNameType = { FreeMethodNameRep, DupMethodNameRep, NULL, - NULL + NULL, + TCL_OBJTYPE_V0 }; diff --git a/generic/tclObj.c b/generic/tclObj.c index 5e55784..eeaa727 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -230,28 +230,32 @@ const Tcl_ObjType tclBooleanType = { NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ - TclSetBooleanFromAny /* setFromAnyProc */ + TclSetBooleanFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; const Tcl_ObjType tclDoubleType = { "double", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfDouble, /* updateStringProc */ - SetDoubleFromAny /* setFromAnyProc */ + SetDoubleFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; const Tcl_ObjType tclIntType = { "int", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfInt, /* updateStringProc */ - SetIntFromAny /* setFromAnyProc */ + SetIntFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; const Tcl_ObjType tclBignumType = { "bignum", /* name */ FreeBignum, /* freeIntRepProc */ DupBignum, /* dupIntRepProc */ UpdateStringOfBignum, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* @@ -295,7 +299,8 @@ Tcl_ObjType tclCmdNameType = { FreeCmdNameInternalRep, /* freeIntRepProc */ DupCmdNameInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetCmdNameFromAny /* setFromAnyProc */ + SetCmdNameFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 40955b1..17bbc46 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -41,7 +41,8 @@ static const Tcl_ObjType fsPathType = { FreeFsPathInternalRep, /* freeIntRepProc */ DupFsPathInternalRep, /* dupIntRepProc */ UpdateStringOfFsPath, /* updateStringProc */ - SetFsPathFromAny /* setFromAnyProc */ + SetFsPathFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* diff --git a/generic/tclProc.c b/generic/tclProc.c index acb520c..a9baba2 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -63,8 +63,9 @@ const Tcl_ObjType tclProcBodyType = { NULL, /* UpdateString function; Tcl_GetString and * Tcl_GetStringFromObj should panic * instead. */ - NULL /* SetFromAny function; Tcl_ConvertToType + NULL, /* SetFromAny function; Tcl_ConvertToType * should panic instead. */ + TCL_OBJTYPE_V0 }; #define ProcSetIntRep(objPtr, procPtr) \ @@ -93,7 +94,7 @@ const Tcl_ObjType tclProcBodyType = { static const Tcl_ObjType levelReferenceType = { "levelReference", - NULL, NULL, NULL, NULL + NULL, NULL, NULL, NULL, TCL_OBJTYPE_V0 }; /* @@ -110,7 +111,8 @@ static const Tcl_ObjType lambdaType = { FreeLambdaInternalRep, /* freeIntRepProc */ DupLambdaInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetLambdaFromAny /* setFromAnyProc */ + SetLambdaFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; #define LambdaSetIntRep(objPtr, procPtr, nsObjPtr) \ diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index 5fe5412..259e3f7 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -106,7 +106,8 @@ const Tcl_ObjType tclRegexpType = { FreeRegexpInternalRep, /* freeIntRepProc */ DupRegexpInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetRegexpFromAny /* setFromAnyProc */ + SetRegexpFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; #define RegexpSetInternalRep(objPtr, rePtr) \ diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index cf23aab..fb7e45a 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -90,7 +90,8 @@ const Tcl_ObjType tclStringType = { FreeStringInternalRep, /* freeIntRepPro */ DupStringInternalRep, /* dupIntRepProc */ UpdateStringOfString, /* updateStringProc */ - SetStringFromAny /* setFromAnyProc */ + SetStringFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 5870781..cdaa242 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -127,7 +127,8 @@ static const Tcl_ObjType endOffsetType = { NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ + NULL, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; /* diff --git a/generic/tclVar.c b/generic/tclVar.c index 337f923..6226e1e 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -245,7 +245,7 @@ static Tcl_DupInternalRepProc DupParsedVarName; static const Tcl_ObjType localVarNameType = { "localVarName", - FreeLocalVarName, DupLocalVarName, NULL, NULL + FreeLocalVarName, DupLocalVarName, NULL, NULL, TCL_OBJTYPE_V0 }; #define LocalSetInternalRep(objPtr, index, namePtr) \ @@ -268,7 +268,7 @@ static const Tcl_ObjType localVarNameType = { static const Tcl_ObjType parsedVarNameType = { "parsedVarName", - FreeParsedVarName, DupParsedVarName, NULL, NULL + FreeParsedVarName, DupParsedVarName, NULL, NULL, TCL_OBJTYPE_V0 }; #define ParsedSetInternalRep(objPtr, arrayPtr, elem) \ -- cgit v0.12 From 7a961752a9d930a7eb51f6f813df3e4570026bb1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 11 Oct 2022 15:48:43 +0000 Subject: Make TCL_ENCODING_STRICT and TCL_ENCODING_NOCOMPLAIN work independant from each other (suggested by Harald Oehlmann) --- generic/tcl.h | 4 +++- generic/tclEncoding.c | 2 +- generic/tclIO.c | 34 +++++++++++++++++++++------------- 3 files changed, 25 insertions(+), 15 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 80494f3..1d2c5be 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1890,6 +1890,8 @@ typedef struct Tcl_EncodingType { * reset to an initial state. If the source * buffer contains the entire input stream to be * converted, this flag should be set. + * TCL_ENCODING_STRICT - Be more strict in accepting what + * is considered a 'invalid byte sequence'. * TCL_ENCODING_STOPONERROR - Not used any more. * TCL_ENCODING_NO_TERMINATE - If set, Tcl_ExternalToUtf does not append a * terminating NUL byte. Since it does not need @@ -1921,12 +1923,12 @@ typedef struct Tcl_EncodingType { #define TCL_ENCODING_START 0x01 #define TCL_ENCODING_END 0x02 +#define TCL_ENCODING_STRICT 0x04 #define TCL_ENCODING_STOPONERROR 0x0 /* Not used any more */ #define TCL_ENCODING_NO_TERMINATE 0x08 #define TCL_ENCODING_CHAR_LIMIT 0x10 #define TCL_ENCODING_MODIFIED 0x20 #define TCL_ENCODING_NOCOMPLAIN 0x40 -#define TCL_ENCODING_STRICT 0x44 /* * The following definitions are the error codes returned by the conversion diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index e366904..cd6aacb 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2222,7 +2222,7 @@ BinaryProc( *------------------------------------------------------------------------- */ -#define STOPONERROR ((flags & TCL_ENCODING_STRICT) != TCL_ENCODING_NOCOMPLAIN) +#define STOPONERROR (!(flags & TCL_ENCODING_NOCOMPLAIN)) static int UtfToUtfProc( diff --git a/generic/tclIO.c b/generic/tclIO.c index 5f831c9..48aa18d 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4360,14 +4360,16 @@ Write( } /* - * Transfer encoding strict/nocomplain option to the encoding flags + * Transfer encoding nocomplain/strict option to the encoding flags */ + if (GotFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN)) { + statePtr->outputEncodingFlags |= TCL_ENCODING_NOCOMPLAIN; + } else { + statePtr->outputEncodingFlags &= ~TCL_ENCODING_NOCOMPLAIN; + } if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) { statePtr->outputEncodingFlags |= TCL_ENCODING_STRICT; - } else if (GotFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN)) { - statePtr->outputEncodingFlags &= ~TCL_ENCODING_STRICT; - statePtr->outputEncodingFlags |= TCL_ENCODING_NOCOMPLAIN; } else { statePtr->outputEncodingFlags &= ~TCL_ENCODING_STRICT; } @@ -4693,11 +4695,13 @@ Tcl_GetsObj( * Transfer encoding nocomplain/strict option to the encoding flags */ + if (GotFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN)) { + statePtr->inputEncodingFlags |= TCL_ENCODING_NOCOMPLAIN; + } else { + statePtr->inputEncodingFlags &= ~TCL_ENCODING_NOCOMPLAIN; + } if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) { statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT; - } else if (GotFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN)) { - statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT; - statePtr->inputEncodingFlags |= TCL_ENCODING_NOCOMPLAIN; } else { statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT; } @@ -5464,11 +5468,13 @@ FilterInputBytes( * Transfer encoding nocomplain/strict option to the encoding flags */ + if (GotFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN)) { + statePtr->inputEncodingFlags |= TCL_ENCODING_NOCOMPLAIN; + } else { + statePtr->inputEncodingFlags &= ~TCL_ENCODING_NOCOMPLAIN; + } if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) { statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT; - } else if (GotFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN)) { - statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT; - statePtr->inputEncodingFlags |= TCL_ENCODING_NOCOMPLAIN; } else { statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT; } @@ -6250,11 +6256,13 @@ ReadChars( * Transfer encoding nocomplain/strict option to the encoding flags */ + if (GotFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN)) { + statePtr->inputEncodingFlags |= TCL_ENCODING_NOCOMPLAIN; + } else { + statePtr->inputEncodingFlags &= ~TCL_ENCODING_NOCOMPLAIN; + } if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) { statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT; - } else if (GotFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN)) { - statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT; - statePtr->inputEncodingFlags |= TCL_ENCODING_NOCOMPLAIN; } else { statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT; } -- cgit v0.12 From b758c501cf323af7a0fddb806260e84ad03c68e5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 11 Oct 2022 15:51:42 +0000 Subject: Document TCL_ENCODING_STRICT flag --- doc/Encoding.3 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/doc/Encoding.3 b/doc/Encoding.3 index 86c5a78..553cc21 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -114,7 +114,9 @@ byte is converted and then to reset to an initial state. \fBTCL_ENCODING_STOPONERROR\fR signifies that the conversion routine should return immediately upon reading a source character that does not exist in the target encoding; otherwise a default fallback character will -automatically be substituted. The flag \fBTCL_ENCODING_NOCOMPLAIN\fR has +automatically be substituted. The flag \fBTCL_ENCODING_STRICT\fR makes the +encoder/decoder more strict in what it considers to be an invalid byte +sequence. The flag \fBTCL_ENCODING_NOCOMPLAIN\fR has no effect, it is reserved for Tcl 9.0. The flag \fBTCL_ENCODING_MODIFIED\fR makes \fBTcl_UtfToExternalDStringEx\fR and \fBTcl_UtfToExternal\fR produce the byte sequence \exC0\ex80 in stead of \ex00, for the utf-8/cesu-8 encoders. -- cgit v0.12 From 01b1e3aadf2bece4ca5fe2711ee9d6b06bf351ed Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 12 Oct 2022 11:25:28 +0000 Subject: TIP #344 bugfix: on some platforms, needs to be included first --- unix/tclUnixSock.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index e904cfd..abd7fa6 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -9,8 +9,8 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include #include "tclInt.h" +#include /* * Helper macros to make parts of this file clearer. The macros do exactly -- cgit v0.12 From 4addfd1f1e4fe9475c50be231c97bea3ffb086f1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 12 Oct 2022 16:04:12 +0000 Subject: Extract TIP #637 implementation from "novem" branch --- doc/glob.n | 4 +-- generic/tclFileName.c | 54 +++++++++++--------------------------- generic/tclInt.h | 13 ---------- library/package.tcl | 3 +++ tests/fCmd.test | 8 +++--- tests/fileName.test | 72 +++++++++++++++++++++++++-------------------------- tests/winFile.test | 2 +- 7 files changed, 61 insertions(+), 95 deletions(-) diff --git a/doc/glob.n b/doc/glob.n index 8a3099e..80610f7 100644 --- a/doc/glob.n +++ b/doc/glob.n @@ -46,8 +46,8 @@ separators. .TP \fB\-nocomplain\fR . -Allows an empty list to be returned without error; without this -switch an error is returned if the result list would be empty. +Allows an empty list to be returned without error; This is the +default behavior in Tcl 9.0, so this switch has no effect any more. .TP \fB\-path\fR \fIpathPrefix\fR . diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 408d295..040f0fd 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -35,6 +35,14 @@ static Tcl_Obj * SplitUnixPath(const char *path); static int DoGlob(Tcl_Interp *interp, Tcl_Obj *resultPtr, const char *separators, Tcl_Obj *pathPtr, int flags, char *pattern, Tcl_GlobTypeData *types); +static int TclGlob(Tcl_Interp *interp, char *pattern, + Tcl_Obj *pathPrefix, int globFlags, + Tcl_GlobTypeData *types); + +/* Flag values used by TclGlob() */ + +#define TCL_GLOBMODE_DIR 4 +#define TCL_GLOBMODE_TAILS 8 /* * When there is no support for getting the block size of a file in a stat() @@ -1132,8 +1140,8 @@ Tcl_GlobObjCmd( dir = PATH_NONE; typePtr = NULL; for (i = 1; i < objc; i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, - &index) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[i], options, + "option", 0, &index) != TCL_OK) { string = TclGetString(objv[i]); if (string[0] == '-') { /* @@ -1155,7 +1163,10 @@ Tcl_GlobObjCmd( switch (index) { case GLOB_NOCOMPLAIN: /* -nocomplain */ - globFlags |= TCL_GLOBMODE_NO_COMPLAIN; + /* + * Do nothing; This is normal operations in Tcl 9. + * Keep accepting as a no-op option to accommodate old scripts. + */ break; case GLOB_DIR: /* -dir */ if (i == (objc-1)) { @@ -1513,41 +1524,6 @@ Tcl_GlobObjCmd( } } - if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) { - if (TclListObjLengthM(interp, Tcl_GetObjResult(interp), - &length) != TCL_OK) { - /* - * This should never happen. Maybe we should be more dramatic. - */ - - result = TCL_ERROR; - goto endOfGlob; - } - - if (length == 0) { - Tcl_Obj *errorMsg = - Tcl_ObjPrintf("no files matched glob pattern%s \"", - (join || (objc == 1)) ? "" : "s"); - - if (join) { - Tcl_AppendToObj(errorMsg, Tcl_DStringValue(&prefix), -1); - } else { - const char *sep = ""; - - for (i = 0; i < objc; i++) { - Tcl_AppendPrintfToObj(errorMsg, "%s%s", - sep, TclGetString(objv[i])); - sep = " "; - } - } - Tcl_AppendToObj(errorMsg, "\"", -1); - Tcl_SetObjResult(interp, errorMsg); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "NOMATCH", - NULL); - result = TCL_ERROR; - } - } - endOfGlob: if (join || (dir == PATH_GENERAL)) { Tcl_DStringFree(&prefix); @@ -1595,7 +1571,7 @@ Tcl_GlobObjCmd( *---------------------------------------------------------------------- */ -int +static int TclGlob( Tcl_Interp *interp, /* Interpreter for returning error message or * appending list of matching file names. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index a02650a..a876f37 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2767,16 +2767,6 @@ typedef struct TclFileAttrProcs { typedef struct TclFile_ *TclFile; -/* - * The "globParameters" argument of the function TclGlob is an or'ed - * combination of the following values: - */ - -#define TCL_GLOBMODE_NO_COMPLAIN 1 -#define TCL_GLOBMODE_JOIN 2 -#define TCL_GLOBMODE_DIR 4 -#define TCL_GLOBMODE_TAILS 8 - typedef enum Tcl_PathPart { TCL_PATH_DIRNAME, TCL_PATH_TAIL, @@ -3188,9 +3178,6 @@ MODULE_SCOPE int TclGetLoadedLibraries(Tcl_Interp *interp, const char *packageName); MODULE_SCOPE int TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *, Tcl_WideInt *); -MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, - Tcl_Obj *unquotedPrefix, int globFlags, - Tcl_GlobTypeData *types); MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr); MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, diff --git a/library/package.tcl b/library/package.tcl index 5f0795f..0c4aa29 100644 --- a/library/package.tcl +++ b/library/package.tcl @@ -137,6 +137,9 @@ proc pkg_mkIndex {args} { } on error {msg opt} { return -options $opt $msg } + if {[llength $fileList] == 0} { + return -code error "no files matched glob pattern \"$patternList\"" + } foreach file $fileList { # For each file, figure out what commands and packages it provides. # To do this, create a child interpreter, load the file into the diff --git a/tests/fCmd.test b/tests/fCmd.test index 811beb3..93793d1 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -829,12 +829,12 @@ test fCmd-7.4 {FileForceOption: bad option} -constraints {notRoot} -setup { } -result {bad option "-tf1": must be -force or --} test fCmd-7.5 {FileForceOption: multiple times through loop} -setup { cleanup -} -constraints {notRoot} -returnCodes error -body { +} -constraints {notRoot} -body { createfile -- createfile -force file delete -force -force -- -- -force glob -- -- -force -} -result {no files matched glob patterns "-- -force"} +} -result {} test fCmd-8.1 {FileBasename: basename of ~user: argc == 1 && *path == ~} \ -constraints {unix notRoot knownBug tildeexpansion} -body { @@ -994,9 +994,9 @@ test fCmd-9.10 {file rename: comprehensive: file to new name and dir} -setup { testchmod 0o444 tf2 file rename tf1 [file join td1 tf3] file rename tf2 [file join td1 tf4] - list [catch {glob tf*}] [lsort [glob -directory td1 t*]] \ + list [glob tf*] [lsort [glob -directory td1 t*]] \ [file writable [file join td1 tf3]] [file writable [file join td1 tf4]] -} -result [subst {1 {[file join td1 tf3] [file join td1 tf4]} 1 0}] +} -result [subst {{} {[file join td1 tf3] [file join td1 tf4]} 1 0}] test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} -setup { cleanup } -constraints {notRoot testchmod} -body { diff --git a/tests/fileName.test b/tests/fileName.test index c4735cb..416c419 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -701,9 +701,9 @@ test filename-10.24 {Tcl_TranslateFileName} -body { testtranslatefilename ~ouster/foo } -result {/home/ouster/foo} -constraints {nonPortable testtranslatefilename} -test filename-11.1 {Tcl_GlobCmd} -returnCodes error -body { +test filename-11.1 {Tcl_GlobCmd} -body { glob -} -result {no files matched glob patterns ""} +} -result {} test filename-11.2 {Tcl_GlobCmd} -returnCodes error -body { glob -gorp } -result {bad option "-gorp": must be -directory, -join, -nocomplain, -path, -tails, -types, or --} @@ -717,19 +717,19 @@ test filename-11.5 {Tcl_GlobCmd} -body { # Should not error out because of ~ catch {glob -nocomplain * ~xyqrszzz} } -result 0 -test filename-11.6 {Tcl_GlobCmd} -returnCodes error -body { +test filename-11.6 {Tcl_GlobCmd} -body { glob ~xyqrszzz -} -result {no files matched glob pattern "~xyqrszzz"} -test filename-11.7 {Tcl_GlobCmd} -returnCodes error -body { +} -result {} +test filename-11.7 {Tcl_GlobCmd} -body { glob -- -nocomplain -} -result {no files matched glob pattern "-nocomplain"} +} -result {} test filename-11.8 {Tcl_GlobCmd} -body { glob -nocomplain -- -nocomplain } -result {} test filename-11.9 {Tcl_GlobCmd} -constraints {testsetplatform} -body { testsetplatform unix glob ~\\xyqrszzz/bar -} -returnCodes error -result {no files matched glob pattern "~\xyqrszzz/bar"} +} -result {} test filename-11.10 {Tcl_GlobCmd} -constraints {testsetplatform} -body { testsetplatform unix glob -nocomplain ~\\xyqrszzz/bar @@ -737,22 +737,22 @@ test filename-11.10 {Tcl_GlobCmd} -constraints {testsetplatform} -body { test filename-11.11 {Tcl_GlobCmd} -constraints {testsetplatform} -body { testsetplatform unix glob ~xyqrszzz\\/\\bar -} -returnCodes error -result {no files matched glob pattern "~xyqrszzz\/\bar"} +} -result {} test filename-11.12 {Tcl_GlobCmd} -constraints {testsetplatform} -setup { testsetplatform unix set home $env(HOME) } -body { unset env(HOME) glob ~/* -} -returnCodes error -cleanup { +} -cleanup { set env(HOME) $home -} -result {no files matched glob pattern "~/*"} +} -result {} if {[testConstraint testsetplatform]} { testsetplatform $platform } test filename-11.13 {Tcl_GlobCmd} -body { file join [lindex [glob ~] 0] -} -returnCodes error -result {no files matched glob pattern "~"} +} -result {} set oldpwd [pwd] set oldhome $env(HOME) catch {cd [makeDirectory tcl[pid]]} @@ -772,10 +772,10 @@ touch globTest/.1 touch globTest/x,z1.c test filename-11.14 {Tcl_GlobCmd} -body { glob ~/globTest -} -returnCodes error -result {no files matched glob pattern "~/globTest"} +} -result {} test filename-11.15 {Tcl_GlobCmd} -body { glob ~\\/globTest -} -returnCodes error -result {no files matched glob pattern "~\/globTest"} +} -result {} test filename-11.16 {Tcl_GlobCmd} { glob globTest } {globTest} @@ -1098,42 +1098,42 @@ file delete -force $tildeglobname set globname globTest unset horribleglobname tildeglobname -test filename-12.1 {simple globbing} {unixOrWin} { +test filename-12.1 {simple globbing} -constraints {unixOrWin} -body { glob {} -} {.} +} -result {.} test filename-12.1.1 {simple globbing} -constraints {unixOrWin} -body { glob -types f {} -} -returnCodes error -result {no files matched glob pattern ""} -test filename-12.1.2 {simple globbing} {unixOrWin} { +} -result {} +test filename-12.1.2 {simple globbing} -constraints {unixOrWin} -body { glob -types d {} -} {.} -test filename-12.1.3 {simple globbing} {unix} { +} -result {.} +test filename-12.1.3 {simple globbing} -constraints {unix} -body { glob -types hidden {} -} {.} +} -result {.} test filename-12.1.4 {simple globbing} -constraints {win} -body { glob -types hidden {} -} -returnCodes error -result {no files matched glob pattern ""} +} -result {} test filename-12.1.5 {simple globbing} -constraints {win} -body { glob -types hidden c:/ -} -returnCodes error -result {no files matched glob pattern "c:/"} -test filename-12.1.6 {simple globbing} {win} { +} -result {} +test filename-12.1.6 {simple globbing} -constraints {win} -body { glob c:/ -} {c:/} -test filename-12.3 {simple globbing} { +} -result {c:/} +test filename-12.3 {simple globbing} -body { glob -nocomplain \{a1,a2\} -} {} +} -result {} set globPreResult globTest/ set x1 x1.c set y1 y1.c -test filename-12.4 {simple globbing} {unixOrWin} { +test filename-12.4 {simple globbing} -constraints {unixOrWin} -body { lsort [glob globTest/x1.c globTest/y1.c globTest/foo] -} "$globPreResult$x1 $globPreResult$y1" -test filename-12.5 {simple globbing} { +} -result "$globPreResult$x1 $globPreResult$y1" +test filename-12.5 {simple globbing} -body { glob globTest\\/x1.c -} "$globPreResult$x1" -test filename-12.6 {simple globbing} { +} -result "$globPreResult$x1" +test filename-12.6 {simple globbing} -body { glob globTest\\/\\x1.c -} "$globPreResult$x1" +} -result "$globPreResult$x1" test filename-12.7 {globbing at filesystem root} -constraints {unix} -body { list [glob -nocomplain /*] [glob -path / *] } -match compareWords -result equal @@ -1265,10 +1265,10 @@ test filename-14.20 {asterisks, question marks, and brackets} { } {} test filename-14.21 {asterisks, question marks, and brackets} -body { glob globTest/*/gorp -} -returnCodes error -result {no files matched glob pattern "globTest/*/gorp"} +} -result {} test filename-14.22 {asterisks, question marks, and brackets} -body { glob goo/* x*z foo?q -} -returnCodes error -result {no files matched glob patterns "goo/* x*z foo?q"} +} -result {} test filename-14.23 {slash globbing} {unix} { glob / } / @@ -1368,7 +1368,7 @@ test filename-15.5 {unix specific globbing} {unix nonPortable} { # supported, the test was meaningless test filename-15.7 {glob tilde} -body { glob ~ -} -returnCodes error -result {no files matched glob pattern "~"} +} -result {} test filename-15.8 {win and unix specific globbing} -constraints {unixOrWin} -setup { global env set temp $env(HOME) @@ -1379,7 +1379,7 @@ test filename-15.8 {win and unix specific globbing} -constraints {unixOrWin} -se } -cleanup { set env(HOME) $temp catch {file delete -force $env(HOME)/globTest/anyname} -} -returnCodes error -result {no files matched glob pattern "~"} +} -result {} # The following tests are only valid for Windows systems. set oldDir [pwd] diff --git a/tests/winFile.test b/tests/winFile.test index 38f6954..231fb3f 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -28,7 +28,7 @@ testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] test winFile-1.1 {TclpGetUserHome} -constraints {win} -body { glob ~nosuchuser -} -returnCodes error -result {no files matched glob pattern "~nosuchuser"} +} -result {} test winFile-1.2 {TclpGetUserHome} -constraints {win nonPortable} -body { # The administrator account should always exist. glob ~administrator -- cgit v0.12 From cbd41f6910eac83dfe47c930b5d9ab50c503596a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 13 Oct 2022 09:07:22 +0000 Subject: Fix socket_*-7.3 testcase (since 2 socket options were added) --- tests/socket.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/socket.test b/tests/socket.test index 7250cb8..7fdb09d 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -1071,7 +1071,7 @@ test socket_$af-7.3 {testing socket specific options} -constraints [list socket close $s update llength $l -} -result 18 +} -result 22 test socket_$af-7.4 {testing socket specific options} -constraints [list socket supported_$af] -setup { set timer [after 10000 "set x timed_out"] set l "" -- cgit v0.12 From 0f77e154ab45515b9f12a97807769db1fdf35f96 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 13 Oct 2022 14:56:20 +0000 Subject: More progress in handling rules.vc --- win/rules.vc | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/win/rules.vc b/win/rules.vc index 6e06943..abb8b2c 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -24,7 +24,7 @@ _RULES_VC = 1 # For modifications that are not backward-compatible, you *must* change # the major version. RULES_VERSION_MAJOR = 1 -RULES_VERSION_MINOR = 10 +RULES_VERSION_MINOR = 11 # The PROJECT macro must be defined by parent makefile. !if "$(PROJECT)" == "" @@ -880,6 +880,7 @@ USE_THREAD_ALLOC= 0 !if [nmakehlp -f $(OPTS) "tcl8"] !message *** Build for Tcl8 TCL_MAJOR_VERSION = 8 +TCL_BUILD_FOR = 8 !endif !if $(TCL_MAJOR_VERSION) == 8 @@ -1171,7 +1172,7 @@ TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX:t=).exe TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX:t=).exe !endif -!if $(TCL_MAJOR_VERSION) == 8 +!if $(TCL_MAJOR_VERSION) == 8 && "$(TCL_BUILD_FOR)" != "8" TCLSTUBLIB = $(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib !else TCLSTUBLIB = $(_TCLDIR)\lib\tclstub.lib @@ -1195,7 +1196,7 @@ TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX:t=).exe !if !exist($(TCLSH)) TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX:t=).exe !endif -!if $(TCL_MAJOR_VERSION) == 8 +!if $(TCL_MAJOR_VERSION) == 8 && "$(TCL_BUILD_FOR)" != "8" TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib !else TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub.lib @@ -1215,7 +1216,11 @@ TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win" !endif # TCLINSTALL +!if !$(STATIC_BUILD) +tcllibs = "$(TCLSTUBLIB)" +!else tcllibs = "$(TCLSTUBLIB)" "$(TCLIMPLIB)" +!endif !endif # $(DOING_TCL) -- cgit v0.12 From f685c98a417dcab25fd035553cd16b61fbdeb74d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 13 Oct 2022 20:17:44 +0000 Subject: Make TclGlob() a static function --- generic/tclFileName.c | 13 ++++++++++++- generic/tclInt.h | 13 ++++++------- 2 files changed, 18 insertions(+), 8 deletions(-) diff --git a/generic/tclFileName.c b/generic/tclFileName.c index b553621..3cdd52f 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -37,6 +37,17 @@ static Tcl_Obj * SplitUnixPath(const char *path); static int DoGlob(Tcl_Interp *interp, Tcl_Obj *resultPtr, const char *separators, Tcl_Obj *pathPtr, int flags, char *pattern, Tcl_GlobTypeData *types); +static int TclGlob(Tcl_Interp *interp, char *pattern, + Tcl_Obj *pathPrefix, int globFlags, + Tcl_GlobTypeData *types); + +/* Flag values used by TclGlob() */ + +#ifdef TCL_NO_DEPRECATED +# define TCL_GLOBMODE_NO_COMPLAIN 1 +# define TCL_GLOBMODE_DIR 4 +# define TCL_GLOBMODE_TAILS 8 +#endif /* * When there is no support for getting the block size of a file in a stat() @@ -1688,7 +1699,7 @@ Tcl_GlobObjCmd( *---------------------------------------------------------------------- */ -int +static int TclGlob( Tcl_Interp *interp, /* Interpreter for returning error message or * appending list of matching file names. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 471892b..c15293a 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2781,10 +2781,12 @@ typedef struct TclFile_ *TclFile; * combination of the following values: */ -#define TCL_GLOBMODE_NO_COMPLAIN 1 -#define TCL_GLOBMODE_JOIN 2 -#define TCL_GLOBMODE_DIR 4 -#define TCL_GLOBMODE_TAILS 8 +#ifndef TCL_NO_DEPRECATED +# define TCL_GLOBMODE_NO_COMPLAIN 1 +# define TCL_GLOBMODE_JOIN 2 +# define TCL_GLOBMODE_DIR 4 +# define TCL_GLOBMODE_TAILS 8 +#endif typedef enum Tcl_PathPart { TCL_PATH_DIRNAME, @@ -3216,9 +3218,6 @@ MODULE_SCOPE int TclGetLoadedLibraries(Tcl_Interp *interp, const char *packageName); MODULE_SCOPE int TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *, Tcl_WideInt *); -MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, - Tcl_Obj *unquotedPrefix, int globFlags, - Tcl_GlobTypeData *types); MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr); MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, -- cgit v0.12 From e7e044e96841e4bdbbf931d03658b12d8315af19 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 14 Oct 2022 11:22:20 +0000 Subject: Build-fix --- win/rules.vc | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/win/rules.vc b/win/rules.vc index abb8b2c..89a72ce 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -879,7 +879,6 @@ USE_THREAD_ALLOC= 0 !if [nmakehlp -f $(OPTS) "tcl8"] !message *** Build for Tcl8 -TCL_MAJOR_VERSION = 8 TCL_BUILD_FOR = 8 !endif @@ -1172,7 +1171,7 @@ TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX:t=).exe TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX:t=).exe !endif -!if $(TCL_MAJOR_VERSION) == 8 && "$(TCL_BUILD_FOR)" != "8" +!if $(TCL_MAJOR_VERSION) == 8 TCLSTUBLIB = $(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib !else TCLSTUBLIB = $(_TCLDIR)\lib\tclstub.lib @@ -1196,7 +1195,7 @@ TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX:t=).exe !if !exist($(TCLSH)) TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX:t=).exe !endif -!if $(TCL_MAJOR_VERSION) == 8 && "$(TCL_BUILD_FOR)" != "8" +!if $(TCL_MAJOR_VERSION) == 8 TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib !else TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub.lib @@ -1216,7 +1215,7 @@ TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win" !endif # TCLINSTALL -!if !$(STATIC_BUILD) +!if !$(STATIC_BUILD) && "$(TCL_BUILD_FOR)" == "8" tcllibs = "$(TCLSTUBLIB)" !else tcllibs = "$(TCLSTUBLIB)" "$(TCLIMPLIB)" @@ -1240,7 +1239,7 @@ WISHNAMEPREFIX = wish WISHNAME = $(WISHNAMEPREFIX)$(TK_VERSION)$(SUFX).exe TKLIBNAME8 = tk$(TK_VERSION)$(SUFX).$(EXT) TKLIBNAME9 = tcl9tk$(TK_VERSION)$(SUFX).$(EXT) -!if $(TCL_MAJOR_VERSION) == 8 +!if $(TCL_MAJOR_VERSION) == 8 || "$(TCL_BUILD_FOR)" == "8" TKLIBNAME = tk$(TK_VERSION)$(SUFX).$(EXT) TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX).lib !else @@ -1297,7 +1296,7 @@ tklibs = "$(TKSTUBLIB)" "$(TKIMPLIB)" PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib PRJLIBNAME8 = $(PROJECT)$(VERSION)$(SUFX).$(EXT) PRJLIBNAME9 = tcl9$(PROJECT)$(VERSION)$(SUFX).$(EXT) -!if $(TCL_MAJOR_VERSION) == 8 +!if $(TCL_MAJOR_VERSION) == 8 || "$(TCL_BUILD_FOR)" == "8" PRJLIBNAME = $(PRJLIBNAME8) !else PRJLIBNAME = $(PRJLIBNAME9) @@ -1455,7 +1454,7 @@ COMPILERFLAGS = /D_ATL_XP_TARGETING !if "$(TCL_UTF_MAX)" == "3" OPTDEFINES = $(OPTDEFINES) /DTCL_UTF_MAX=3 !endif -!if $(TCL_MAJOR_VERSION) == 8 +!if "$(TCL_BUILD_FOR)" == "8" OPTDEFINES = $(OPTDEFINES) /DTCL_MAJOR_VERSION=8 !endif -- cgit v0.12 From e960c97fadd45f3b9a938716d996ff5588c28558 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 14 Oct 2022 13:36:25 +0000 Subject: Fix [7505fac5bd]: new iocmd.test failures --- tests/ioCmd.test | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 70f6b5c..6fc4de0 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -2914,7 +2914,7 @@ test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body rename foo {} set res } -constraints {testchannel thread} \ - -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} + -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} * -translation {auto *}}} test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -2927,7 +2927,7 @@ test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { rename foo {} set res } -constraints {testchannel thread} \ - -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} + -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} * -translation {auto *}}} test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -2943,7 +2943,7 @@ test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { rename foo {} set res } -constraints {testchannel thread} \ - -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}} + -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} * -translation {auto *} -bar foo -snarf x}} test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { -- cgit v0.12 From 20af6b5bdd79037a7dc053dcc37c183262ed8018 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 14 Oct 2022 14:40:27 +0000 Subject: typo --- doc/expr.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/expr.n b/doc/expr.n index 490217c..d003a30 100644 --- a/doc/expr.n +++ b/doc/expr.n @@ -50,7 +50,7 @@ the end of the expression, whichever comes first. .PP An expression consists of a combination of operands, operators, parentheses and commas, possibly with whitespace between any of these elements, which is -ignored. Each operand is intepreted as a numeric value if at all possible. +ignored. Each operand is interpreted as a numeric value if at all possible. .PP Each operand has one of the following forms: .RS -- cgit v0.12 From 6d004906276da0cdf24745a523dd66c46e8e0e17 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 14 Oct 2022 15:51:05 +0000 Subject: Improve error-message "cannot use xxxx as operand ....." --- generic/tclExecute.c | 85 ++++++++++----------- tests/assemble.test | 2 +- tests/compExpr-old.test | 25 ++++--- tests/execute.test | 22 +++--- tests/expr-old.test | 65 ++++++++-------- tests/expr.test | 56 +++++++------- tests/mathop.test | 194 ++++++++++++++++++++++++------------------------ tests/while-old.test | 2 +- tests/while.test | 4 +- 9 files changed, 229 insertions(+), 226 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index a063aae..47cb5e6 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -167,7 +167,7 @@ static BuiltinFunc const tclBuiltinFuncTable[] = { * Minimal data required to fully reconstruct the execution state. */ -typedef struct TEBCdata { +typedef struct { ByteCode *codePtr; /* Constant until the BC returns */ /* -----------------------------------------*/ Tcl_Obj **catchTop; /* These fields are used on return TO this */ @@ -2446,8 +2446,8 @@ TEBCresume( if (traceInstructions) { TRACE_APPEND(("YIELD...\n")); } else { - fprintf(stdout, "%d: (%u) yielding value \"%.30s\"\n", - iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), + fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) yielding value \"%.30s\"\n", + iPtr->numLevels, (size_t)(pc - codePtr->codeStart), Tcl_GetString(OBJ_AT_TOS)); } fflush(stdout); @@ -2489,8 +2489,8 @@ TEBCresume( TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr))); } else { /* FIXME: What is the right thing to trace? */ - fprintf(stdout, "%d: (%u) yielding to [%.30s]\n", - iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), + fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) yielding to [%.30s]\n", + iPtr->numLevels, (size_t)(pc - codePtr->codeStart), TclGetString(valuePtr)); } fflush(stdout); @@ -2851,8 +2851,8 @@ TEBCresume( strncpy(cmdNameBuf, TclGetString(objv[0]), 20); TRACE(("%u => call ", objc)); } else { - fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels, - (unsigned)(pc - codePtr->codeStart)); + fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels, + (size_t)(pc - codePtr->codeStart)); } for (i = 0; i < objc; i++) { TclPrintObject(stdout, objv[i], 15); @@ -2984,8 +2984,8 @@ TEBCresume( TRACE(("%u => call (implementation %s) ", objc, O2S(objPtr))); } else { fprintf(stdout, - "%d: (%u) invoking (using implementation %s) ", - iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), + "%d: (%" TCL_Z_MODIFIER "u) invoking (using implementation %s) ", + iPtr->numLevels, (size_t)(pc - codePtr->codeStart), O2S(objPtr)); } for (i = 0; i < objc; i++) { @@ -4308,15 +4308,15 @@ TEBCresume( case INST_JUMP1: opnd = TclGetInt1AtPtr(pc+1); - TRACE(("%d => new pc %u\n", opnd, - (unsigned)(pc + opnd - codePtr->codeStart))); + TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", opnd, + (size_t)(pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); break; case INST_JUMP4: opnd = TclGetInt4AtPtr(pc+1); - TRACE(("%d => new pc %u\n", opnd, - (unsigned)(pc + opnd - codePtr->codeStart))); + TRACE(("%d => new pc %" TCL_Z_MODIFIER "u\n", opnd, + (size_t)(pc + opnd - codePtr->codeStart))); NEXT_INST_F(opnd, 0, 0); { @@ -4358,8 +4358,8 @@ TEBCresume( #ifdef TCL_COMPILE_DEBUG if (b) { if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { - TRACE_APPEND(("%.20s true, new pc %u\n", O2S(valuePtr), - (unsigned)(pc + jmpOffset[1] - codePtr->codeStart))); + TRACE_APPEND(("%.20s true, new pc %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), + (size_t)(pc + jmpOffset[1] - codePtr->codeStart))); } else { TRACE_APPEND(("%.20s true\n", O2S(valuePtr))); } @@ -4367,8 +4367,8 @@ TEBCresume( if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) { TRACE_APPEND(("%.20s false\n", O2S(valuePtr))); } else { - TRACE_APPEND(("%.20s false, new pc %u\n", O2S(valuePtr), - (unsigned)(pc + jmpOffset[0] - codePtr->codeStart))); + TRACE_APPEND(("%.20s false, new pc %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), + (size_t)(pc + jmpOffset[0] - codePtr->codeStart))); } } #endif @@ -4392,8 +4392,8 @@ TEBCresume( if (hPtr != NULL) { int jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr)); - TRACE_APPEND(("found in table, new pc %u\n", - (unsigned)(pc - codePtr->codeStart + jumpOffset))); + TRACE_APPEND(("found in table, new pc %" TCL_Z_MODIFIER "u\n", + (size_t)(pc - codePtr->codeStart + jumpOffset))); NEXT_INST_F(jumpOffset, 1, 0); } else { TRACE_APPEND(("not found in table\n")); @@ -4638,9 +4638,9 @@ TEBCresume( if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { - fprintf(stdout, "%d: (%u) invoking ", + fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", iPtr->numLevels, - (unsigned)(pc - codePtr->codeStart)); + (size_t)(pc - codePtr->codeStart)); } for (i = 0; i < opnd; i++) { TclPrintObject(stdout, objv[i], 15); @@ -4664,7 +4664,7 @@ TEBCresume( TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n", O2S(valuePtr))); - for (i = contextPtr->index ; i >= 0 ; i--) { + for (i = contextPtr->index ; i != TCL_INDEX_NONE ; i--) { miPtr = contextPtr->callPtr->chain + i; if (miPtr->isFilter || miPtr->mPtr->declaringClassPtr != classPtr) { @@ -4740,8 +4740,8 @@ TEBCresume( if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { - fprintf(stdout, "%d: (%u) invoking ", - iPtr->numLevels, (unsigned)(pc - codePtr->codeStart)); + fprintf(stdout, "%d: (%" TCL_Z_MODIFIER "u) invoking ", + iPtr->numLevels, (size_t)(pc - codePtr->codeStart)); } for (i = 0; i < opnd; i++) { TclPrintObject(stdout, objv[i], 15); @@ -7585,7 +7585,7 @@ TEBCresume( { /* Read the wall clock */ Tcl_WideInt wval; Tcl_Time now; - switch(TclGetUInt1AtPtr(pc+1)) { + switch (TclGetUInt1AtPtr(pc+1)) { case 0: /* clicks */ #ifdef TCL_WIDE_CLICKS wval = TclpGetWideClicks(); @@ -7682,7 +7682,7 @@ TEBCresume( rangePtr->codeOffset, rangePtr->breakOffset)); NEXT_INST_F(0, 0, 0); } - if (rangePtr->continueOffset == -1) { + if (rangePtr->continueOffset == TCL_INDEX_NONE) { TRACE_APPEND(("%s, loop w/o continue, checking for catch\n", StringForResultCode(result))); goto checkForCatch; @@ -9124,7 +9124,6 @@ PrintByteCodeInfo( fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_Z_MODIFIER "u, epoch %u, interp 0x%p (epoch %u)\n", codePtr, (size_t)codePtr->refCount, codePtr->compileEpoch, iPtr, iPtr->compileEpoch); - fprintf(stdout, " Source: "); TclPrintSource(stdout, codePtr->source, 60); @@ -9139,13 +9138,13 @@ PrintByteCodeInfo( 0.0); #ifdef TCL_COMPILE_STATS - fprintf(stdout, " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", + fprintf(stdout, " Code %lu = header %" TCL_Z_MODIFIER "u+inst %d+litObj %" TCL_Z_MODIFIER "u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER "u+cmdMap %d\n", (unsigned long) codePtr->structureSize, - (unsigned long) offsetof(ByteCode, localCachePtr), + offsetof(ByteCode, localCachePtr), codePtr->numCodeBytes, - (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), - (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), - (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), + codePtr->numLitObjects * sizeof(Tcl_Obj *), + codePtr->numExceptRanges*sizeof(ExceptionRange), + codePtr->numAuxDataItems * sizeof(AuxData), codePtr->numCmdLocBytes); #endif /* TCL_COMPILE_STATS */ if (procPtr != NULL) { @@ -9289,7 +9288,8 @@ IllegalExprOperandType( } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't use %s as operand of \"%s\"", description, op)); + "can't use %s \"%s\" as operand of \"%s\"", description, + TclGetString(opndPtr), op)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL); } @@ -9366,7 +9366,8 @@ TclGetSrcInfoForPc( ExtCmdLoc *eclPtr; ECL *locPtr = NULL; - int srcOffset, i; + int srcOffset; + int i; Interp *iPtr = (Interp *) *codePtr->interpHandle; Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr); @@ -9601,7 +9602,7 @@ GetExceptRangeForPc( if (searchMode == TCL_BREAK) { return rangePtr; } - if (searchMode == TCL_CONTINUE && rangePtr->continueOffset != -1){ + if (searchMode == TCL_CONTINUE && rangePtr->continueOffset != TCL_INDEX_NONE){ return rangePtr; } } @@ -9799,8 +9800,8 @@ EvalStatsCmd( Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); Tcl_AppendPrintfToObj(objPtr, - "Compilation and execution statistics for interpreter %#" TCL_Z_MODIFIER "x\n", - (size_t)iPtr); + "Compilation and execution statistics for interpreter %p\n", + iPtr); Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%" TCL_Z_MODIFIER "u\n", statsPtr->numExecutions); @@ -9847,11 +9848,11 @@ EvalStatsCmd( statsPtr->currentByteCodeBytes); Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", currentLiteralBytes); - Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", - (unsigned long) sizeof(LiteralTable), - (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), - (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)), - (unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)), + Tcl_AppendPrintfToObj(objPtr, " table %" TCL_Z_MODIFIER "u + bkts %" TCL_Z_MODIFIER "u + entries %" TCL_Z_MODIFIER "u + objects %" TCL_Z_MODIFIER "u + strings %.6g\n", + sizeof(LiteralTable), + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), + iPtr->literalTable.numEntries * sizeof(LiteralEntry), + iPtr->literalTable.numEntries * sizeof(Tcl_Obj), statsPtr->currentLitStringBytes); Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n", currentCodeBytes / statsPtr->currentSrcBytes); diff --git a/tests/assemble.test b/tests/assemble.test index 55124d0..b656894 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -781,7 +781,7 @@ test assemble-7.43 {uplus} { } } -returnCodes error - -result {can't use non-numeric floating-point value as operand of "+"} + -result {can't use non-numeric floating-point value "NaN" as operand of "+"} } test assemble-7.43.1 {tryCvtToNumeric} { -body { diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test index b70e65c..40dea76 100644 --- a/tests/compExpr-old.test +++ b/tests/compExpr-old.test @@ -280,10 +280,10 @@ test compExpr-old-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body { } -returnCodes error -match glob -result * test compExpr-old-6.9 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {24.0^3}} msg] $msg -} {1 {can't use floating-point value as operand of "^"}} +} {1 {can't use floating-point value "24.0" as operand of "^"}} test compExpr-old-6.10 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {"a"^"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "^"}} +} {1 {can't use non-numeric string "a" as operand of "^"}} test compExpr-old-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0 test compExpr-old-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1 @@ -304,10 +304,10 @@ test compExpr-old-7.11 {CompileBitAndExpr: error compiling bitand arm} -body { } -returnCodes error -match glob -result * test compExpr-old-7.12 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {24.0&3}} msg] $msg -} {1 {can't use floating-point value as operand of "&"}} +} {1 {can't use floating-point value "24.0" as operand of "&"}} test compExpr-old-7.13 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {"a"&"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "&"}} +} {1 {can't use non-numeric string "a" as operand of "&"}} test compExpr-old-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1 test compExpr-old-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1 @@ -365,10 +365,10 @@ test compExpr-old-10.9 {CompileShiftExpr: error compiling shift arm} -body { } -returnCodes error -match glob -result * test compExpr-old-10.10 {CompileShiftExpr: runtime error} { list [catch {expr {24.0>>43}} msg] $msg -} {1 {can't use floating-point value as operand of ">>"}} +} {1 {can't use floating-point value "24.0" as operand of ">>"}} test compExpr-old-10.11 {CompileShiftExpr: runtime error} { list [catch {expr {"a"<<"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "<<"}} +} {1 {can't use non-numeric string "a" as operand of "<<"}} test compExpr-old-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8 test compExpr-old-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1 @@ -387,10 +387,10 @@ test compExpr-old-11.9 {CompileAddExpr: error compiling add arm} -body { } -returnCodes error -match glob -result * test compExpr-old-11.10 {CompileAddExpr: runtime error} { list [catch {expr {24.0+"xx"}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "xx" as operand of "+"}} test compExpr-old-11.11 {CompileAddExpr: runtime error} { list [catch {expr {"a"-"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} +} {1 {can't use non-numeric string "a" as operand of "-"}} test compExpr-old-11.12 {CompileAddExpr: runtime error} { list [catch {expr {3/0}} msg] $msg } {1 {divide by zero}} @@ -418,10 +418,10 @@ test compExpr-old-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body } -returnCodes error -match glob -result * test compExpr-old-12.10 {CompileMultiplyExpr: runtime error} { list [catch {expr {24.0*"xx"}} msg] $msg -} {1 {can't use non-numeric string as operand of "*"}} +} {1 {can't use non-numeric string "xx" as operand of "*"}} test compExpr-old-12.11 {CompileMultiplyExpr: runtime error} { list [catch {expr {"a"/"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "/"}} +} {1 {can't use non-numeric string "a" as operand of "/"}} test compExpr-old-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255 test compExpr-old-13.2 {CompileUnaryExpr: unary exprs} {expr +0o00123} 83 @@ -439,10 +439,10 @@ test compExpr-old-13.9 {CompileUnaryExpr: error compiling unary expr} -body { } -returnCodes error -match glob -result * test compExpr-old-13.10 {CompileUnaryExpr: runtime error} { list [catch {expr {~"xx"}} msg] $msg -} {1 {can't use non-numeric string as operand of "~"}} +} {1 {can't use non-numeric string "xx" as operand of "~"}} test compExpr-old-13.11 {CompileUnaryExpr: runtime error} { list [catch {expr ~4.0} msg] $msg -} {1 {can't use floating-point value as operand of "~"}} +} {1 {can't use floating-point value "4.0" as operand of "~"}} test compExpr-old-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291 test compExpr-old-13.13 {CompileUnaryExpr: just primary expr} { set a 27 @@ -590,6 +590,7 @@ test compExpr-old-15.5 {CompileMathFuncCall: not enough arguments} -body { test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body { expr sin(1 } -returnCodes error -match glob -result * + test compExpr-old-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} { catch {unset a} set a(VALUE) ff15 diff --git a/tests/execute.test b/tests/execute.test index d86ad0e..8702de6 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -179,7 +179,7 @@ test execute-3.5 {TclExecuteByteCode, INST_ADD, op1 is string double} {testobj} test execute-3.6 {TclExecuteByteCode, INST_ADD, op1 is non-numeric} {testobj} { set x [teststringobj set 0 foo] list [catch {expr {$x + 1}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "foo" as operand of "+"}} test execute-3.7 {TclExecuteByteCode, INST_ADD, op2 is int} {testobj} { set x [testintobj set 0 1] expr {1 + $x} @@ -204,7 +204,7 @@ test execute-3.11 {TclExecuteByteCode, INST_ADD, op2 is string double} {testobj} test execute-3.12 {TclExecuteByteCode, INST_ADD, op2 is non-numeric} {testobj} { set x [teststringobj set 0 foo] list [catch {expr {1 + $x}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "foo" as operand of "+"}} # INST_SUB is partially tested: test execute-3.13 {TclExecuteByteCode, INST_SUB, op1 is int} {testobj} { @@ -231,7 +231,7 @@ test execute-3.17 {TclExecuteByteCode, INST_SUB, op1 is string double} {testobj} test execute-3.18 {TclExecuteByteCode, INST_SUB, op1 is non-numeric} {testobj} { set x [teststringobj set 0 foo] list [catch {expr {$x - 1}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} +} {1 {can't use non-numeric string "foo" as operand of "-"}} test execute-3.19 {TclExecuteByteCode, INST_SUB, op2 is int} {testobj} { set x [testintobj set 0 1] expr {1 - $x} @@ -256,7 +256,7 @@ test execute-3.23 {TclExecuteByteCode, INST_SUB, op2 is string double} {testobj} test execute-3.24 {TclExecuteByteCode, INST_SUB, op2 is non-numeric} {testobj} { set x [teststringobj set 0 foo] list [catch {expr {1 - $x}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} +} {1 {can't use non-numeric string "foo" as operand of "-"}} # INST_MULT is partially tested: test execute-3.25 {TclExecuteByteCode, INST_MULT, op1 is int} {testobj} { @@ -283,7 +283,7 @@ test execute-3.29 {TclExecuteByteCode, INST_MULT, op1 is string double} {testobj test execute-3.30 {TclExecuteByteCode, INST_MULT, op1 is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {$x * 1}} msg] $msg -} {1 {can't use non-numeric string as operand of "*"}} +} {1 {can't use non-numeric string "foo" as operand of "*"}} test execute-3.31 {TclExecuteByteCode, INST_MULT, op2 is int} {testobj} { set x [testintobj set 1 1] expr {1 * $x} @@ -308,7 +308,7 @@ test execute-3.35 {TclExecuteByteCode, INST_MULT, op2 is string double} {testobj test execute-3.36 {TclExecuteByteCode, INST_MULT, op2 is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {1 * $x}} msg] $msg -} {1 {can't use non-numeric string as operand of "*"}} +} {1 {can't use non-numeric string "foo" as operand of "*"}} # INST_DIV is partially tested: test execute-3.37 {TclExecuteByteCode, INST_DIV, op1 is int} {testobj} { @@ -335,7 +335,7 @@ test execute-3.41 {TclExecuteByteCode, INST_DIV, op1 is string double} {testobj} test execute-3.42 {TclExecuteByteCode, INST_DIV, op1 is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {$x / 1}} msg] $msg -} {1 {can't use non-numeric string as operand of "/"}} +} {1 {can't use non-numeric string "foo" as operand of "/"}} test execute-3.43 {TclExecuteByteCode, INST_DIV, op2 is int} {testobj} { set x [testintobj set 1 1] expr {2 / $x} @@ -360,7 +360,7 @@ test execute-3.47 {TclExecuteByteCode, INST_DIV, op2 is string double} {testobj} test execute-3.48 {TclExecuteByteCode, INST_DIV, op2 is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {1 / $x}} msg] $msg -} {1 {can't use non-numeric string as operand of "/"}} +} {1 {can't use non-numeric string "foo" as operand of "/"}} # INST_UPLUS is partially tested: test execute-3.49 {TclExecuteByteCode, INST_UPLUS, op is int} {testobj} { @@ -387,7 +387,7 @@ test execute-3.53 {TclExecuteByteCode, INST_UPLUS, op is string double} {testobj test execute-3.54 {TclExecuteByteCode, INST_UPLUS, op is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {+ $x}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "foo" as operand of "+"}} # INST_UMINUS is partially tested: test execute-3.55 {TclExecuteByteCode, INST_UMINUS, op is int} {testobj} { @@ -414,7 +414,7 @@ test execute-3.59 {TclExecuteByteCode, INST_UMINUS, op is string double} {testob test execute-3.60 {TclExecuteByteCode, INST_UMINUS, op is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {- $x}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} +} {1 {can't use non-numeric string "foo" as operand of "-"}} # INST_LNOT is partially tested: test execute-3.61 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} { @@ -462,7 +462,7 @@ test execute-3.70 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj} test execute-3.71 {TclExecuteByteCode, INST_LNOT, op is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {! $x}} msg] $msg -} {1 {can't use non-numeric string as operand of "!"}} +} {1 {can't use non-numeric string "foo" as operand of "!"}} # INST_BITNOT not tested # INST_CALL_BUILTIN_FUNC1 not tested diff --git a/tests/expr-old.test b/tests/expr-old.test index 676443a..2401bd4 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -194,34 +194,34 @@ test expr-old-2.38 {floating-point operators} { test expr-old-3.1 {illegal floating-point operations} { list [catch {expr ~4.0} msg] $msg -} {1 {can't use floating-point value as operand of "~"}} +} {1 {can't use floating-point value "4.0" as operand of "~"}} test expr-old-3.2 {illegal floating-point operations} { list [catch {expr 27%4.0} msg] $msg -} {1 {can't use floating-point value as operand of "%"}} +} {1 {can't use floating-point value "4.0" as operand of "%"}} test expr-old-3.3 {illegal floating-point operations} { list [catch {expr 27.0%4} msg] $msg -} {1 {can't use floating-point value as operand of "%"}} +} {1 {can't use floating-point value "27.0" as operand of "%"}} test expr-old-3.4 {illegal floating-point operations} { list [catch {expr 1.0<<3} msg] $msg -} {1 {can't use floating-point value as operand of "<<"}} +} {1 {can't use floating-point value "1.0" as operand of "<<"}} test expr-old-3.5 {illegal floating-point operations} { list [catch {expr 3<<1.0} msg] $msg -} {1 {can't use floating-point value as operand of "<<"}} +} {1 {can't use floating-point value "1.0" as operand of "<<"}} test expr-old-3.6 {illegal floating-point operations} { list [catch {expr 24.0>>3} msg] $msg -} {1 {can't use floating-point value as operand of ">>"}} +} {1 {can't use floating-point value "24.0" as operand of ">>"}} test expr-old-3.7 {illegal floating-point operations} { list [catch {expr 24>>3.0} msg] $msg -} {1 {can't use floating-point value as operand of ">>"}} +} {1 {can't use floating-point value "3.0" as operand of ">>"}} test expr-old-3.8 {illegal floating-point operations} { list [catch {expr 24&3.0} msg] $msg -} {1 {can't use floating-point value as operand of "&"}} +} {1 {can't use floating-point value "3.0" as operand of "&"}} test expr-old-3.9 {illegal floating-point operations} { list [catch {expr 24.0|3} msg] $msg -} {1 {can't use floating-point value as operand of "|"}} +} {1 {can't use floating-point value "24.0" as operand of "|"}} test expr-old-3.10 {illegal floating-point operations} { list [catch {expr 24.0^3} msg] $msg -} {1 {can't use floating-point value as operand of "^"}} +} {1 {can't use floating-point value "24.0" as operand of "^"}} # Check the string operators individually. @@ -262,46 +262,46 @@ test expr-old-4.32 {string operators} {expr {0?"foo":"bar"}} bar test expr-old-5.1 {illegal string operations} { list [catch {expr {-"a"}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} +} {1 {can't use non-numeric string "a" as operand of "-"}} test expr-old-5.2 {illegal string operations} { list [catch {expr {+"a"}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "a" as operand of "+"}} test expr-old-5.3 {illegal string operations} { list [catch {expr {~"a"}} msg] $msg -} {1 {can't use non-numeric string as operand of "~"}} +} {1 {can't use non-numeric string "a" as operand of "~"}} test expr-old-5.4 {illegal string operations} { list [catch {expr {!"a"}} msg] $msg -} {1 {can't use non-numeric string as operand of "!"}} +} {1 {can't use non-numeric string "a" as operand of "!"}} test expr-old-5.5 {illegal string operations} { list [catch {expr {"a"*"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "*"}} +} {1 {can't use non-numeric string "a" as operand of "*"}} test expr-old-5.6 {illegal string operations} { list [catch {expr {"a"/"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "/"}} +} {1 {can't use non-numeric string "a" as operand of "/"}} test expr-old-5.7 {illegal string operations} { list [catch {expr {"a"%"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "%"}} +} {1 {can't use non-numeric string "a" as operand of "%"}} test expr-old-5.8 {illegal string operations} { list [catch {expr {"a"+"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "a" as operand of "+"}} test expr-old-5.9 {illegal string operations} { list [catch {expr {"a"-"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} +} {1 {can't use non-numeric string "a" as operand of "-"}} test expr-old-5.10 {illegal string operations} { list [catch {expr {"a"<<"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "<<"}} +} {1 {can't use non-numeric string "a" as operand of "<<"}} test expr-old-5.11 {illegal string operations} { list [catch {expr {"a">>"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of ">>"}} +} {1 {can't use non-numeric string "a" as operand of ">>"}} test expr-old-5.12 {illegal string operations} { list [catch {expr {"a"&"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "&"}} +} {1 {can't use non-numeric string "a" as operand of "&"}} test expr-old-5.13 {illegal string operations} { list [catch {expr {"a"^"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "^"}} +} {1 {can't use non-numeric string "a" as operand of "^"}} test expr-old-5.14 {illegal string operations} { list [catch {expr {"a"|"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "|"}} +} {1 {can't use non-numeric string "a" as operand of "|"}} test expr-old-5.15 {illegal string operations} { list [catch {expr {"a"&&"b"}} msg] $msg } {1 {expected boolean value but got "a"}} @@ -490,7 +490,7 @@ test expr-old-25.20 {type conversions} {expr 10.0} 10.0 test expr-old-26.1 {error conditions} { list [catch {expr 2+"a"} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "a" as operand of "+"}} test expr-old-26.2 {error conditions} -body { expr 2+4* } -returnCodes error -match glob -result * @@ -504,10 +504,10 @@ test expr-old-26.4 {error conditions} { set a xx test expr-old-26.5 {error conditions} { list [catch {expr {2+$a}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "xx" as operand of "+"}} test expr-old-26.6 {error conditions} { list [catch {expr {2+[set a]}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "xx" as operand of "+"}} test expr-old-26.7 {error conditions} -body { expr {2+(4} } -returnCodes error -match glob -result * @@ -531,7 +531,7 @@ test expr-old-26.12 {error conditions} -body { } -returnCodes error -match glob -result * test expr-old-26.13 {error conditions} { list [catch {expr {"a"/"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "/"}} +} {1 {can't use non-numeric string "a" as operand of "/"}} test expr-old-26.14 {error conditions} -body { expr 2:3 } -returnCodes error -match glob -result * @@ -943,13 +943,14 @@ test expr-old-34.15 {errors in math functions} { test expr-old-34.16 {errors in math functions} { expr round(-1.0e30) } -1000000000000000019884624838656 + test expr-old-36.1 {ExprLooksLikeInt procedure} -body { expr 0o289 } -returnCodes error -match glob -result {*invalid octal number*} test expr-old-36.2 {ExprLooksLikeInt procedure} { set x 0o289 list [catch {expr {$x+1}} msg] $msg -} {1 {can't use invalid octal number as operand of "+"}} +} {1 {can't use invalid octal number "0o289" as operand of "+"}} test expr-old-36.3 {ExprLooksLikeInt procedure} { list [catch {expr 0289.1} msg] $msg } {0 289.1} @@ -989,11 +990,11 @@ test expr-old-36.11 {ExprLooksLikeInt procedure} { test expr-old-36.12 {ExprLooksLikeInt procedure} { set x "10;" list [catch {expr {$x+1}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "10;" as operand of "+"}} test expr-old-36.13 {ExprLooksLikeInt procedure} { set x " +" list [catch {expr {$x+1}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string " +" as operand of "+"}} test expr-old-36.14 {ExprLooksLikeInt procedure} { set x "123456789012345678901234567890 " expr {$x+1} @@ -1001,7 +1002,7 @@ test expr-old-36.14 {ExprLooksLikeInt procedure} { test expr-old-36.15 {ExprLooksLikeInt procedure} { set x "0o99 " list [catch {expr {$x+1}} msg] $msg -} {1 {can't use invalid octal number as operand of "+"}} +} {1 {can't use invalid octal number "0o99 " as operand of "+"}} test expr-old-36.16 {ExprLooksLikeInt procedure} { set x " 0xffffffffffffffffffffffffffffffffffffff " expr {$x+1} diff --git a/tests/expr.test b/tests/expr.test index 32706d9..25a02e3 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -138,9 +138,9 @@ proc do_twelve_days {} { catch {unset a b i x} -test expr-1.1 {TclCompileExprCmd: no expression} { - list [catch {expr } msg] $msg -} {1 {wrong # args: should be "expr arg ?arg ...?"}} +test expr-1.1 {TclCompileExprCmd: no expression} -body { + expr +} -returnCodes error -result {wrong # args: should be "expr arg ?arg ...?"} test expr-1.2 {TclCompileExprCmd: one expression word} { expr -25 } -25 @@ -187,12 +187,12 @@ test expr-1.13 {TclCompileExprCmd: second level of substitutions in expr not in } foo test expr-1.14 {TclCompileExprCmd: second level of substitutions in expr with comparison as top-level operator} { set a xxx - set x 2; set b {$x}; set a [expr $b == 2] + set x 2; set b {$x}; set a [expr $b==2] set a } 1 test expr-1.15 {TclCompileExprCmd: second level of substitutions in expr with comparison as top-level operator} { set a xxx - set x 2; set b {$x}; set a [expr $b eq 2] + set x 2; set b {$x}; set a [expr "$b eq 2"] set a } 1 @@ -252,7 +252,7 @@ test expr-4.9 {CompileLorExpr: long lor arm} { } 1 test expr-4.10 {CompileLorExpr: error compiling ! operand} { list [catch {expr {!"a"}} msg] $msg -} {1 {can't use non-numeric string as operand of "!"}} +} {1 {can't use non-numeric string "a" as operand of "!"}} test expr-4.11 {CompileLorExpr: error compiling land arms} { list [catch {expr {"a"||0}} msg] $msg } {1 {expected boolean value but got "a"}} @@ -299,10 +299,10 @@ test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body { } -returnCodes error -match glob -result * test expr-6.9 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {24.0^3}} msg] $msg -} {1 {can't use floating-point value as operand of "^"}} +} {1 {can't use floating-point value "24.0" as operand of "^"}} test expr-6.10 {CompileBitXorExpr: runtime error in bitxor arm} { list [catch {expr {"a"^"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "^"}} +} {1 {can't use non-numeric string "a" as operand of "^"}} test expr-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0 test expr-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1 @@ -323,10 +323,10 @@ test expr-7.11 {CompileBitAndExpr: error compiling bitand arm} -body { } -returnCodes error -match glob -result * test expr-7.12 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {24.0&3}} msg] $msg -} {1 {can't use floating-point value as operand of "&"}} +} {1 {can't use floating-point value "24.0" as operand of "&"}} test expr-7.13 {CompileBitAndExpr: runtime error in bitand arm} { list [catch {expr {"a"&"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "&"}} +} {1 {can't use non-numeric string "a" as operand of "&"}} test expr-7.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0 test expr-7.18 {CompileBitAndExpr: equality expr} {expr {"abc" eq "abd"}} 0 test expr-7.20 {CompileBitAndExpr: error in equality expr} -body { @@ -468,10 +468,10 @@ test expr-10.9 {CompileShiftExpr: error compiling shift arm} -body { } -returnCodes error -match glob -result * test expr-10.10 {CompileShiftExpr: runtime error} { list [catch {expr {24.0>>43}} msg] $msg -} {1 {can't use floating-point value as operand of ">>"}} +} {1 {can't use floating-point value "24.0" as operand of ">>"}} test expr-10.11 {CompileShiftExpr: runtime error} { list [catch {expr {"a"<<"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "<<"}} +} {1 {can't use non-numeric string "a" as operand of "<<"}} test expr-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8 test expr-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1 @@ -490,10 +490,10 @@ test expr-11.9 {CompileAddExpr: error compiling add arm} -body { } -returnCodes error -match glob -result * test expr-11.10 {CompileAddExpr: runtime error} { list [catch {expr {24.0+"xx"}} msg] $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "xx" as operand of "+"}} test expr-11.11 {CompileAddExpr: runtime error} { list [catch {expr {"a"-"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "-"}} +} {1 {can't use non-numeric string "a" as operand of "-"}} test expr-11.12 {CompileAddExpr: runtime error} { list [catch {expr {3/0}} msg] $msg } {1 {divide by zero}} @@ -521,10 +521,10 @@ test expr-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body { } -returnCodes error -match glob -result * test expr-12.10 {CompileMultiplyExpr: runtime error} { list [catch {expr {24.0*"xx"}} msg] $msg -} {1 {can't use non-numeric string as operand of "*"}} +} {1 {can't use non-numeric string "xx" as operand of "*"}} test expr-12.11 {CompileMultiplyExpr: runtime error} { list [catch {expr {"a"/"b"}} msg] $msg -} {1 {can't use non-numeric string as operand of "/"}} +} {1 {can't use non-numeric string "a" as operand of "/"}} test expr-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255 test expr-13.2 {CompileUnaryExpr: unary exprs} {expr +0o00123} 83 @@ -541,10 +541,10 @@ test expr-13.9 {CompileUnaryExpr: error compiling unary expr} -body { } -returnCodes error -match glob -result * test expr-13.10 {CompileUnaryExpr: runtime error} { list [catch {expr {~"xx"}} msg] $msg -} {1 {can't use non-numeric string as operand of "~"}} +} {1 {can't use non-numeric string "xx" as operand of "~"}} test expr-13.11 {CompileUnaryExpr: runtime error} { list [catch {expr ~4.0} msg] $msg -} {1 {can't use floating-point value as operand of "~"}} +} {1 {can't use floating-point value "4.0" as operand of "~"}} test expr-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291 test expr-13.13 {CompileUnaryExpr: just primary expr} { set a 27 @@ -821,15 +821,15 @@ test expr-21.13 {non-numeric boolean literals} -body { } -returnCodes error -match glob -result * test expr-21.14 {non-numeric boolean literals} { list [catch {expr !"truef"} err] $err -} {1 {can't use non-numeric string as operand of "!"}} +} {1 {can't use non-numeric string "truef" as operand of "!"}} test expr-21.15 {non-numeric boolean variables} { set v truef list [catch {expr {!$v}} err] $err -} {1 {can't use non-numeric string as operand of "!"}} +} {1 {can't use non-numeric string "truef" as operand of "!"}} test expr-21.16 {non-numeric boolean variables} { set v "true " list [catch {expr {!$v}} err] $err -} {1 {can't use non-numeric string as operand of "!"}} +} {1 {can't use non-numeric string "true " as operand of "!"}} test expr-21.17 {non-numeric boolean variables} { set v "tru" list [catch {expr {!$v}} err] $err @@ -849,23 +849,23 @@ test expr-21.20 {non-numeric boolean variables} { test expr-21.21 {non-numeric boolean variables} { set v "o" list [catch {expr {!$v}} err] $err -} {1 {can't use non-numeric string as operand of "!"}} +} {1 {can't use non-numeric string "o" as operand of "!"}} test expr-21.22 {non-numeric boolean variables} { set v "" list [catch {expr {!$v}} err] $err -} {1 {can't use empty string as operand of "!"}} +} {1 {can't use empty string "" as operand of "!"}} # Test for non-numeric float handling. test expr-22.1 {non-numeric floats} { list [catch {expr {NaN + 1}} msg] $msg -} {1 {can't use non-numeric floating-point value as operand of "+"}} +} {1 {can't use non-numeric floating-point value "NaN" as operand of "+"}} test expr-22.2 {non-numeric floats} !ieeeFloatingPoint { list [catch {expr {Inf + 1}} msg] $msg } {1 {can't use infinite floating-point value as operand of "+"}} test expr-22.3 {non-numeric floats} { set nan NaN list [catch {expr {$nan + 1}} msg] $msg -} {1 {can't use non-numeric floating-point value as operand of "+"}} +} {1 {can't use non-numeric floating-point value "NaN" as operand of "+"}} test expr-22.4 {non-numeric floats} !ieeeFloatingPoint { set inf Inf list [catch {expr {$inf + 1}} msg] $msg @@ -878,7 +878,7 @@ test expr-22.6 {non-numeric floats} !ieeeFloatingPoint { } {1 {floating-point value too large to represent}} test expr-22.7 {non-numeric floats} { list [catch {expr {1 / NaN}} msg] $msg -} {1 {can't use non-numeric floating-point value as operand of "/"}} +} {1 {can't use non-numeric floating-point value "NaN" as operand of "/"}} test expr-22.8 {non-numeric floats} !ieeeFloatingPoint { list [catch {expr {1 / Inf}} msg] $msg } {1 {can't use infinite floating-point value as operand of "/"}} @@ -914,10 +914,10 @@ test expr-23.8 {CompileExponentialExpr: error compiling expo arm} -body { } -returnCodes error -match glob -result * test expr-23.9 {CompileExponentialExpr: runtime error} { list [catch {expr {24.0**"xx"}} msg] $msg -} {1 {can't use non-numeric string as operand of "**"}} +} {1 {can't use non-numeric string "xx" as operand of "**"}} test expr-23.10 {CompileExponentialExpr: runtime error} { list [catch {expr {"a"**2}} msg] $msg -} {1 {can't use non-numeric string as operand of "**"}} +} {1 {can't use non-numeric string "a" as operand of "**"}} test expr-23.11 {CompileExponentialExpr: runtime error} { list [catch {expr {0**-1}} msg] $msg } {1 {exponentiation of zero by negative power}} diff --git a/tests/mathop.test b/tests/mathop.test index e38001d..13a0543 100644 --- a/tests/mathop.test +++ b/tests/mathop.test @@ -114,22 +114,22 @@ namespace eval ::testmathop { test mathop-1.10 {compiled +} { + 1 2 3000000000000000000000 } 3000000000000000000003 test mathop-1.11 {compiled +: errors} -returnCodes error -body { + x 0 - } -result {can't use non-numeric string as operand of "+"} + } -result {can't use non-numeric string "x" as operand of "+"} test mathop-1.12 {compiled +: errors} -returnCodes error -body { + nan 0 - } -result {can't use non-numeric floating-point value as operand of "+"} + } -result {can't use non-numeric floating-point value "nan" as operand of "+"} test mathop-1.13 {compiled +: errors} -returnCodes error -body { + 0 x - } -result {can't use non-numeric string as operand of "+"} + } -result {can't use non-numeric string "x" as operand of "+"} test mathop-1.14 {compiled +: errors} -returnCodes error -body { + 0 nan - } -result {can't use non-numeric floating-point value as operand of "+"} + } -result {can't use non-numeric floating-point value "nan" as operand of "+"} test mathop-1.15 {compiled +: errors} -returnCodes error -body { + 0o8 0 - } -result {can't use invalid octal number as operand of "+"} + } -result {can't use invalid octal number "0o8" as operand of "+"} test mathop-1.16 {compiled +: errors} -returnCodes error -body { + 0 0o8 - } -result {can't use invalid octal number as operand of "+"} + } -result {can't use invalid octal number "0o8" as operand of "+"} test mathop-1.17 {compiled +: errors} -returnCodes error -body { + 0 [error expectedError] } -result expectedError @@ -152,22 +152,22 @@ namespace eval ::testmathop { test mathop-1.28 {interpreted +} { $op 1 2 3000000000000000000000 } 3000000000000000000003 test mathop-1.29 {interpreted +: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string as operand of "+"} + } -result {can't use non-numeric string "x" as operand of "+"} test mathop-1.30 {interpreted +: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value as operand of "+"} + } -result {can't use non-numeric floating-point value "nan" as operand of "+"} test mathop-1.31 {interpreted +: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string as operand of "+"} + } -result {can't use non-numeric string "x" as operand of "+"} test mathop-1.32 {interpreted +: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value as operand of "+"} + } -result {can't use non-numeric floating-point value "nan" as operand of "+"} test mathop-1.33 {interpreted +: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number as operand of "+"} + } -result {can't use invalid octal number "0o8" as operand of "+"} test mathop-1.34 {interpreted +: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number as operand of "+"} + } -result {can't use invalid octal number "0o8" as operand of "+"} test mathop-1.35 {interpreted +: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -189,22 +189,22 @@ namespace eval ::testmathop { test mathop-2.10 {compiled *} { * 1 2 3000000000000000000000 } 6000000000000000000000 test mathop-2.11 {compiled *: errors} -returnCodes error -body { * x 0 - } -result {can't use non-numeric string as operand of "*"} + } -result {can't use non-numeric string "x" as operand of "*"} test mathop-2.12 {compiled *: errors} -returnCodes error -body { * nan 0 - } -result {can't use non-numeric floating-point value as operand of "*"} + } -result {can't use non-numeric floating-point value "nan" as operand of "*"} test mathop-2.13 {compiled *: errors} -returnCodes error -body { * 0 x - } -result {can't use non-numeric string as operand of "*"} + } -result {can't use non-numeric string "x" as operand of "*"} test mathop-2.14 {compiled *: errors} -returnCodes error -body { * 0 nan - } -result {can't use non-numeric floating-point value as operand of "*"} + } -result {can't use non-numeric floating-point value "nan" as operand of "*"} test mathop-2.15 {compiled *: errors} -returnCodes error -body { * 0o8 0 - } -result {can't use invalid octal number as operand of "*"} + } -result {can't use invalid octal number "0o8" as operand of "*"} test mathop-2.16 {compiled *: errors} -returnCodes error -body { * 0 0o8 - } -result {can't use invalid octal number as operand of "*"} + } -result {can't use invalid octal number "0o8" as operand of "*"} test mathop-2.17 {compiled *: errors} -returnCodes error -body { * 0 [error expectedError] } -result expectedError @@ -227,22 +227,22 @@ namespace eval ::testmathop { test mathop-2.28 {interpreted *} { $op 1 2 3000000000000000000000 } 6000000000000000000000 test mathop-2.29 {interpreted *: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string as operand of "*"} + } -result {can't use non-numeric string "x" as operand of "*"} test mathop-2.30 {interpreted *: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value as operand of "*"} + } -result {can't use non-numeric floating-point value "nan" as operand of "*"} test mathop-2.31 {interpreted *: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string as operand of "*"} + } -result {can't use non-numeric string "x" as operand of "*"} test mathop-2.32 {interpreted *: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value as operand of "*"} + } -result {can't use non-numeric floating-point value "nan" as operand of "*"} test mathop-2.33 {interpreted *: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number as operand of "*"} + } -result {can't use invalid octal number "0o8" as operand of "*"} test mathop-2.34 {interpreted *: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number as operand of "*"} + } -result {can't use invalid octal number "0o8" as operand of "*"} test mathop-2.35 {interpreted *: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -261,7 +261,7 @@ namespace eval ::testmathop { test mathop-3.7 {compiled !} {! 10000000000000000000000000} 0 test mathop-3.8 {compiled !: errors} -body { ! foobar - } -returnCodes error -result {can't use non-numeric string as operand of "!"} + } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "!"} test mathop-3.9 {compiled !: errors} -body { ! 0 0 } -returnCodes error -result "wrong # args: should be \"! boolean\"" @@ -278,7 +278,7 @@ namespace eval ::testmathop { test mathop-3.17 {interpreted !} {$op 10000000000000000000000000} 0 test mathop-3.18 {interpreted !: errors} -body { $op foobar - } -returnCodes error -result {can't use non-numeric string as operand of "!"} + } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "!"} test mathop-3.19 {interpreted !: errors} -body { $op 0 0 } -returnCodes error -result "wrong # args: should be \"! boolean\"" @@ -287,10 +287,10 @@ namespace eval ::testmathop { } -returnCodes error -result "wrong # args: should be \"! boolean\"" test mathop-3.21 {compiled !: error} -returnCodes error -body { ! NaN - } -result {can't use non-numeric floating-point value as operand of "!"} + } -result {can't use non-numeric floating-point value "NaN" as operand of "!"} test mathop-3.22 {interpreted !: error} -returnCodes error -body { $op NaN - } -result {can't use non-numeric floating-point value as operand of "!"} + } -result {can't use non-numeric floating-point value "NaN" as operand of "!"} test mathop-4.1 {compiled ~} {~ 0} -1 test mathop-4.2 {compiled ~} {~ 1} -2 @@ -301,7 +301,7 @@ namespace eval ::testmathop { test mathop-4.7 {compiled ~} {~ 10000000000000000000000000} -10000000000000000000000001 test mathop-4.8 {compiled ~: errors} -body { ~ foobar - } -returnCodes error -result {can't use non-numeric string as operand of "~"} + } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "~"} test mathop-4.9 {compiled ~: errors} -body { ~ 0 0 } -returnCodes error -result "wrong # args: should be \"~ integer\"" @@ -310,10 +310,10 @@ namespace eval ::testmathop { } -returnCodes error -result "wrong # args: should be \"~ integer\"" test mathop-4.11 {compiled ~: errors} -returnCodes error -body { ~ 0.0 - } -result {can't use floating-point value as operand of "~"} + } -result {can't use floating-point value "0.0" as operand of "~"} test mathop-4.12 {compiled ~: errors} -returnCodes error -body { ~ NaN - } -result {can't use non-numeric floating-point value as operand of "~"} + } -result {can't use non-numeric floating-point value "NaN" as operand of "~"} set op ~ test mathop-4.13 {interpreted ~} {$op 0} -1 test mathop-4.14 {interpreted ~} {$op 1} -2 @@ -324,7 +324,7 @@ namespace eval ::testmathop { test mathop-4.19 {interpreted ~} {$op 10000000000000000000000000} -10000000000000000000000001 test mathop-4.20 {interpreted ~: errors} -body { $op foobar - } -returnCodes error -result {can't use non-numeric string as operand of "~"} + } -returnCodes error -result {can't use non-numeric string "foobar" as operand of "~"} test mathop-4.21 {interpreted ~: errors} -body { $op 0 0 } -returnCodes error -result "wrong # args: should be \"~ integer\"" @@ -333,10 +333,10 @@ namespace eval ::testmathop { } -returnCodes error -result "wrong # args: should be \"~ integer\"" test mathop-4.23 {interpreted ~: errors} -returnCodes error -body { $op 0.0 - } -result {can't use floating-point value as operand of "~"} + } -result {can't use floating-point value "0.0" as operand of "~"} test mathop-4.24 {interpreted ~: errors} -returnCodes error -body { $op NaN - } -result {can't use non-numeric floating-point value as operand of "~"} + } -result {can't use non-numeric floating-point value "NaN" as operand of "~"} test mathop-5.1 {compiled eq} {eq {} a} 0 test mathop-5.2 {compiled eq} {eq a a} 1 @@ -377,32 +377,32 @@ namespace eval ::testmathop { test mathop-6.4 {compiled &} { & 3 7 6 } 2 test mathop-6.5 {compiled &} -returnCodes error -body { & 1.0 2 3 - } -result {can't use floating-point value as operand of "&"} + } -result {can't use floating-point value "1.0" as operand of "&"} test mathop-6.6 {compiled &} -returnCodes error -body { & 1 2 3.0 - } -result {can't use floating-point value as operand of "&"} + } -result {can't use floating-point value "3.0" as operand of "&"} test mathop-6.7 {compiled &} { & 100000000002 18 -126 } 2 test mathop-6.8 {compiled &} { & 0xff 0o377 333333333333 } 85 test mathop-6.9 {compiled &} { & 1000000000000000000002 18 -126 } 2 test mathop-6.10 {compiled &} { & 0xff 0o377 3333333333333333333333 } 85 test mathop-6.11 {compiled &: errors} -returnCodes error -body { & x 0 - } -result {can't use non-numeric string as operand of "&"} + } -result {can't use non-numeric string "x" as operand of "&"} test mathop-6.12 {compiled &: errors} -returnCodes error -body { & nan 0 - } -result {can't use non-numeric floating-point value as operand of "&"} + } -result {can't use non-numeric floating-point value "nan" as operand of "&"} test mathop-6.13 {compiled &: errors} -returnCodes error -body { & 0 x - } -result {can't use non-numeric string as operand of "&"} + } -result {can't use non-numeric string "x" as operand of "&"} test mathop-6.14 {compiled &: errors} -returnCodes error -body { & 0 nan - } -result {can't use non-numeric floating-point value as operand of "&"} + } -result {can't use non-numeric floating-point value "nan" as operand of "&"} test mathop-6.15 {compiled &: errors} -returnCodes error -body { & 0o8 0 - } -result {can't use invalid octal number as operand of "&"} + } -result {can't use invalid octal number "0o8" as operand of "&"} test mathop-6.16 {compiled &: errors} -returnCodes error -body { & 0 0o8 - } -result {can't use invalid octal number as operand of "&"} + } -result {can't use invalid octal number "0o8" as operand of "&"} test mathop-6.17 {compiled &: errors} -returnCodes error -body { & 0 [error expectedError] } -result expectedError @@ -419,32 +419,32 @@ namespace eval ::testmathop { test mathop-6.22 {interpreted &} { $op 3 7 6 } 2 test mathop-6.23 {interpreted &} -returnCodes error -body { $op 1.0 2 3 - } -result {can't use floating-point value as operand of "&"} + } -result {can't use floating-point value "1.0" as operand of "&"} test mathop-6.24 {interpreted &} -returnCodes error -body { $op 1 2 3.0 - } -result {can't use floating-point value as operand of "&"} + } -result {can't use floating-point value "3.0" as operand of "&"} test mathop-6.25 {interpreted &} { $op 100000000002 18 -126 } 2 test mathop-6.26 {interpreted &} { $op 0xff 0o377 333333333333 } 85 test mathop-6.27 {interpreted &} { $op 1000000000000000000002 18 -126 } 2 test mathop-6.28 {interpreted &} { $op 0xff 0o377 3333333333333333333333 } 85 test mathop-6.29 {interpreted &: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string as operand of "&"} + } -result {can't use non-numeric string "x" as operand of "&"} test mathop-6.30 {interpreted &: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value as operand of "&"} + } -result {can't use non-numeric floating-point value "nan" as operand of "&"} test mathop-6.31 {interpreted &: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string as operand of "&"} + } -result {can't use non-numeric string "x" as operand of "&"} test mathop-6.32 {interpreted &: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value as operand of "&"} + } -result {can't use non-numeric floating-point value "nan" as operand of "&"} test mathop-6.33 {interpreted &: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number as operand of "&"} + } -result {can't use invalid octal number "0o8" as operand of "&"} test mathop-6.34 {interpreted &: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number as operand of "&"} + } -result {can't use invalid octal number "0o8" as operand of "&"} test mathop-6.35 {interpreted &: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -487,32 +487,32 @@ namespace eval ::testmathop { test mathop-7.4 {compiled |} { | 3 7 6 } 7 test mathop-7.5 {compiled |} -returnCodes error -body { | 1.0 2 3 - } -result {can't use floating-point value as operand of "|"} + } -result {can't use floating-point value "1.0" as operand of "|"} test mathop-7.6 {compiled |} -returnCodes error -body { | 1 2 3.0 - } -result {can't use floating-point value as operand of "|"} + } -result {can't use floating-point value "3.0" as operand of "|"} test mathop-7.7 {compiled |} { | 100000000002 18 -126 } -110 test mathop-7.8 {compiled |} { | 0xff 0o377 333333333333 } 333333333503 test mathop-7.9 {compiled |} { | 1000000000000000000002 18 -126 } -110 test mathop-7.10 {compiled |} { | 0xff 0o377 3333333333333333333333 } 3333333333333333333503 test mathop-7.11 {compiled |: errors} -returnCodes error -body { | x 0 - } -result {can't use non-numeric string as operand of "|"} + } -result {can't use non-numeric string "x" as operand of "|"} test mathop-7.12 {compiled |: errors} -returnCodes error -body { | nan 0 - } -result {can't use non-numeric floating-point value as operand of "|"} + } -result {can't use non-numeric floating-point value "nan" as operand of "|"} test mathop-7.13 {compiled |: errors} -returnCodes error -body { | 0 x - } -result {can't use non-numeric string as operand of "|"} + } -result {can't use non-numeric string "x" as operand of "|"} test mathop-7.14 {compiled |: errors} -returnCodes error -body { | 0 nan - } -result {can't use non-numeric floating-point value as operand of "|"} + } -result {can't use non-numeric floating-point value "nan" as operand of "|"} test mathop-7.15 {compiled |: errors} -returnCodes error -body { | 0o8 0 - } -result {can't use invalid octal number as operand of "|"} + } -result {can't use invalid octal number "0o8" as operand of "|"} test mathop-7.16 {compiled |: errors} -returnCodes error -body { | 0 0o8 - } -result {can't use invalid octal number as operand of "|"} + } -result {can't use invalid octal number "0o8" as operand of "|"} test mathop-7.17 {compiled |: errors} -returnCodes error -body { | 0 [error expectedError] } -result expectedError @@ -529,32 +529,32 @@ namespace eval ::testmathop { test mathop-7.22 {interpreted |} { $op 3 7 6 } 7 test mathop-7.23 {interpreted |} -returnCodes error -body { $op 1.0 2 3 - } -result {can't use floating-point value as operand of "|"} + } -result {can't use floating-point value "1.0" as operand of "|"} test mathop-7.24 {interpreted |} -returnCodes error -body { $op 1 2 3.0 - } -result {can't use floating-point value as operand of "|"} + } -result {can't use floating-point value "3.0" as operand of "|"} test mathop-7.25 {interpreted |} { $op 100000000002 18 -126 } -110 test mathop-7.26 {interpreted |} { $op 0xff 0o377 333333333333 } 333333333503 test mathop-7.27 {interpreted |} { $op 1000000000000000000002 18 -126 } -110 test mathop-7.28 {interpreted |} { $op 0xff 0o377 3333333333333333333333 } 3333333333333333333503 test mathop-7.29 {interpreted |: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string as operand of "|"} + } -result {can't use non-numeric string "x" as operand of "|"} test mathop-7.30 {interpreted |: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value as operand of "|"} + } -result {can't use non-numeric floating-point value "nan" as operand of "|"} test mathop-7.31 {interpreted |: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string as operand of "|"} + } -result {can't use non-numeric string "x" as operand of "|"} test mathop-7.32 {interpreted |: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value as operand of "|"} + } -result {can't use non-numeric floating-point value "nan" as operand of "|"} test mathop-7.33 {interpreted |: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number as operand of "|"} + } -result {can't use invalid octal number "0o8" as operand of "|"} test mathop-7.34 {interpreted |: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number as operand of "|"} + } -result {can't use invalid octal number "0o8" as operand of "|"} test mathop-7.35 {interpreted |: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -597,32 +597,32 @@ namespace eval ::testmathop { test mathop-8.4 {compiled ^} { ^ 3 7 6 } 2 test mathop-8.5 {compiled ^} -returnCodes error -body { ^ 1.0 2 3 - } -result {can't use floating-point value as operand of "^"} + } -result {can't use floating-point value "1.0" as operand of "^"} test mathop-8.6 {compiled ^} -returnCodes error -body { ^ 1 2 3.0 - } -result {can't use floating-point value as operand of "^"} + } -result {can't use floating-point value "3.0" as operand of "^"} test mathop-8.7 {compiled ^} { ^ 100000000002 18 -126 } -100000000110 test mathop-8.8 {compiled ^} { ^ 0xff 0o377 333333333333 } 333333333333 test mathop-8.9 {compiled ^} { ^ 1000000000000000000002 18 -126 } -1000000000000000000110 test mathop-8.10 {compiled ^} { ^ 0xff 0o377 3333333333333333333333 } 3333333333333333333333 test mathop-8.11 {compiled ^: errors} -returnCodes error -body { ^ x 0 - } -result {can't use non-numeric string as operand of "^"} + } -result {can't use non-numeric string "x" as operand of "^"} test mathop-8.12 {compiled ^: errors} -returnCodes error -body { ^ nan 0 - } -result {can't use non-numeric floating-point value as operand of "^"} + } -result {can't use non-numeric floating-point value "nan" as operand of "^"} test mathop-8.13 {compiled ^: errors} -returnCodes error -body { ^ 0 x - } -result {can't use non-numeric string as operand of "^"} + } -result {can't use non-numeric string "x" as operand of "^"} test mathop-8.14 {compiled ^: errors} -returnCodes error -body { ^ 0 nan - } -result {can't use non-numeric floating-point value as operand of "^"} + } -result {can't use non-numeric floating-point value "nan" as operand of "^"} test mathop-8.15 {compiled ^: errors} -returnCodes error -body { ^ 0o8 0 - } -result {can't use invalid octal number as operand of "^"} + } -result {can't use invalid octal number "0o8" as operand of "^"} test mathop-8.16 {compiled ^: errors} -returnCodes error -body { ^ 0 0o8 - } -result {can't use invalid octal number as operand of "^"} + } -result {can't use invalid octal number "0o8" as operand of "^"} test mathop-8.17 {compiled ^: errors} -returnCodes error -body { ^ 0 [error expectedError] } -result expectedError @@ -639,32 +639,32 @@ namespace eval ::testmathop { test mathop-8.22 {interpreted ^} { $op 3 7 6 } 2 test mathop-8.23 {interpreted ^} -returnCodes error -body { $op 1.0 2 3 - } -result {can't use floating-point value as operand of "^"} + } -result {can't use floating-point value "1.0" as operand of "^"} test mathop-8.24 {interpreted ^} -returnCodes error -body { $op 1 2 3.0 - } -result {can't use floating-point value as operand of "^"} + } -result {can't use floating-point value "3.0" as operand of "^"} test mathop-8.25 {interpreted ^} { $op 100000000002 18 -126 } -100000000110 test mathop-8.26 {interpreted ^} { $op 0xff 0o377 333333333333 } 333333333333 test mathop-8.27 {interpreted ^} { $op 1000000000000000000002 18 -126 } -1000000000000000000110 test mathop-8.28 {interpreted ^} { $op 0xff 0o377 3333333333333333333333 } 3333333333333333333333 test mathop-8.29 {interpreted ^: errors} -returnCodes error -body { $op x 0 - } -result {can't use non-numeric string as operand of "^"} + } -result {can't use non-numeric string "x" as operand of "^"} test mathop-8.30 {interpreted ^: errors} -returnCodes error -body { $op nan 0 - } -result {can't use non-numeric floating-point value as operand of "^"} + } -result {can't use non-numeric floating-point value "nan" as operand of "^"} test mathop-8.31 {interpreted ^: errors} -returnCodes error -body { $op 0 x - } -result {can't use non-numeric string as operand of "^"} + } -result {can't use non-numeric string "x" as operand of "^"} test mathop-8.32 {interpreted ^: errors} -returnCodes error -body { $op 0 nan - } -result {can't use non-numeric floating-point value as operand of "^"} + } -result {can't use non-numeric floating-point value "nan" as operand of "^"} test mathop-8.33 {interpreted ^: errors} -returnCodes error -body { $op 0o8 0 - } -result {can't use invalid octal number as operand of "^"} + } -result {can't use invalid octal number "0o8" as operand of "^"} test mathop-8.34 {interpreted ^: errors} -returnCodes error -body { $op 0 0o8 - } -result {can't use invalid octal number as operand of "^"} + } -result {can't use invalid octal number "0o8" as operand of "^"} test mathop-8.35 {interpreted ^: errors} -returnCodes error -body { $op 0 [error expectedError] } -result expectedError @@ -775,13 +775,13 @@ test mathop-20.6 { one arg, error } { # skipping - for now, knownbug... foreach op {+ * / & | ^ **} { lappend res [TestOp $op {*}$vals] - lappend exp "can't use non-numeric string as operand of \"$op\"\ + lappend exp "can't use non-numeric string \"x\" as operand of \"$op\"\ ARITH DOMAIN {non-numeric string}" } } foreach op {+ * / & | ^ **} { lappend res [TestOp $op NaN 1] - lappend exp "can't use non-numeric floating-point value as operand of \"$op\"\ + lappend exp "can't use non-numeric floating-point value \"NaN\" as operand of \"$op\"\ ARITH DOMAIN {non-numeric floating-point value}" } expr {$res eq $exp ? 0 : $res} @@ -850,15 +850,15 @@ test mathop-21.5 { unary ops, bad values } { set res {} set exp {} lappend res [TestOp / x] - lappend exp "can't use non-numeric string as operand of \"/\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"/\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp - x] - lappend exp "can't use non-numeric string as operand of \"-\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"-\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ~ x] - lappend exp "can't use non-numeric string as operand of \"~\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"~\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ! x] - lappend exp "can't use non-numeric string as operand of \"!\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"!\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ~ 5.0] - lappend exp "can't use floating-point value as operand of \"~\" ARITH DOMAIN {floating-point value}" + lappend exp "can't use floating-point value \"5.0\" as operand of \"~\" ARITH DOMAIN {floating-point value}" expr {$res eq $exp ? 0 : $res} } 0 test mathop-21.6 { unary ops, too many } { @@ -965,9 +965,9 @@ test mathop-22.4 { unary ops, bad values } { set exp {} foreach op {& | ^} { lappend res [TestOp $op x 5] - lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp $op 5 x] - lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}" } expr {$res eq $exp ? 0 : $res} } 0 @@ -1080,15 +1080,15 @@ test mathop-24.3 { binary ops, bad values } { set exp {} foreach op {% << >>} { lappend res [TestOp $op x 1] - lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp $op 1 x] - lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"x\" as operand of \"$op\" ARITH DOMAIN {non-numeric string}" } foreach op {% << >>} { lappend res [TestOp $op 5.0 1] - lappend exp "can't use floating-point value as operand of \"$op\" ARITH DOMAIN {floating-point value}" + lappend exp "can't use floating-point value \"5.0\" as operand of \"$op\" ARITH DOMAIN {floating-point value}" lappend res [TestOp $op 1 5.0] - lappend exp "can't use floating-point value as operand of \"$op\" ARITH DOMAIN {floating-point value}" + lappend exp "can't use floating-point value \"5.0\" as operand of \"$op\" ARITH DOMAIN {floating-point value}" } foreach op {in ni} { lappend res [TestOp $op 5 "a b \{ c"] @@ -1266,9 +1266,9 @@ test mathop-25.41 { exp operator errors } { lappend res [TestOp ** $huge 2.1] lappend exp "Inf" lappend res [TestOp ** 2 foo] - lappend exp "can't use non-numeric string as operand of \"**\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"foo\" as operand of \"**\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ** foo 2] - lappend exp "can't use non-numeric string as operand of \"**\" ARITH DOMAIN {non-numeric string}" + lappend exp "can't use non-numeric string \"foo\" as operand of \"**\" ARITH DOMAIN {non-numeric string}" expr {$res eq $exp ? 0 : $res} } 0 diff --git a/tests/while-old.test b/tests/while-old.test index 9c8cacc..b5b69dc 100644 --- a/tests/while-old.test +++ b/tests/while-old.test @@ -92,7 +92,7 @@ test while-old-4.3 {errors in while loops} { test while-old-4.4 {errors in while loops} { set err [catch {while {"a"+"b"} {error "loop aborted"}} msg] list $err $msg -} {1 {can't use non-numeric string as operand of "+"}} +} {1 {can't use non-numeric string "a" as operand of "+"}} test while-old-4.5 {errors in while loops} { catch {unset x} set x 1 diff --git a/tests/while.test b/tests/while.test index 6ea8548..2bfab2a 100644 --- a/tests/while.test +++ b/tests/while.test @@ -32,7 +32,7 @@ test while-1.2 {TclCompileWhileCmd: error in test expression} -body { } -match glob -result {*"while {$i<} break"} test while-1.3 {TclCompileWhileCmd: error in test expression} -body { while {"a"+"b"} {error "loop aborted"} -} -returnCodes error -result {can't use non-numeric string as operand of "+"} +} -returnCodes error -result {can't use non-numeric string "a" as operand of "+"} test while-1.4 {TclCompileWhileCmd: multiline test expr} -body { set value 1 while {($tcl_platform(platform) != "foobar1") && \ @@ -343,7 +343,7 @@ test while-4.3 {while (not compiled): error in test expression} -body { test while-4.4 {while (not compiled): error in test expression} -body { set z while $z {"a"+"b"} {error "loop aborted"} -} -returnCodes error -result {can't use non-numeric string as operand of "+"} +} -returnCodes error -result {can't use non-numeric string "a" as operand of "+"} test while-4.5 {while (not compiled): multiline test expr} -body { set value 1 set z while -- cgit v0.12 From 3f9307ffc1520edb1932e7b342b67ecd49c4dcf5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 14 Oct 2022 22:24:36 +0000 Subject: Update tzdata to 2022e --- library/tzdata/America/Bahia_Banderas | 2 +- library/tzdata/America/Chihuahua | 2 +- library/tzdata/America/Hermosillo | 2 +- library/tzdata/America/Matamoros | 2 +- library/tzdata/America/Mazatlan | 2 +- library/tzdata/America/Mexico_City | 2 +- library/tzdata/America/Ojinaga | 2 +- library/tzdata/America/Tijuana | 2 +- library/tzdata/Asia/Amman | 156 +--------------------------------- library/tzdata/Asia/Damascus | 156 +--------------------------------- 10 files changed, 10 insertions(+), 318 deletions(-) diff --git a/library/tzdata/America/Bahia_Banderas b/library/tzdata/America/Bahia_Banderas index 8c40a0e..f06141e 100644 --- a/library/tzdata/America/Bahia_Banderas +++ b/library/tzdata/America/Bahia_Banderas @@ -5,7 +5,7 @@ set TZData(:America/Bahia_Banderas) { {-1514739600 -25200 0 MST} {-1343066400 -21600 0 CST} {-1234807200 -25200 0 MST} - {-1220292000 -21600 0 CST} + {-1220292000 -21600 1 MDT} {-1207159200 -25200 0 MST} {-1191344400 -21600 0 CST} {-873828000 -25200 0 MST} diff --git a/library/tzdata/America/Chihuahua b/library/tzdata/America/Chihuahua index 5444930..fc38542 100644 --- a/library/tzdata/America/Chihuahua +++ b/library/tzdata/America/Chihuahua @@ -5,7 +5,7 @@ set TZData(:America/Chihuahua) { {-1514739600 -25200 0 MST} {-1343066400 -21600 0 CST} {-1234807200 -25200 0 MST} - {-1220292000 -21600 0 CST} + {-1220292000 -21600 1 MDT} {-1207159200 -25200 0 MST} {-1191344400 -21600 0 CST} {820476000 -21600 0 CST} diff --git a/library/tzdata/America/Hermosillo b/library/tzdata/America/Hermosillo index 779020e..6576ad1 100644 --- a/library/tzdata/America/Hermosillo +++ b/library/tzdata/America/Hermosillo @@ -5,7 +5,7 @@ set TZData(:America/Hermosillo) { {-1514739600 -25200 0 MST} {-1343066400 -21600 0 CST} {-1234807200 -25200 0 MST} - {-1220292000 -21600 0 CST} + {-1220292000 -21600 1 MDT} {-1207159200 -25200 0 MST} {-1191344400 -21600 0 CST} {-873828000 -25200 0 MST} diff --git a/library/tzdata/America/Matamoros b/library/tzdata/America/Matamoros index 2b98652..6ae2fb9 100644 --- a/library/tzdata/America/Matamoros +++ b/library/tzdata/America/Matamoros @@ -1,7 +1,7 @@ # created by tools/tclZIC.tcl - do not edit set TZData(:America/Matamoros) { - {-9223372036854775808 -24000 0 LMT} + {-9223372036854775808 -23400 0 LMT} {-1514743200 -21600 0 CST} {568015200 -21600 0 CST} {576057600 -18000 1 CDT} diff --git a/library/tzdata/America/Mazatlan b/library/tzdata/America/Mazatlan index e56d7d0..5547d3f 100644 --- a/library/tzdata/America/Mazatlan +++ b/library/tzdata/America/Mazatlan @@ -5,7 +5,7 @@ set TZData(:America/Mazatlan) { {-1514739600 -25200 0 MST} {-1343066400 -21600 0 CST} {-1234807200 -25200 0 MST} - {-1220292000 -21600 0 CST} + {-1220292000 -21600 1 MDT} {-1207159200 -25200 0 MST} {-1191344400 -21600 0 CST} {-873828000 -25200 0 MST} diff --git a/library/tzdata/America/Mexico_City b/library/tzdata/America/Mexico_City index 48462e4..66e273f 100644 --- a/library/tzdata/America/Mexico_City +++ b/library/tzdata/America/Mexico_City @@ -5,7 +5,7 @@ set TZData(:America/Mexico_City) { {-1514739600 -25200 0 MST} {-1343066400 -21600 0 CST} {-1234807200 -25200 0 MST} - {-1220292000 -21600 0 CST} + {-1220292000 -21600 1 MDT} {-1207159200 -25200 0 MST} {-1191344400 -21600 0 CST} {-975261600 -18000 1 CDT} diff --git a/library/tzdata/America/Ojinaga b/library/tzdata/America/Ojinaga index 1172708..c01cfde 100644 --- a/library/tzdata/America/Ojinaga +++ b/library/tzdata/America/Ojinaga @@ -5,7 +5,7 @@ set TZData(:America/Ojinaga) { {-1514739600 -25200 0 MST} {-1343066400 -21600 0 CST} {-1234807200 -25200 0 MST} - {-1220292000 -21600 0 CST} + {-1220292000 -21600 1 MDT} {-1207159200 -25200 0 MST} {-1191344400 -21600 0 CST} {820476000 -21600 0 CST} diff --git a/library/tzdata/America/Tijuana b/library/tzdata/America/Tijuana index 4b7ebe7..186fe7d 100644 --- a/library/tzdata/America/Tijuana +++ b/library/tzdata/America/Tijuana @@ -2,7 +2,7 @@ set TZData(:America/Tijuana) { {-9223372036854775808 -28084 0 LMT} - {-1514736000 -25200 0 MST} + {-1514739600 -25200 0 MST} {-1451667600 -28800 0 PST} {-1343062800 -25200 0 MST} {-1234803600 -28800 0 PST} diff --git a/library/tzdata/Asia/Amman b/library/tzdata/Asia/Amman index 242a0c5..05cba69 100644 --- a/library/tzdata/Asia/Amman +++ b/library/tzdata/Asia/Amman @@ -88,159 +88,5 @@ set TZData(:Asia/Amman) { {1616709600 10800 1 EEST} {1635458400 7200 0 EET} {1645740000 10800 1 EEST} - {1666908000 7200 0 EET} - {1677189600 10800 1 EEST} - {1698357600 7200 0 EET} - {1709244000 10800 1 EEST} - {1729807200 7200 0 EET} - {1740693600 10800 1 EEST} - {1761861600 7200 0 EET} - {1772143200 10800 1 EEST} - {1793311200 7200 0 EET} - {1803592800 10800 1 EEST} - {1824760800 7200 0 EET} - {1835042400 10800 1 EEST} - {1856210400 7200 0 EET} - {1866492000 10800 1 EEST} - {1887660000 7200 0 EET} - {1898546400 10800 1 EEST} - {1919109600 7200 0 EET} - {1929996000 10800 1 EEST} - {1951164000 7200 0 EET} - {1961445600 10800 1 EEST} - {1982613600 7200 0 EET} - {1992895200 10800 1 EEST} - {2014063200 7200 0 EET} - {2024344800 10800 1 EEST} - {2045512800 7200 0 EET} - {2055794400 10800 1 EEST} - {2076962400 7200 0 EET} - {2087848800 10800 1 EEST} - {2109016800 7200 0 EET} - {2119298400 10800 1 EEST} - {2140466400 7200 0 EET} - {2150748000 10800 1 EEST} - {2171916000 7200 0 EET} - {2182197600 10800 1 EEST} - {2203365600 7200 0 EET} - {2213647200 10800 1 EEST} - {2234815200 7200 0 EET} - {2245701600 10800 1 EEST} - {2266264800 7200 0 EET} - {2277151200 10800 1 EEST} - {2298319200 7200 0 EET} - {2308600800 10800 1 EEST} - {2329768800 7200 0 EET} - {2340050400 10800 1 EEST} - {2361218400 7200 0 EET} - {2371500000 10800 1 EEST} - {2392668000 7200 0 EET} - {2402949600 10800 1 EEST} - {2424117600 7200 0 EET} - {2435004000 10800 1 EEST} - {2455567200 7200 0 EET} - {2466453600 10800 1 EEST} - {2487621600 7200 0 EET} - {2497903200 10800 1 EEST} - {2519071200 7200 0 EET} - {2529352800 10800 1 EEST} - {2550520800 7200 0 EET} - {2560802400 10800 1 EEST} - {2581970400 7200 0 EET} - {2592856800 10800 1 EEST} - {2613420000 7200 0 EET} - {2624306400 10800 1 EEST} - {2645474400 7200 0 EET} - {2655756000 10800 1 EEST} - {2676924000 7200 0 EET} - {2687205600 10800 1 EEST} - {2708373600 7200 0 EET} - {2718655200 10800 1 EEST} - {2739823200 7200 0 EET} - {2750104800 10800 1 EEST} - {2771272800 7200 0 EET} - {2782159200 10800 1 EEST} - {2802722400 7200 0 EET} - {2813608800 10800 1 EEST} - {2834776800 7200 0 EET} - {2845058400 10800 1 EEST} - {2866226400 7200 0 EET} - {2876508000 10800 1 EEST} - {2897676000 7200 0 EET} - {2907957600 10800 1 EEST} - {2929125600 7200 0 EET} - {2939407200 10800 1 EEST} - {2960575200 7200 0 EET} - {2971461600 10800 1 EEST} - {2992629600 7200 0 EET} - {3002911200 10800 1 EEST} - {3024079200 7200 0 EET} - {3034360800 10800 1 EEST} - {3055528800 7200 0 EET} - {3065810400 10800 1 EEST} - {3086978400 7200 0 EET} - {3097260000 10800 1 EEST} - {3118428000 7200 0 EET} - {3129314400 10800 1 EEST} - {3149877600 7200 0 EET} - {3160764000 10800 1 EEST} - {3181932000 7200 0 EET} - {3192213600 10800 1 EEST} - {3213381600 7200 0 EET} - {3223663200 10800 1 EEST} - {3244831200 7200 0 EET} - {3255112800 10800 1 EEST} - {3276280800 7200 0 EET} - {3286562400 10800 1 EEST} - {3307730400 7200 0 EET} - {3318616800 10800 1 EEST} - {3339180000 7200 0 EET} - {3350066400 10800 1 EEST} - {3371234400 7200 0 EET} - {3381516000 10800 1 EEST} - {3402684000 7200 0 EET} - {3412965600 10800 1 EEST} - {3434133600 7200 0 EET} - {3444415200 10800 1 EEST} - {3465583200 7200 0 EET} - {3476469600 10800 1 EEST} - {3497032800 7200 0 EET} - {3507919200 10800 1 EEST} - {3529087200 7200 0 EET} - {3539368800 10800 1 EEST} - {3560536800 7200 0 EET} - {3570818400 10800 1 EEST} - {3591986400 7200 0 EET} - {3602268000 10800 1 EEST} - {3623436000 7200 0 EET} - {3633717600 10800 1 EEST} - {3654885600 7200 0 EET} - {3665772000 10800 1 EEST} - {3686335200 7200 0 EET} - {3697221600 10800 1 EEST} - {3718389600 7200 0 EET} - {3728671200 10800 1 EEST} - {3749839200 7200 0 EET} - {3760120800 10800 1 EEST} - {3781288800 7200 0 EET} - {3791570400 10800 1 EEST} - {3812738400 7200 0 EET} - {3823020000 10800 1 EEST} - {3844188000 7200 0 EET} - {3855074400 10800 1 EEST} - {3876242400 7200 0 EET} - {3886524000 10800 1 EEST} - {3907692000 7200 0 EET} - {3917973600 10800 1 EEST} - {3939141600 7200 0 EET} - {3949423200 10800 1 EEST} - {3970591200 7200 0 EET} - {3980872800 10800 1 EEST} - {4002040800 7200 0 EET} - {4012927200 10800 1 EEST} - {4033490400 7200 0 EET} - {4044376800 10800 1 EEST} - {4065544800 7200 0 EET} - {4075826400 10800 1 EEST} - {4096994400 7200 0 EET} + {1666908000 10800 0 +03} } diff --git a/library/tzdata/Asia/Damascus b/library/tzdata/Asia/Damascus index fafef49..92ac4f5 100644 --- a/library/tzdata/Asia/Damascus +++ b/library/tzdata/Asia/Damascus @@ -122,159 +122,5 @@ set TZData(:Asia/Damascus) { {1616709600 10800 1 EEST} {1635454800 7200 0 EET} {1648159200 10800 1 EEST} - {1666904400 7200 0 EET} - {1680213600 10800 1 EEST} - {1698354000 7200 0 EET} - {1711663200 10800 1 EEST} - {1729803600 7200 0 EET} - {1743112800 10800 1 EEST} - {1761858000 7200 0 EET} - {1774562400 10800 1 EEST} - {1793307600 7200 0 EET} - {1806012000 10800 1 EEST} - {1824757200 7200 0 EET} - {1838066400 10800 1 EEST} - {1856206800 7200 0 EET} - {1869516000 10800 1 EEST} - {1887656400 7200 0 EET} - {1900965600 10800 1 EEST} - {1919106000 7200 0 EET} - {1932415200 10800 1 EEST} - {1951160400 7200 0 EET} - {1963864800 10800 1 EEST} - {1982610000 7200 0 EET} - {1995314400 10800 1 EEST} - {2014059600 7200 0 EET} - {2027368800 10800 1 EEST} - {2045509200 7200 0 EET} - {2058818400 10800 1 EEST} - {2076958800 7200 0 EET} - {2090268000 10800 1 EEST} - {2109013200 7200 0 EET} - {2121717600 10800 1 EEST} - {2140462800 7200 0 EET} - {2153167200 10800 1 EEST} - {2171912400 7200 0 EET} - {2184616800 10800 1 EEST} - {2203362000 7200 0 EET} - {2216671200 10800 1 EEST} - {2234811600 7200 0 EET} - {2248120800 10800 1 EEST} - {2266261200 7200 0 EET} - {2279570400 10800 1 EEST} - {2298315600 7200 0 EET} - {2311020000 10800 1 EEST} - {2329765200 7200 0 EET} - {2342469600 10800 1 EEST} - {2361214800 7200 0 EET} - {2374524000 10800 1 EEST} - {2392664400 7200 0 EET} - {2405973600 10800 1 EEST} - {2424114000 7200 0 EET} - {2437423200 10800 1 EEST} - {2455563600 7200 0 EET} - {2468872800 10800 1 EEST} - {2487618000 7200 0 EET} - {2500322400 10800 1 EEST} - {2519067600 7200 0 EET} - {2531772000 10800 1 EEST} - {2550517200 7200 0 EET} - {2563826400 10800 1 EEST} - {2581966800 7200 0 EET} - {2595276000 10800 1 EEST} - {2613416400 7200 0 EET} - {2626725600 10800 1 EEST} - {2645470800 7200 0 EET} - {2658175200 10800 1 EEST} - {2676920400 7200 0 EET} - {2689624800 10800 1 EEST} - {2708370000 7200 0 EET} - {2721679200 10800 1 EEST} - {2739819600 7200 0 EET} - {2753128800 10800 1 EEST} - {2771269200 7200 0 EET} - {2784578400 10800 1 EEST} - {2802718800 7200 0 EET} - {2816028000 10800 1 EEST} - {2834773200 7200 0 EET} - {2847477600 10800 1 EEST} - {2866222800 7200 0 EET} - {2878927200 10800 1 EEST} - {2897672400 7200 0 EET} - {2910981600 10800 1 EEST} - {2929122000 7200 0 EET} - {2942431200 10800 1 EEST} - {2960571600 7200 0 EET} - {2973880800 10800 1 EEST} - {2992626000 7200 0 EET} - {3005330400 10800 1 EEST} - {3024075600 7200 0 EET} - {3036780000 10800 1 EEST} - {3055525200 7200 0 EET} - {3068229600 10800 1 EEST} - {3086974800 7200 0 EET} - {3100284000 10800 1 EEST} - {3118424400 7200 0 EET} - {3131733600 10800 1 EEST} - {3149874000 7200 0 EET} - {3163183200 10800 1 EEST} - {3181928400 7200 0 EET} - {3194632800 10800 1 EEST} - {3213378000 7200 0 EET} - {3226082400 10800 1 EEST} - {3244827600 7200 0 EET} - {3258136800 10800 1 EEST} - {3276277200 7200 0 EET} - {3289586400 10800 1 EEST} - {3307726800 7200 0 EET} - {3321036000 10800 1 EEST} - {3339176400 7200 0 EET} - {3352485600 10800 1 EEST} - {3371230800 7200 0 EET} - {3383935200 10800 1 EEST} - {3402680400 7200 0 EET} - {3415384800 10800 1 EEST} - {3434130000 7200 0 EET} - {3447439200 10800 1 EEST} - {3465579600 7200 0 EET} - {3478888800 10800 1 EEST} - {3497029200 7200 0 EET} - {3510338400 10800 1 EEST} - {3529083600 7200 0 EET} - {3541788000 10800 1 EEST} - {3560533200 7200 0 EET} - {3573237600 10800 1 EEST} - {3591982800 7200 0 EET} - {3605292000 10800 1 EEST} - {3623432400 7200 0 EET} - {3636741600 10800 1 EEST} - {3654882000 7200 0 EET} - {3668191200 10800 1 EEST} - {3686331600 7200 0 EET} - {3699640800 10800 1 EEST} - {3718386000 7200 0 EET} - {3731090400 10800 1 EEST} - {3749835600 7200 0 EET} - {3762540000 10800 1 EEST} - {3781285200 7200 0 EET} - {3794594400 10800 1 EEST} - {3812734800 7200 0 EET} - {3826044000 10800 1 EEST} - {3844184400 7200 0 EET} - {3857493600 10800 1 EEST} - {3876238800 7200 0 EET} - {3888943200 10800 1 EEST} - {3907688400 7200 0 EET} - {3920392800 10800 1 EEST} - {3939138000 7200 0 EET} - {3951842400 10800 1 EEST} - {3970587600 7200 0 EET} - {3983896800 10800 1 EEST} - {4002037200 7200 0 EET} - {4015346400 10800 1 EEST} - {4033486800 7200 0 EET} - {4046796000 10800 1 EEST} - {4065541200 7200 0 EET} - {4078245600 10800 1 EEST} - {4096990800 7200 0 EET} + {1666908000 10800 0 +03} } -- cgit v0.12 From 6cda753ae057b0c4e0b485b64262b5d61de28334 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 16 Oct 2022 11:10:36 +0000 Subject: new TIP about -eofchar handling --- generic/tclIO.c | 74 ++++++------------------------------------------------- generic/tclIO.h | 4 ++- tests/chan.test | 2 +- tests/chanio.test | 22 ++++++++--------- tests/io.test | 26 +++++++++---------- tests/ioCmd.test | 6 ++--- 6 files changed, 39 insertions(+), 95 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 48aa18d..2e821a7 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -1688,7 +1688,6 @@ Tcl_CreateChannel( statePtr->inputTranslation = TCL_TRANSLATE_AUTO; statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION; statePtr->inEofChar = 0; - statePtr->outEofChar = 0; statePtr->unreportedError = 0; statePtr->refCount = 0; @@ -3077,18 +3076,6 @@ CloseChannel( } /* - * If the EOF character is set in the channel, append that to the output - * device. - */ - - if ((statePtr->outEofChar != 0) && GotFlag(statePtr, TCL_WRITABLE)) { - int dummy; - char c = (char) statePtr->outEofChar; - - (void) ChanWrite(chanPtr, &c, 1, &dummy); - } - - /* * TIP #219, Tcl Channel Reflection API. * Move a leftover error message in the channel bypass into the * interpreter bypass. Just clear it if there is no interpreter. @@ -3853,18 +3840,6 @@ CloseChannelPart( } /* - * If the EOF character is set in the channel, append that to the - * output device. - */ - - if ((statePtr->outEofChar != 0) && GotFlag(statePtr, TCL_WRITABLE)) { - int dummy; - char c = (char) statePtr->outEofChar; - - (void) ChanWrite(chanPtr, &c, 1, &dummy); - } - - /* * TIP #219, Tcl Channel Reflection API. * Move a leftover error message in the channel bypass into the * interpreter bypass. Just clear it if there is no interpreter. @@ -7958,40 +7933,13 @@ Tcl_GetChannelOption( if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-eofchar"); } - if (((flags & (TCL_READABLE|TCL_WRITABLE)) == - (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) { - Tcl_DStringStartSublist(dsPtr); - } - if (flags & TCL_READABLE) { - if (statePtr->inEofChar == 0) { - Tcl_DStringAppendElement(dsPtr, ""); - } else { - char buf[4]; - - sprintf(buf, "%c", statePtr->inEofChar); - Tcl_DStringAppendElement(dsPtr, buf); - } - } - if (flags & TCL_WRITABLE) { - if (statePtr->outEofChar == 0) { - Tcl_DStringAppendElement(dsPtr, ""); - } else { - char buf[4]; - - sprintf(buf, "%c", statePtr->outEofChar); - Tcl_DStringAppendElement(dsPtr, buf); - } - } - if (!(flags & (TCL_READABLE|TCL_WRITABLE))) { - /* - * Not readable or writable (e.g. server socket) - */ - + if (!(flags & TCL_READABLE) || (statePtr->inEofChar == 0)) { Tcl_DStringAppendElement(dsPtr, ""); - } - if (((flags & (TCL_READABLE|TCL_WRITABLE)) == - (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) { - Tcl_DStringEndSublist(dsPtr); + } else { + char buf[4]; + + sprintf(buf, "%c", statePtr->inEofChar); + Tcl_DStringAppendElement(dsPtr, buf); } if (len > 0) { return TCL_OK; @@ -8234,13 +8182,11 @@ Tcl_SetChannelOption( } if (argc == 0) { statePtr->inEofChar = 0; - statePtr->outEofChar = 0; } else if (argc == 1 || argc == 2) { - int outIndex = (argc - 1); int inValue = (int) argv[0][0]; - int outValue = (int) argv[outIndex][0]; + int outValue = (argc == 2) ? (int) argv[1][0] : 0; - if (inValue & 0x80 || outValue & 0x80) { + if (inValue & 0x80 || outValue) { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -eofchar: must be non-NUL ASCII" @@ -8252,9 +8198,6 @@ Tcl_SetChannelOption( if (GotFlag(statePtr, TCL_READABLE)) { statePtr->inEofChar = inValue; } - if (GotFlag(statePtr, TCL_WRITABLE)) { - statePtr->outEofChar = outValue; - } } else { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -8387,7 +8330,6 @@ Tcl_SetChannelOption( statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION; } } else if (strcmp(writeMode, "binary") == 0) { - statePtr->outEofChar = 0; statePtr->outputTranslation = TCL_TRANSLATE_LF; Tcl_FreeEncoding(statePtr->encoding); statePtr->encoding = NULL; diff --git a/generic/tclIO.h b/generic/tclIO.h index a4cc602..490f26c 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -158,8 +158,10 @@ typedef struct ChannelState { * of line sequences in output? */ int inEofChar; /* If nonzero, use this as a signal of EOF on * input. */ +#if TCL_MAJOR_VERSION < 9 int outEofChar; /* If nonzero, append this to the channel when - * it is closed if it is open for writing. */ + * it is closed if it is open for writing. For Tcl 8.x only */ +#endif int unreportedError; /* Non-zero if an error report was deferred * because it happened in the background. The * value is the POSIX error code. */ diff --git a/tests/chan.test b/tests/chan.test index 4155c36..280783f 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -61,7 +61,7 @@ test chan-4.5 {chan command: check valid inValue, invalid outValue} -body { } -returnCodes error -match glob -result {bad value for -eofchar:*} test chan-4.6 {chan command: check no inValue, valid outValue} -body { chan configure stdout -eofchar [list {} \x27] -} -result {} -cleanup {chan configure stdout -eofchar [list {} {}]} +} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character} -cleanup {chan configure stdout -eofchar [list {} {}]} test chan-5.1 {chan command: copy subcommand} -body { chan copy foo diff --git a/tests/chanio.test b/tests/chanio.test index c1085f4..f9d272a 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -1895,7 +1895,7 @@ test chan-io-20.3 {Tcl_CreateChannel: initial settings} -constraints {unix} -bod list [chan configure $f -eofchar] [chan configure $f -translation] } -cleanup { chan close $f -} -result {{{} {}} {auto lf}} +} -result {{{}} {auto lf}} test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} -setup { set path(stdout) [makeFile {} stdout] } -constraints {stdio notWinCI} -body { @@ -4657,7 +4657,7 @@ test chan-io-35.6 {Tcl_Eof, eof char, lf write, auto read} -setup { list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f -} -result {9 8 1} +} -result {8 8 1} test chan-io-35.7 {Tcl_Eof, eof char, lf write, lf read} -setup { file delete $path(test1) } -body { @@ -4671,7 +4671,7 @@ test chan-io-35.7 {Tcl_Eof, eof char, lf write, lf read} -setup { list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f -} -result {9 8 1} +} -result {8 8 1} test chan-io-35.8 {Tcl_Eof, eof char, cr write, auto read} -setup { file delete $path(test1) } -body { @@ -4685,7 +4685,7 @@ test chan-io-35.8 {Tcl_Eof, eof char, cr write, auto read} -setup { list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f -} -result {9 8 1} +} -result {8 8 1} test chan-io-35.9 {Tcl_Eof, eof char, cr write, cr read} -setup { file delete $path(test1) } -body { @@ -4699,7 +4699,7 @@ test chan-io-35.9 {Tcl_Eof, eof char, cr write, cr read} -setup { list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f -} -result {9 8 1} +} -result {8 8 1} test chan-io-35.10 {Tcl_Eof, eof char, crlf write, auto read} -setup { file delete $path(test1) } -body { @@ -4713,7 +4713,7 @@ test chan-io-35.10 {Tcl_Eof, eof char, crlf write, auto read} -setup { list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f -} -result {11 8 1} +} -result {10 8 1} test chan-io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} -setup { file delete $path(test1) } -body { @@ -4727,7 +4727,7 @@ test chan-io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} -setup { list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f -} -result {11 8 1} +} -result {10 8 1} test chan-io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} -setup { file delete $path(test1) } -body { @@ -5288,26 +5288,26 @@ test chan-io-39.22 {Tcl_SetChannelOption, invariance} -setup { } -constraints {unix} -body { set f1 [open $path(test1) w+] lappend l [chan configure $f1 -eofchar] - chan configure $f1 -eofchar {ON GO} + chan configure $f1 -eofchar {ON {}} lappend l [chan configure $f1 -eofchar] chan configure $f1 -eofchar D lappend l [chan configure $f1 -eofchar] } -cleanup { chan close $f1 -} -result {{{} {}} {O G} {D D}} +} -result {{{}} O D} test chan-io-39.22a {Tcl_SetChannelOption, invariance} -setup { file delete $path(test1) set l [list] } -body { set f1 [open $path(test1) w+] - chan configure $f1 -eofchar {ON GO} + chan configure $f1 -eofchar {ON {}} lappend l [chan configure $f1 -eofchar] chan configure $f1 -eofchar D lappend l [chan configure $f1 -eofchar] lappend l [list [catch {chan configure $f1 -eofchar {1 2 3}} msg] $msg] } -cleanup { chan close $f1 -} -result {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}} +} -result {O D {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}} test chan-io-39.23 {Tcl_GetChannelOption, server socket is not readable or\ writeable, it should still have valid -eofchar and -translation options} -setup { set l [list] diff --git a/tests/io.test b/tests/io.test index 3241625..15ce577 100644 --- a/tests/io.test +++ b/tests/io.test @@ -2099,7 +2099,7 @@ test io-20.3 {Tcl_CreateChannel: initial settings} {unix} { set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] close $f set x -} {{{} {}} {auto lf}} +} {{{}} {auto lf}} set path(stdout) [makeFile {} stdout] test io-20.5 {Tcl_CreateChannel: install channel in empty slot} stdio { set f [open $path(script) w] @@ -5038,7 +5038,7 @@ test io-35.6 {Tcl_Eof, eof char, lf write, auto read} { set e [eof $f] close $f list $s $l $e -} {9 8 1} +} {8 8 1} test io-35.7 {Tcl_Eof, eof char, lf write, lf read} { file delete $path(test1) set f [open $path(test1) w] @@ -5052,7 +5052,7 @@ test io-35.7 {Tcl_Eof, eof char, lf write, lf read} { set e [eof $f] close $f list $s $l $e -} {9 8 1} +} {8 8 1} test io-35.8 {Tcl_Eof, eof char, cr write, auto read} { file delete $path(test1) set f [open $path(test1) w] @@ -5066,7 +5066,7 @@ test io-35.8 {Tcl_Eof, eof char, cr write, auto read} { set e [eof $f] close $f list $s $l $e -} {9 8 1} +} {8 8 1} test io-35.9 {Tcl_Eof, eof char, cr write, cr read} { file delete $path(test1) set f [open $path(test1) w] @@ -5080,7 +5080,7 @@ test io-35.9 {Tcl_Eof, eof char, cr write, cr read} { set e [eof $f] close $f list $s $l $e -} {9 8 1} +} {8 8 1} test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} { file delete $path(test1) set f [open $path(test1) w] @@ -5094,7 +5094,7 @@ test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} { set e [eof $f] close $f list $s $l $e -} {11 8 1} +} {10 8 1} test io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} { file delete $path(test1) set f [open $path(test1) w] @@ -5108,7 +5108,7 @@ test io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} { set e [eof $f] close $f list $s $l $e -} {11 8 1} +} {10 8 1} test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} { file delete $path(test1) set f [open $path(test1) w] @@ -5226,7 +5226,7 @@ test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} -body { set e [eof $f] close $f list $s $l $e [scan [string index $in end] %c] -} -result {9 8 1 13} +} -result {8 8 1 13} test io-35.18b {Tcl_Eof, eof char, cr write, crlf read} -body { file delete $path(test1) set f [open $path(test1) w] @@ -5240,7 +5240,7 @@ test io-35.18b {Tcl_Eof, eof char, cr write, crlf read} -body { set e [eof $f] close $f list $s $l $e [scan [string index $in end] %c] -} -result {2 1 1 13} +} -result {1 1 1 13} test io-35.18c {Tcl_Eof, eof char, cr write, crlf read} -body { file delete $path(test1) set f [open $path(test1) w] @@ -5761,25 +5761,25 @@ test io-39.22 {Tcl_SetChannelOption, invariance} {unix} { set f1 [open $path(test1) w+] set l "" lappend l [fconfigure $f1 -eofchar] - fconfigure $f1 -eofchar {ON GO} + fconfigure $f1 -eofchar {ON {}} lappend l [fconfigure $f1 -eofchar] fconfigure $f1 -eofchar D lappend l [fconfigure $f1 -eofchar] close $f1 set l -} {{{} {}} {O G} {D D}} +} {{{}} O D} test io-39.22a {Tcl_SetChannelOption, invariance} { file delete $path(test1) set f1 [open $path(test1) w+] set l [list] - fconfigure $f1 -eofchar {ON GO} + fconfigure $f1 -eofchar {ON {}} lappend l [fconfigure $f1 -eofchar] fconfigure $f1 -eofchar D lappend l [fconfigure $f1 -eofchar] lappend l [list [catch {fconfigure $f1 -eofchar {1 2 3}} msg] $msg] close $f1 set l -} {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}} +} {O D {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}} test io-39.23 {Tcl_GetChannelOption, server socket is not readable or writeable, it should still have valid -eofchar and -translation options } { set l [list] diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 20418f3..c8daa96 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -1363,7 +1363,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { close $c rename foo {} set res -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -nocomplainencoding 0 -strictencoding 0 -translation {auto *}}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} -nocomplainencoding 0 -strictencoding 0 -translation {auto *}}} test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -1372,7 +1372,7 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -nocomplainencoding 0 -strictencoding 0 -translation {auto *}}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} -nocomplainencoding 0 -strictencoding 0 -translation {auto *}}} test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -1384,7 +1384,7 @@ test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -nocomplainencoding 0 -strictencoding 0 -translation {auto *} -bar foo -snarf x}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} -nocomplainencoding 0 -strictencoding 0 -translation {auto *} -bar foo -snarf x}} test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { -- cgit v0.12 From 7593fce2300c45d321ff47f31909d0fafe03bf68 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 16 Oct 2022 16:57:29 +0000 Subject: Prevent warning: tclUnixSock.c:1079:19: warning: unused variable 'size' [-Wunused-variable] --- unix/tclUnixSock.c | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index abd7fa6..43303f8 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -1016,8 +1016,8 @@ TcpGetOptionProc( if ((len == 0) || ((len > 1) && (optionName[1] == 's') && (strncmp(optionName, "-sockname", len) == 0))) { TcpFdList *fds; - address sockname; - socklen_t size; + address sockname; + socklen_t size; int found = 0; WaitForConnect(statePtr, NULL); @@ -1056,7 +1056,9 @@ TcpGetOptionProc( if ((len == 0) || ((len > 1) && (optionName[1] == 'k') && (strncmp(optionName, "-keepalive", len) == 0))) { - socklen_t size; +#if defined(SO_KEEPALIVE) + socklen_t size; +#endif int opt = 0; if (len == 0) { @@ -1074,7 +1076,9 @@ TcpGetOptionProc( if ((len == 0) || ((len > 1) && (optionName[1] == 'n') && (strncmp(optionName, "-nodelay", len) == 0))) { - socklen_t size; +#if defined(SOL_TCP) && defined(TCP_NODELAY) + socklen_t size; +#endif int opt = 0; if (len == 0) { -- cgit v0.12 From 3c0ca659784b51136017dd079a4716fdf2355524 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 16 Oct 2022 17:56:23 +0000 Subject: Minor change to -eofchar handling --- doc/chan.n | 9 ++-- generic/tclIO.c | 3 +- tests/chanio.test | 116 ++++++++++++++++++++++++------------------------- tests/io.test | 128 +++++++++++++++++++++++++++--------------------------- 4 files changed, 127 insertions(+), 129 deletions(-) diff --git a/doc/chan.n b/doc/chan.n index 9589f98..71db309 100644 --- a/doc/chan.n +++ b/doc/chan.n @@ -142,17 +142,16 @@ which returns the platform- and locale-dependent system encoding used to interface with the operating system, .RE .TP -\fB\-eofchar\fR \fIchar\fR +\fB\-eofchar\fR \fIinChar\fR .TP \fB\-eofchar\fR \fB{\fIinChar outChar\fB}\fR . -\fIchar\fR signals the end of the data when it is encountered in the input. -For output, the character is added when the channel is closed. If \fIchar\fR +\fIinChar\fR signals the end of the data when it is encountered in the input. +For output, the character is added when the channel is closed. If \fIinChar\fR is the empty string, there is no special character that marks the end of the data. For read-write channels, one end-of-file character for input and another for output may be given. When only one end-of-file character is given it is -applied to both input and output. For a read-write channel two values are -returned even if they are are identical. +applied to input only. The default value is the empty string, except that under Windows the default value for reading is Control-z (\ex1A). The acceptable range is \ex01 - diff --git a/generic/tclIO.c b/generic/tclIO.c index 6a9c306..32a03b0 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8269,9 +8269,8 @@ Tcl_SetChannelOption( statePtr->inEofChar = 0; statePtr->outEofChar = 0; } else if (argc == 1 || argc == 2) { - int outIndex = (argc - 1); int inValue = (int) argv[0][0]; - int outValue = (int) argv[outIndex][0]; + int outValue = (argc == 2) ? (int) argv[1][0] : 0; if (inValue & 0x80 || outValue & 0x80) { if (interp) { diff --git a/tests/chanio.test b/tests/chanio.test index 8d922a2..7d9c3e5 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -80,7 +80,7 @@ namespace eval ::tcl::test::io { if {$argv != ""} { set f [open [lindex $argv 0]] } - chan configure $f -encoding binary -translation lf -blocking 0 -eofchar \x1A + chan configure $f -encoding binary -translation lf -blocking 0 -eofchar "\x1A \x1A" chan configure stdout -encoding binary -translation lf -buffering none chan event $f readable "foo $f" proc foo {f} { @@ -481,7 +481,7 @@ test chan-io-6.8 {Tcl_GetsObj: remember if EOF is seen} -body { chan puts $f "abcdef\x1Aghijk\nwombat" chan close $f set f [open $path(test1)] - chan configure $f -eofchar \x1A + chan configure $f -eofchar "\x1A \x1A" list [chan gets $f line] $line [chan gets $f line] $line } -cleanup { chan close $f @@ -491,7 +491,7 @@ test chan-io-6.9 {Tcl_GetsObj: remember if EOF is seen} -body { chan puts $f "abcdefghijk\nwom\x1Abat" chan close $f set f [open $path(test1)] - chan configure $f -eofchar \x1A + chan configure $f -eofchar "\x1A \x1A" list [chan gets $f line] $line [chan gets $f line] $line } -cleanup { chan close $f @@ -999,7 +999,7 @@ test chan-io-6.52 {Tcl_GetsObj: saw EOF character} -constraints {testchannel} -b chan puts -nonewline $f "123456\x1Ak9012345\r" chan close $f set f [open $path(test1)] - chan configure $f -eofchar \x1A + chan configure $f -eofchar "\x1A \x1A" list [chan gets $f] [testchannel queuedcr $f] [chan tell $f] [chan gets $f] } -cleanup { chan close $f @@ -3105,7 +3105,7 @@ test chan-io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} -setup { chan puts -nonewline $f hello\nthere\nand\rhere\n\x1A chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" chan read $f } -cleanup { chan close $f @@ -3118,11 +3118,11 @@ test chan-io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} -setup { file delete $path(test1) } -constraints {win} -body { set f [open $path(test1) w] - chan configure $f -translation lf -eofchar \x1A + chan configure $f -translation lf -eofchar "\x1A \x1A" chan puts $f hello\nthere\nand\rhere chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" chan read $f } -cleanup { chan close $f @@ -3140,7 +3140,7 @@ test chan-io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} -setup { chan puts $f $s chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" set l "" lappend l [chan gets $f] lappend l [chan gets $f] @@ -3161,7 +3161,7 @@ test chan-io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} -setup { chan puts $f $s chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" set l "" lappend l [chan gets $f] lappend l [chan gets $f] @@ -3239,7 +3239,7 @@ test chan-io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} -setup { chan puts $f [format abc\ndef\n%cqrs\ntuv 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3253,7 +3253,7 @@ test chan-io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation lf -eofchar \x1A + chan configure $f -translation lf -eofchar "\x1A \x1A" list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3267,7 +3267,7 @@ test chan-io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3281,7 +3281,7 @@ test chan-io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation cr -eofchar \x1A + chan configure $f -translation cr -eofchar "\x1A \x1A" list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3295,7 +3295,7 @@ test chan-io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3309,7 +3309,7 @@ test chan-io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} -setup { chan puts $f $c chan close $f set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar \x1A + chan configure $f -translation crlf -eofchar "\x1A \x1A" list [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -3660,7 +3660,7 @@ test chan-io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} -setup { chan puts $f [format "hello\nthere\nand\rhere\n\%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3676,11 +3676,11 @@ test chan-io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} -setup { set l "" } -body { set f [open $path(test1) w] - chan configure $f -translation lf -eofchar \x1A + chan configure $f -translation lf -eofchar "\x1A \x1A" chan puts $f hello\nthere\nand\rhere chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan gets $f] @@ -3700,7 +3700,7 @@ test chan-io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3718,7 +3718,7 @@ test chan-io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3802,7 +3802,7 @@ test chan-io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3820,7 +3820,7 @@ test chan-io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation lf -eofchar \x1A + chan configure $f -translation lf -eofchar "\x1A \x1A" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3838,7 +3838,7 @@ test chan-io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3856,7 +3856,7 @@ test chan-io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation cr -eofchar \x1A + chan configure $f -translation cr -eofchar "\x1A \x1A" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3874,7 +3874,7 @@ test chan-io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -3892,7 +3892,7 @@ test chan-io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} -setup { chan puts $f [format "abc\ndef\n%cqrs\ntuv" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar \x1A + chan configure $f -translation crlf -eofchar "\x1A \x1A" lappend l [chan gets $f] lappend l [chan gets $f] lappend l [chan eof $f] @@ -4648,12 +4648,12 @@ test chan-io-35.6 {Tcl_Eof, eof char, lf write, auto read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation lf -eofchar \x1A + chan configure $f -translation lf -eofchar "\x1A \x1A" chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4662,12 +4662,12 @@ test chan-io-35.7 {Tcl_Eof, eof char, lf write, lf read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation lf -eofchar \x1A + chan configure $f -translation lf -eofchar "\x1A \x1A" chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation lf -eofchar \x1A + chan configure $f -translation lf -eofchar "\x1A \x1A" list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4676,12 +4676,12 @@ test chan-io-35.8 {Tcl_Eof, eof char, cr write, auto read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation cr -eofchar \x1A + chan configure $f -translation cr -eofchar "\x1A \x1A" chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4690,12 +4690,12 @@ test chan-io-35.9 {Tcl_Eof, eof char, cr write, cr read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation cr -eofchar \x1A + chan configure $f -translation cr -eofchar "\x1A \x1A" chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation cr -eofchar \x1A + chan configure $f -translation cr -eofchar "\x1A \x1A" list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4704,12 +4704,12 @@ test chan-io-35.10 {Tcl_Eof, eof char, crlf write, auto read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation crlf -eofchar \x1A + chan configure $f -translation crlf -eofchar "\x1A \x1A" chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4718,12 +4718,12 @@ test chan-io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -translation crlf -eofchar \x1A + chan configure $f -translation crlf -eofchar "\x1A \x1A" chan puts $f abc\ndef chan close $f set s [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar \x1A + chan configure $f -translation crlf -eofchar "\x1A \x1A" list $s [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4737,7 +4737,7 @@ test chan-io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4751,7 +4751,7 @@ test chan-io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation lf -eofchar \x1A + chan configure $f -translation lf -eofchar "\x1A \x1A" list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4765,7 +4765,7 @@ test chan-io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4779,7 +4779,7 @@ test chan-io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation cr -eofchar \x1A + chan configure $f -translation cr -eofchar "\x1A \x1A" list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4793,7 +4793,7 @@ test chan-io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -4807,7 +4807,7 @@ test chan-io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} -setup { chan close $f set c [file size $path(test1)] set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar \x1A + chan configure $f -translation crlf -eofchar "\x1A \x1A" list $c [string length [chan read $f]] [chan eof $f] } -cleanup { chan close $f @@ -5290,7 +5290,7 @@ test chan-io-39.22 {Tcl_SetChannelOption, invariance} -setup { lappend l [chan configure $f1 -eofchar] chan configure $f1 -eofchar {ON GO} lappend l [chan configure $f1 -eofchar] - chan configure $f1 -eofchar D + chan configure $f1 -eofchar {D D} lappend l [chan configure $f1 -eofchar] } -cleanup { chan close $f1 @@ -5302,7 +5302,7 @@ test chan-io-39.22a {Tcl_SetChannelOption, invariance} -setup { set f1 [open $path(test1) w+] chan configure $f1 -eofchar {ON GO} lappend l [chan configure $f1 -eofchar] - chan configure $f1 -eofchar D + chan configure $f1 -eofchar {D D} lappend l [chan configure $f1 -eofchar] lappend l [list [catch {chan configure $f1 -eofchar {1 2 3}} msg] $msg] } -cleanup { @@ -6047,7 +6047,7 @@ test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6071,7 +6071,7 @@ test chan-io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6095,7 +6095,7 @@ test chan-io-48.6 {cr write, testing readability, ^Z termination, auto read mode chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6119,7 +6119,7 @@ test chan-io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6143,7 +6143,7 @@ test chan-io-48.8 {crlf write, testing readability, ^Z termination, auto read mo chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6167,7 +6167,7 @@ test chan-io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation auto -eofchar \x1A + chan configure $f -translation auto -eofchar "\x1A \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6191,7 +6191,7 @@ test chan-io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} - chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation lf -eofchar \x1A + chan configure $f -translation lf -eofchar "\x1A \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6215,7 +6215,7 @@ test chan-io-48.11 {lf write, testing readability, ^Z termination, lf read mode} chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation lf -eofchar \x1A + chan configure $f -translation lf -eofchar "\x1A \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6239,7 +6239,7 @@ test chan-io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} - chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation cr -eofchar \x1A + chan configure $f -translation cr -eofchar "\x1A \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6263,7 +6263,7 @@ test chan-io-48.13 {cr write, testing readability, ^Z termination, cr read mode} chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation cr -eofchar \x1A + chan configure $f -translation cr -eofchar "\x1A \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6287,7 +6287,7 @@ test chan-io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mod chan puts -nonewline $f [format "abc\ndef\n%cfoo\nbar\n" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar \x1A + chan configure $f -translation crlf -eofchar "\x1A \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done @@ -6311,7 +6311,7 @@ test chan-io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} - chan puts -nonewline $f [format "abc\ndef\n%c" 26] chan close $f set f [open $path(test1) r] - chan configure $f -translation crlf -eofchar \x1A + chan configure $f -translation crlf -eofchar "\x1A \x1A" chan event $f readable [namespace code { if {[chan eof $f]} { set x done diff --git a/tests/io.test b/tests/io.test index f928cd3..a80e94e 100644 --- a/tests/io.test +++ b/tests/io.test @@ -77,7 +77,7 @@ set path(cat) [makeFile { if {$argv != ""} { set f [open [lindex $argv 0]] } - fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar \x1A + fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar "\x1A \x1A" fconfigure stdout -encoding binary -translation lf -buffering none fileevent $f readable "foo $f" proc foo {f} { @@ -517,7 +517,7 @@ test io-6.8 {Tcl_GetsObj: remember if EOF is seen} { puts $f "abcdef\x1Aghijk\nwombat" close $f set f [open $path(test1)] - fconfigure $f -eofchar \x1A + fconfigure $f -eofchar "\x1A \x1A" set x [list [gets $f line] $line [gets $f line] $line] close $f set x @@ -527,7 +527,7 @@ test io-6.9 {Tcl_GetsObj: remember if EOF is seen} { puts $f "abcdefghijk\nwom\x1Abat" close $f set f [open $path(test1)] - fconfigure $f -eofchar \x1A + fconfigure $f -eofchar "\x1A \x1A" set x [list [gets $f line] $line [gets $f line] $line] close $f set x @@ -1036,7 +1036,7 @@ test io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} { puts -nonewline $f "123456\x1Ak9012345\r" close $f set f [open $path(test1)] - fconfigure $f -eofchar \x1A + fconfigure $f -eofchar "\x1A \x1A" set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]] close $f set x @@ -3382,7 +3382,7 @@ test io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} { puts -nonewline $f hello\nthere\nand\rhere\n\x1A close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set c [read $f] close $f set c @@ -3394,11 +3394,11 @@ here test io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {win} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar \x1A + fconfigure $f -translation lf -eofchar "\x1A \x1A" puts $f hello\nthere\nand\rhere close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set c [read $f] close $f set c @@ -3415,7 +3415,7 @@ test io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -3435,7 +3435,7 @@ test io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -3513,7 +3513,7 @@ test io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set c [string length [read $f]] set e [eof $f] close $f @@ -3527,7 +3527,7 @@ test io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1A + fconfigure $f -translation lf -eofchar "\x1A \x1A" set c [string length [read $f]] set e [eof $f] close $f @@ -3541,7 +3541,7 @@ test io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set c [string length [read $f]] set e [eof $f] close $f @@ -3555,7 +3555,7 @@ test io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1A + fconfigure $f -translation cr -eofchar "\x1A \x1A" set c [string length [read $f]] set e [eof $f] close $f @@ -3569,7 +3569,7 @@ test io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set c [string length [read $f]] set e [eof $f] close $f @@ -3583,7 +3583,7 @@ test io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1A + fconfigure $f -translation crlf -eofchar "\x1A \x1A" set c [string length [read $f]] set e [eof $f] close $f @@ -3916,7 +3916,7 @@ test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -3931,11 +3931,11 @@ test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { test io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar \x1A + fconfigure $f -translation lf -eofchar "\x1A \x1A" puts $f hello\nthere\nand\rhere close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -3955,7 +3955,7 @@ test io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -3973,7 +3973,7 @@ test io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -4057,7 +4057,7 @@ test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -4075,7 +4075,7 @@ test io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1A + fconfigure $f -translation lf -eofchar "\x1A \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -4093,7 +4093,7 @@ test io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -4111,7 +4111,7 @@ test io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1A + fconfigure $f -translation cr -eofchar "\x1A \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -4129,7 +4129,7 @@ test io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -4147,7 +4147,7 @@ test io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1A + fconfigure $f -translation crlf -eofchar "\x1A \x1A" set l "" lappend l [gets $f] lappend l [gets $f] @@ -5028,12 +5028,12 @@ test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} stdio { test io-35.6 {Tcl_Eof, eof char, lf write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar \x1A + fconfigure $f -translation lf -eofchar "\x1A \x1A" puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5042,12 +5042,12 @@ test io-35.6 {Tcl_Eof, eof char, lf write, auto read} { test io-35.7 {Tcl_Eof, eof char, lf write, lf read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar \x1A + fconfigure $f -translation lf -eofchar "\x1A \x1A" puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1A + fconfigure $f -translation lf -eofchar "\x1A \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5056,12 +5056,12 @@ test io-35.7 {Tcl_Eof, eof char, lf write, lf read} { test io-35.8 {Tcl_Eof, eof char, cr write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar \x1A + fconfigure $f -translation cr -eofchar "\x1A \x1A" puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5070,12 +5070,12 @@ test io-35.8 {Tcl_Eof, eof char, cr write, auto read} { test io-35.9 {Tcl_Eof, eof char, cr write, cr read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar \x1A + fconfigure $f -translation cr -eofchar "\x1A \x1A" puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1A + fconfigure $f -translation cr -eofchar "\x1A \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5084,12 +5084,12 @@ test io-35.9 {Tcl_Eof, eof char, cr write, cr read} { test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar \x1A + fconfigure $f -translation crlf -eofchar "\x1A \x1A" puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5098,12 +5098,12 @@ test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} { test io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar \x1A + fconfigure $f -translation crlf -eofchar "\x1A \x1A" puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1A + fconfigure $f -translation crlf -eofchar "\x1A \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5118,7 +5118,7 @@ test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5133,7 +5133,7 @@ test io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1A + fconfigure $f -translation lf -eofchar "\x1A \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5148,7 +5148,7 @@ test io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5163,7 +5163,7 @@ test io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1A + fconfigure $f -translation cr -eofchar "\x1A \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5178,7 +5178,7 @@ test io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5193,7 +5193,7 @@ test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1A + fconfigure $f -translation crlf -eofchar "\x1A \x1A" set l [string length [read $f]] set e [eof $f] close $f @@ -5216,12 +5216,12 @@ test io-35.18 {Tcl_Eof, eof char, cr write, crlf read} -body { test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} -body { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar \x1A + fconfigure $f -translation cr -eofchar "\x1A \x1A" puts $f abc\ndef close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1A + fconfigure $f -translation crlf -eofchar "\x1A \x1A" set l [string length [set in [read $f]]] set e [eof $f] close $f @@ -5230,12 +5230,12 @@ test io-35.18a {Tcl_Eof, eof char, cr write, crlf read} -body { test io-35.18b {Tcl_Eof, eof char, cr write, crlf read} -body { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar \x1A + fconfigure $f -translation cr -eofchar "\x1A \x1A" puts $f {} close $f set s [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1A + fconfigure $f -translation crlf -eofchar "\x1A \x1A" set l [string length [set in [read $f]]] set e [eof $f] close $f @@ -5264,7 +5264,7 @@ test io-35.19 {Tcl_Eof, eof char in middle, cr write, crlf read} -body { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1A + fconfigure $f -translation crlf -eofchar "\x1A \x1A" set l [string length [set in [read $f]]] set e [eof $f] close $f @@ -5279,7 +5279,7 @@ test io-35.20 {Tcl_Eof, eof char in middle, cr write, crlf read} { close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1A + fconfigure $f -translation crlf -eofchar "\x1A \x1A" set l [string length [set in [read $f]]] set e [eof $f] close $f @@ -5763,7 +5763,7 @@ test io-39.22 {Tcl_SetChannelOption, invariance} {unix} { lappend l [fconfigure $f1 -eofchar] fconfigure $f1 -eofchar {ON GO} lappend l [fconfigure $f1 -eofchar] - fconfigure $f1 -eofchar D + fconfigure $f1 -eofchar {D D} lappend l [fconfigure $f1 -eofchar] close $f1 set l @@ -5774,7 +5774,7 @@ test io-39.22a {Tcl_SetChannelOption, invariance} { set l [list] fconfigure $f1 -eofchar {ON GO} lappend l [fconfigure $f1 -eofchar] - fconfigure $f1 -eofchar D + fconfigure $f1 -eofchar {D D} lappend l [fconfigure $f1 -eofchar] lappend l [list [catch {fconfigure $f1 -eofchar {1 2 3}} msg] $msg] close $f1 @@ -6539,7 +6539,7 @@ test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fi set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6567,7 +6567,7 @@ test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {file set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6595,7 +6595,7 @@ test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {fi set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6623,7 +6623,7 @@ test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {file set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6651,7 +6651,7 @@ test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} { set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6679,7 +6679,7 @@ test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {fi set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1A + fconfigure $f -translation auto -eofchar "\x1A \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6707,7 +6707,7 @@ test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {filee set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1A + fconfigure $f -translation lf -eofchar "\x1A \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6735,7 +6735,7 @@ test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {fil set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1A + fconfigure $f -translation lf -eofchar "\x1A \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6763,7 +6763,7 @@ test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {filee set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1A + fconfigure $f -translation cr -eofchar "\x1A \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6791,7 +6791,7 @@ test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {fil set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1A + fconfigure $f -translation cr -eofchar "\x1A \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6819,7 +6819,7 @@ test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {f set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1A + fconfigure $f -translation crlf -eofchar "\x1A \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] @@ -6847,7 +6847,7 @@ test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {filee set c 0 set l "" set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1A + fconfigure $f -translation crlf -eofchar "\x1A \x1A" fileevent $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] -- cgit v0.12 From 4656afb575cda58ec7b6ce77f0a96b98173ca36d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 17 Oct 2022 19:44:08 +0000 Subject: More octal -> hex usage --- doc/Eval.3 | 6 ++-- doc/FileSystem.3 | 6 ++-- doc/Number.3 | 8 ++--- doc/source.n | 4 +-- doc/tclsh.1 | 8 ++--- generic/regc_lex.c | 4 +-- generic/regc_locale.c | 86 +++++++++++++++++++++++++-------------------------- generic/tclObj.c | 6 ++-- library/auto.tcl | 4 +-- library/init.tcl | 2 +- library/safe.tcl | 2 +- tools/genStubs.tcl | 2 +- 12 files changed, 64 insertions(+), 74 deletions(-) diff --git a/doc/Eval.3 b/doc/Eval.3 index 3ae0bce..02a8da5 100644 --- a/doc/Eval.3 +++ b/doc/Eval.3 @@ -99,13 +99,11 @@ its contents as a Tcl script. It returns the same information as If the file could not be read then a Tcl error is returned to describe why the file could not be read. The eofchar for files is -.QW \e32 +.QW \ex1A (^Z) for all platforms. If you require a .QW ^Z in code for string comparison, you can use -.QW \e032 -or -.QW \eu001a , +.QW \ex1A , which will be safely substituted by the Tcl interpreter into .QW ^Z . .PP diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index 4951ec5..e7cc4ab 100644 --- a/doc/FileSystem.3 +++ b/doc/FileSystem.3 @@ -425,14 +425,12 @@ reading the file contents. If the file could not be read then a Tcl error is returned to describe why the file could not be read. The eofchar for files is -.QW \e32 +.QW \ex1A (^Z) for all platforms. If you require a .QW ^Z in code for string comparison, you can use -.QW \e032 -or -.QW \eu001a , +.QW \ex1A , which will be safely substituted by the Tcl interpreter into .QW ^Z . \fBTcl_FSEvalFile\fR is a simpler version of diff --git a/doc/Number.3 b/doc/Number.3 index f93d75d..f405060 100644 --- a/doc/Number.3 +++ b/doc/Number.3 @@ -50,7 +50,7 @@ Tcl recognizes many values as numbers. Several examples include: \fB"1_000_000"\fR, \fB"4.0"\fR, \fB"1e-7"\fR, \fB"NaN"\fR, or \fB"Inf"\fR. When built-in Tcl commands act on these values as numbers, they are converted to a numeric representation for efficient handling in C code. Tcl makes -use of three C types to store these representations: \fBdouble\fR, +use of three C types to store these representations: \fBdouble\fR, \fBTcl_WideInt\fR, and \fBmp_int\fR. The \fBdouble\fR type is provided by the C language standard. The \fBTcl_WideInt\fR type is declared in the Tcl header file, \fBtcl.h\fR, and is equivalent to the C standard type @@ -76,7 +76,7 @@ If Tcl does recognize the examined value as a number, both routines return and \fItypePtr\fR (which may not be NULL) to report information the caller can use to retrieve the numeric representation. Both routines write to *\fIclientDataPtr\fR a pointer to the internal storage location -where Tcl holds the converted numeric value. +where Tcl holds the converted numeric value. .PP When the converted numeric value is stored as a \fBdouble\fR, a call to math library routine \fBisnan\fR determines whether that @@ -91,13 +91,13 @@ the \fBdouble\fR numeric value may be read through it. .PP When the converted numeric value is stored as a \fBTcl_WideInt\fR, both \fBTcl_GetNumber\fR and \fBTcl_GetNumberFromObj\fR write the -value \fBTCL_NUMBER_INT\fR to *\fItypePtr\fR. +value \fBTCL_NUMBER_INT\fR to *\fItypePtr\fR. The storage pointer may be cast to type \fBconst Tcl_WideInt *\fR and the \fBTcl_WideInt\fR numeric value may be read through it. .PP When the converted numeric value is stored as an \fBmp_int\fR, both \fBTcl_GetNumber\fR and \fBTcl_GetNumberFromObj\fR write the -value \fBTCL_NUMBER_BIG\fR to *\fItypePtr\fR. +value \fBTCL_NUMBER_BIG\fR to *\fItypePtr\fR. The storage pointer may be cast to type \fBconst mp_int *\fR and the \fBmp_int\fR numeric value may be read through it. .PP diff --git a/doc/source.n b/doc/source.n index 8757cb8..cee1312 100644 --- a/doc/source.n +++ b/doc/source.n @@ -37,9 +37,7 @@ allowing for files containing code and data segments (scripted documents). If you require a .QW ^Z in code for string comparison, you can use -.QW \e032 -or -.QW \eu001a , +.QW \ex1A , which will be safely substituted by the Tcl interpreter into .QW ^Z . .PP diff --git a/doc/tclsh.1 b/doc/tclsh.1 index 8dbacc0..3a78737 100644 --- a/doc/tclsh.1 +++ b/doc/tclsh.1 @@ -38,15 +38,11 @@ read Tcl commands from the named file; \fBtclsh\fR will exit when it reaches the end of the file. The end of the file may be marked either by the physical end of the medium, or by the character, -.QW \e032 -.PQ \eu001a ", control-Z" . +.PQ \ex1A ", control-Z" . If this character is present in the file, the \fBtclsh\fR application will read text up to but not including the character. An application that requires this character in the file may safely encode it as -.QW \e032 , -.QW \ex1A , -or -.QW \eu001a ; +.QW \ex1A ; or may generate it by use of commands such as \fBformat\fR or \fBbinary\fR. There is no automatic evaluation of \fB.tclshrc\fR when the name of a script file is presented on the \fBtclsh\fR command diff --git a/generic/regc_lex.c b/generic/regc_lex.c index bad91ce..eb068b4 100644 --- a/generic/regc_lex.c +++ b/generic/regc_lex.c @@ -775,7 +775,7 @@ lexescape( NOTE(REG_UNONPOSIX); switch (c) { case CHR('a'): - RETV(PLAIN, chrnamed(v, alert, ENDOF(alert), CHR('\007'))); + RETV(PLAIN, chrnamed(v, alert, ENDOF(alert), CHR('\x07'))); break; case CHR('A'): RETV(SBEGIN, 0); @@ -803,7 +803,7 @@ lexescape( break; case CHR('e'): NOTE(REG_UUNPORT); - RETV(PLAIN, chrnamed(v, esc, ENDOF(esc), CHR('\033'))); + RETV(PLAIN, chrnamed(v, esc, ENDOF(esc), CHR('\x1B'))); break; case CHR('f'): RETV(PLAIN, CHR('\f')); diff --git a/generic/regc_locale.c b/generic/regc_locale.c index e74b147..1ac04ef 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -16,49 +16,49 @@ static const struct cname { const char *name; const char code; } cnames[] = { - {"NUL", '\0'}, - {"SOH", '\001'}, - {"STX", '\002'}, - {"ETX", '\003'}, - {"EOT", '\004'}, - {"ENQ", '\005'}, - {"ACK", '\006'}, - {"BEL", '\007'}, - {"alert", '\007'}, - {"BS", '\010'}, - {"backspace", '\b'}, - {"HT", '\011'}, - {"tab", '\t'}, - {"LF", '\012'}, - {"newline", '\n'}, - {"VT", '\013'}, - {"vertical-tab", '\v'}, - {"FF", '\014'}, - {"form-feed", '\f'}, - {"CR", '\015'}, - {"carriage-return", '\r'}, - {"SO", '\016'}, - {"SI", '\017'}, - {"DLE", '\020'}, - {"DC1", '\021'}, - {"DC2", '\022'}, - {"DC3", '\023'}, - {"DC4", '\024'}, - {"NAK", '\025'}, - {"SYN", '\026'}, - {"ETB", '\027'}, - {"CAN", '\030'}, - {"EM", '\031'}, - {"SUB", '\032'}, - {"ESC", '\033'}, - {"IS4", '\034'}, - {"FS", '\034'}, - {"IS3", '\035'}, - {"GS", '\035'}, - {"IS2", '\036'}, - {"RS", '\036'}, - {"IS1", '\037'}, - {"US", '\037'}, + {"NUL", '\x00'}, + {"SOH", '\x01'}, + {"STX", '\x02'}, + {"ETX", '\x03'}, + {"EOT", '\x04'}, + {"ENQ", '\x05'}, + {"ACK", '\x06'}, + {"BEL", '\x07'}, + {"alert", '\x07'}, + {"BS", '\x08'}, + {"backspace", '\x08'}, + {"HT", '\x09'}, + {"tab", '\x09'}, + {"LF", '\x0A'}, + {"newline", '\x0A'}, + {"VT", '\x0B'}, + {"vertical-tab", '\x0B'}, + {"FF", '\x0C'}, + {"form-feed", '\x0C'}, + {"CR", '\x0D'}, + {"carriage-return", '\x0D'}, + {"SO", '\x0E'}, + {"SI", '\x0F'}, + {"DLE", '\x10'}, + {"DC1", '\x11'}, + {"DC2", '\x12'}, + {"DC3", '\x13'}, + {"DC4", '\x14'}, + {"NAK", '\x15'}, + {"SYN", '\x16'}, + {"ETB", '\x17'}, + {"CAN", '\x18'}, + {"EM", '\x19'}, + {"SUB", '\x1A'}, + {"ESC", '\x1B'}, + {"IS4", '\x1C'}, + {"FS", '\x1C'}, + {"IS3", '\x1D'}, + {"GS", '\x1D'}, + {"IS2", '\x1E'}, + {"RS", '\x1E'}, + {"IS1", '\x1F'}, + {"US", '\x1F'}, {"space", ' '}, {"exclamation-mark",'!'}, {"quotation-mark", '"'}, diff --git a/generic/tclObj.c b/generic/tclObj.c index 8970ab0..4a660b2 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -785,7 +785,7 @@ TclContinuationsGet( static void TclThreadFinalizeContLines( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { /* * Release the hashtable tracking invisible continuation lines. @@ -3956,7 +3956,7 @@ Tcl_GetNumber( Tcl_Interp *interp, const char *bytes, size_t numBytes, - ClientData *clientDataPtr, + void **clientDataPtr, int *typePtr) { static Tcl_ThreadDataKey numberCacheKey; @@ -4851,7 +4851,7 @@ SetCmdNameFromAny( int Tcl_RepresentationCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) diff --git a/library/auto.tcl b/library/auto.tcl index dc37328..3b1bb05 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -302,7 +302,7 @@ proc auto_mkindex_old {dir args} { set f "" set error [catch { set f [open $file] - fconfigure $f -encoding utf-8 -eofchar "\032 {}" + fconfigure $f -encoding utf-8 -eofchar "\x1A {}" while {[gets $f line] >= 0} { if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} { set procName [lindex [auto_qualify $procName "::"] 0] @@ -414,7 +414,7 @@ proc auto_mkindex_parser::mkindex {file} { set scriptFile $file set fid [open $file] - fconfigure $fid -encoding utf-8 -eofchar "\032 {}" + fconfigure $fid -encoding utf-8 -eofchar "\x1A {}" set contents [read $fid] close $fid diff --git a/library/init.tcl b/library/init.tcl index a879fe5..bbff158 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -442,7 +442,7 @@ proc auto_load_index {} { continue } else { set error [catch { - fconfigure $f -encoding utf-8 -eofchar "\032 {}" + fconfigure $f -encoding utf-8 -eofchar "\x1A {}" set id [gets $f] if {$id eq "# Tcl autoload index file, version 2.0"} { eval [read $f] diff --git a/library/safe.tcl b/library/safe.tcl index 2e04f8e..9050880 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -980,7 +980,7 @@ proc ::safe::AliasSource {child args} { set replacementMsg "script error" set code [catch { set f [open $realfile] - fconfigure $f -encoding $encoding -eofchar "\032 {}" + fconfigure $f -encoding $encoding -eofchar "\x1A {}" set contents [read $f] close $f ::interp eval $child [list info script $file] diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl index 282abcc..89e4ccc 100644 --- a/tools/genStubs.tcl +++ b/tools/genStubs.tcl @@ -257,7 +257,7 @@ proc genStubs::rewriteFile {file text} { return } set in [open ${file} r] - fconfigure $in -eofchar "\032 {}" -encoding utf-8 + fconfigure $in -eofchar "\x1A {}" -encoding utf-8 set out [open ${file}.new w] fconfigure $out -translation lf -encoding utf-8 -- cgit v0.12 From 39c9836950691a1ae7c2735760a80af66f8edc4a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 18 Oct 2022 10:12:51 +0000 Subject: Allow any single character for -eofchar, even if it's not a valid list --- generic/tclIO.c | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 23b860a..374f770 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8061,7 +8061,7 @@ Tcl_SetChannelOption( /* State info for channel */ size_t len; /* Length of optionName string. */ size_t argc; - const char **argv; + const char **argv = NULL; /* * If the channel is in the middle of a background copy, fail. @@ -8177,10 +8177,13 @@ Tcl_SetChannelOption( UpdateInterest(chanPtr); return TCL_OK; } else if (HaveOpt(2, "-eofchar")) { - if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { + if (!newValue[0] || (!(newValue[0] & 0x80) && !newValue[1])) { + if (GotFlag(statePtr, TCL_READABLE)) { + statePtr->inEofChar = newValue[0]; + } + } else if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; - } - if (argc == 0) { + } else if (argc == 0) { statePtr->inEofChar = 0; } else if (argc == 1 || argc == 2) { int inValue = (int) argv[0][0]; -- cgit v0.12 From 842fb667f5a79b8f11cac96c4a029b509ed5ed22 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 18 Oct 2022 10:25:35 +0000 Subject: Allow any single character for -eofchar, even if it's not a valid list --- generic/tclIO.c | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 32a03b0..4002934 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4655,7 +4655,8 @@ Tcl_GetsObj( ChannelState *statePtr = chanPtr->state; /* State info for channel */ ChannelBuffer *bufPtr; - int inEofChar, skip, copiedTotal, oldLength, oldFlags, oldRemoved; + int inEofChar, skip, copiedTotal, oldFlags, oldRemoved; + int oldLength; Tcl_Encoding encoding; char *dst, *dstEnd, *eol, *eof; Tcl_EncodingState oldState; @@ -8156,7 +8157,7 @@ Tcl_SetChannelOption( /* State info for channel */ size_t len; /* Length of optionName string. */ int argc; - const char **argv; + const char **argv = NULL; /* * If the channel is in the middle of a background copy, fail. @@ -8262,10 +8263,14 @@ Tcl_SetChannelOption( UpdateInterest(chanPtr); return TCL_OK; } else if (HaveOpt(2, "-eofchar")) { - if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { + if (!newValue[0] || (!(newValue[0] & 0x80) && !newValue[1])) { + if (GotFlag(statePtr, TCL_READABLE)) { + statePtr->inEofChar = newValue[0]; + } + statePtr->outEofChar = 0; + } else if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; - } - if (argc == 0) { + } else if (argc == 0) { statePtr->inEofChar = 0; statePtr->outEofChar = 0; } else if (argc == 1 || argc == 2) { -- cgit v0.12 From 59dd8794c5be3c6fd398c50a80526921947220ef Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 18 Oct 2022 13:35:53 +0000 Subject: Change the default for AutoPathSync in Tcl 9.0 (as described in TIP #579) --- library/safe.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/safe.tcl b/library/safe.tcl index 0c09aa4..ab97b8f 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -1419,7 +1419,7 @@ namespace eval ::safe { # Set to 1 for "traditional" behavior: a child's entire access path and # module path are copied to its ::auto_path, which is updated whenever # the user calls ::safe::interpAddToAccessPath to add to the access path. - variable AutoPathSync 1 + variable AutoPathSync 0 # Log command, set via 'setLogCmd'. Logging is disabled when empty. variable Log {} -- cgit v0.12 From c0b6a93d8fe6016ad657a4dfce0bbeffa0b7f86a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 18 Oct 2022 14:42:27 +0000 Subject: Fix [20157fbd14]: Failed tests safe-9.[67], since "-autoPath" is added --- tests/safe.test | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/safe.test b/tests/safe.test index a128f3e..a4f8df0 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -734,10 +734,10 @@ test safe-9.6 {interpConfigure widget like behaviour} -body { safe::interpConfigure $i] } -cleanup { safe::interpDelete $i -} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}}\ - {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ - {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\ - {-accessPath * -statics 0 -nested 0 -deleteHook toto}} +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar} -autoPath *}\ + {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ + {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar} -autoPath *}\ + {-accessPath * -statics 0 -nested 0 -deleteHook toto -autoPath *}} test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { # this test shall work, believed equivalent to 9.6 set i [safe::interpCreate \ @@ -759,10 +759,10 @@ test safe-9.7 {interpConfigure widget like behaviour (demystified)} -body { } -cleanup { safe::interpDelete $i unset -nocomplain a b c d e f g i -} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar}}\ - {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ - {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar}}\ - {-accessPath * -statics 0 -nested 0 -deleteHook toto}} +} -match glob -result {{-accessPath * -statics 0 -nested 1 -deleteHook {foo bar} -autoPath *}\ + {-accessPath *} {-nested 1} {-statics 0} {-deleteHook {foo bar}}\ + {-accessPath * -statics 1 -nested 1 -deleteHook {foo bar} -autoPath *}\ + {-accessPath * -statics 0 -nested 0 -deleteHook toto -autoPath *}} test safe-9.8 {autoloading commands indexed in tclIndex files, Sync Mode on} -setup { set SyncExists [expr {[info commands ::safe::setSyncMode] ne {}}] if {$SyncExists} { -- cgit v0.12 From c84fb00aedcd917b0e97548c3c1060d3f945420c Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 18 Oct 2022 19:37:44 +0000 Subject: Draft updates to changes file for 8.6.13 release. --- changes | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) diff --git a/changes b/changes index fba75e3..6d2392f 100644 --- a/changes +++ b/changes @@ -9116,3 +9116,54 @@ See RFC 2045 2021-10-27 tzdata updated to Olson's tzdata2021e (nijtmans) - Released 8.6.12, Nov 5, 2021 - details at https://core.tcl-lang.org/tcl/ - + +2021-12-08 (update) tcltest package to version 2.5.4 + +2022-01-13 (bug)[26f132] Crash when sizeof(int) < sizeof(void *) (Plan 9 port) + +2022-01-19 (TIP 623)[e9a271] Tcl_GetRange index args < 0 (petasis,nijtmans) + +2022-03-08 (bug) test string-5.22 (porter) + +2022-03-11 (bug)[8a7ec8] fat binary compile on Mac M1 (davis, nijtmans) + +2022-04-04 (bug)[e5ed1b] numeric IPv6 in URLs (nijtmans) +=> http 2.9.6 + +2022-04-26 (bug)[27520c] test error-9.6 (goth,sebres) + +2022-05-04 (bug)[8eb64b] http package support for Content-encoding: br + +2022-05-11 (bug)[6898f9] http package failed detection of shiftjis charset + +2022-05-25 (bug)[76ad7a] tests string-6.13[23] (mistachkin, nijtmans) + +2022-06-20 (bug)[55bf73] Avoid connection reuse after response code 101. +=> http 2.9.8 + +2022-07-22 (bug)[713653] FP rounding exposed by x86 musl (rubicon,sebres) + +2022-07-22 More portable notation of microseconds in verbose output (sebres) +=> tcltest 2.5.5 + +2022-07-27 (bug)[b3977d] Process CR-LF split across packets (nadkarni,sebres) + +2022-07-29 (bug)[4eb3a1] crash due to undetected bytecode invalidity (nadkarni) + +2022-08-23 (new)[371080] Portability to CHERI-enabled Morello processor (jrtc27) + +2022-09-06 (bug)[55a02f] Fallback init env(HOME) from USERPROFILE (nadkarni) + +2022-09-13 (bug)[1073da] crash writing invalid utf-8 (nijtmans) + +2022-09-14 (new) Update to Unicode-15 (nijtmans) + +2022-10-14 tzdata updated to Olson's tzdata2022e (nijtmans) + +Update bundled zlib to 1.2.12 + +Update bundled libtommath + +Many code fixes to avoid overflow or undefined behavior. Thanks chrstphrchvz. + +- Released 8.6.13, Oct 28, 2022 - details at https://core.tcl-lang.org/tcl/ - -- cgit v0.12 From 6a9dc785dc6069702330f2a6ec66b1717afbfbd7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 18 Oct 2022 20:24:43 +0000 Subject: Update to zlib-1.2.13 --- compat/zlib/CMakeLists.txt | 42 +--- compat/zlib/ChangeLog | 24 ++- compat/zlib/Makefile.in | 20 +- compat/zlib/README | 4 +- compat/zlib/compress.c | 6 +- compat/zlib/configure | 94 ++++---- compat/zlib/contrib/README.contrib | 2 +- compat/zlib/contrib/delphi/ZLib.pas | 2 +- compat/zlib/contrib/dotzlib/DotZLib/UnitTests.cs | 2 +- compat/zlib/contrib/infback9/inftree9.c | 4 +- compat/zlib/contrib/infback9/inftree9.h | 2 +- compat/zlib/contrib/minizip/configure.ac | 2 +- compat/zlib/contrib/minizip/crypt.h | 2 +- compat/zlib/contrib/minizip/ioapi.c | 28 ++- compat/zlib/contrib/minizip/ioapi.h | 2 +- compat/zlib/contrib/minizip/miniunz.c | 2 +- compat/zlib/contrib/minizip/unzip.c | 4 +- compat/zlib/contrib/minizip/zip.c | 7 +- compat/zlib/contrib/pascal/zlibpas.pas | 2 +- compat/zlib/contrib/puff/README | 2 +- compat/zlib/contrib/puff/puff.c | 4 +- compat/zlib/contrib/puff/pufftest.c | 2 +- compat/zlib/contrib/vstudio/readme.txt | 5 +- .../contrib/vstudio/vc10/miniunz.vcxproj.filters | 2 +- .../contrib/vstudio/vc10/minizip.vcxproj.filters | 2 +- compat/zlib/contrib/vstudio/vc10/testzlib.vcxproj | 24 +-- .../contrib/vstudio/vc10/testzlib.vcxproj.filters | 5 +- .../vstudio/vc10/testzlibdll.vcxproj.filters | 2 +- compat/zlib/contrib/vstudio/vc10/zlib.rc | 6 +- compat/zlib/contrib/vstudio/vc10/zlibstat.vcxproj | 50 ++--- .../contrib/vstudio/vc10/zlibstat.vcxproj.filters | 3 - compat/zlib/contrib/vstudio/vc10/zlibvc.sln | 2 +- compat/zlib/contrib/vstudio/vc10/zlibvc.vcxproj | 58 ++--- .../contrib/vstudio/vc10/zlibvc.vcxproj.filters | 3 - compat/zlib/contrib/vstudio/vc11/testzlib.vcxproj | 24 +-- compat/zlib/contrib/vstudio/vc11/zlib.rc | 6 +- compat/zlib/contrib/vstudio/vc11/zlibstat.vcxproj | 34 ++- compat/zlib/contrib/vstudio/vc11/zlibvc.sln | 2 +- compat/zlib/contrib/vstudio/vc11/zlibvc.vcxproj | 58 ++--- compat/zlib/contrib/vstudio/vc12/testzlib.vcxproj | 24 +-- compat/zlib/contrib/vstudio/vc12/zlib.rc | 6 +- compat/zlib/contrib/vstudio/vc12/zlibstat.vcxproj | 34 ++- compat/zlib/contrib/vstudio/vc12/zlibvc.sln | 238 ++++++++++----------- compat/zlib/contrib/vstudio/vc12/zlibvc.vcxproj | 58 ++--- compat/zlib/contrib/vstudio/vc14/testzlib.vcxproj | 24 +-- compat/zlib/contrib/vstudio/vc14/zlib.rc | 6 +- compat/zlib/contrib/vstudio/vc14/zlibstat.vcxproj | 34 ++- compat/zlib/contrib/vstudio/vc14/zlibvc.sln | 238 ++++++++++----------- compat/zlib/contrib/vstudio/vc14/zlibvc.vcxproj | 58 ++--- compat/zlib/contrib/vstudio/vc9/miniunz.vcproj | 2 +- compat/zlib/contrib/vstudio/vc9/minizip.vcproj | 2 +- compat/zlib/contrib/vstudio/vc9/testzlib.vcproj | 66 +----- compat/zlib/contrib/vstudio/vc9/testzlibdll.vcproj | 2 +- compat/zlib/contrib/vstudio/vc9/zlib.rc | 6 +- compat/zlib/contrib/vstudio/vc9/zlibstat.vcproj | 76 +------ compat/zlib/contrib/vstudio/vc9/zlibvc.sln | 2 +- compat/zlib/contrib/vstudio/vc9/zlibvc.vcproj | 82 ++----- compat/zlib/crc32.c | 25 ++- compat/zlib/deflate.c | 218 ++++++++++--------- compat/zlib/examples/enough.c | 2 +- compat/zlib/examples/fitblk.c | 4 +- compat/zlib/examples/gun.c | 2 +- compat/zlib/examples/gzappend.c | 4 +- compat/zlib/examples/gzlog.h | 2 +- compat/zlib/examples/zran.c | 2 +- compat/zlib/gzlib.c | 2 +- compat/zlib/gzread.c | 8 +- compat/zlib/gzwrite.c | 2 +- compat/zlib/infback.c | 17 +- compat/zlib/inflate.c | 7 +- compat/zlib/inftrees.c | 4 +- compat/zlib/inftrees.h | 2 +- compat/zlib/make_vms.com | 4 +- compat/zlib/os400/README400 | 6 +- compat/zlib/os400/bndsrc | 8 + compat/zlib/os400/zlib.inc | 6 +- compat/zlib/qnx/package.qpg | 10 +- compat/zlib/test/example.c | 3 +- compat/zlib/test/minigzip.c | 2 +- compat/zlib/treebuild.xml | 4 +- compat/zlib/trees.c | 117 +++++----- compat/zlib/uncompr.c | 4 +- compat/zlib/win32/README-WIN32.txt | 4 +- compat/zlib/win32/zlib1.rc | 2 +- compat/zlib/zconf.h | 19 +- compat/zlib/zconf.h.cmakein | 19 +- compat/zlib/zconf.h.in | 19 +- compat/zlib/zlib.3 | 4 +- compat/zlib/zlib.3.pdf | Bin 8848 -> 19366 bytes compat/zlib/zlib.h | 20 +- compat/zlib/zlib2ansi | 4 +- compat/zlib/zutil.c | 16 +- compat/zlib/zutil.h | 1 + 93 files changed, 874 insertions(+), 1202 deletions(-) diff --git a/compat/zlib/CMakeLists.txt b/compat/zlib/CMakeLists.txt index e6fbb37..b412dc7 100644 --- a/compat/zlib/CMakeLists.txt +++ b/compat/zlib/CMakeLists.txt @@ -3,10 +3,7 @@ set(CMAKE_ALLOW_LOOSE_LOOP_CONSTRUCTS ON) project(zlib C) -set(VERSION "1.2.12") - -option(ASM686 "Enable building i686 assembly implementation") -option(AMD64 "Enable building amd64 assembly implementation") +set(VERSION "1.2.13") set(INSTALL_BIN_DIR "${CMAKE_INSTALL_PREFIX}/bin" CACHE PATH "Installation directory for executables") set(INSTALL_LIB_DIR "${CMAKE_INSTALL_PREFIX}/lib" CACHE PATH "Installation directory for libraries") @@ -129,39 +126,6 @@ if(NOT MINGW) ) endif() -if(CMAKE_COMPILER_IS_GNUCC) - if(ASM686) - set(ZLIB_ASMS contrib/asm686/match.S) - elseif (AMD64) - set(ZLIB_ASMS contrib/amd64/amd64-match.S) - endif () - - if(ZLIB_ASMS) - add_definitions(-DASMV) - set_source_files_properties(${ZLIB_ASMS} PROPERTIES LANGUAGE C COMPILE_FLAGS -DNO_UNDERLINE) - endif() -endif() - -if(MSVC) - if(ASM686) - ENABLE_LANGUAGE(ASM_MASM) - set(ZLIB_ASMS - contrib/masmx86/inffas32.asm - contrib/masmx86/match686.asm - ) - elseif (AMD64) - ENABLE_LANGUAGE(ASM_MASM) - set(ZLIB_ASMS - contrib/masmx64/gvmat64.asm - contrib/masmx64/inffasx64.asm - ) - endif() - - if(ZLIB_ASMS) - add_definitions(-DASMV -DASMINF) - endif() -endif() - # parse the full version number from zlib.h and include in ZLIB_FULL_VERSION file(READ ${CMAKE_CURRENT_SOURCE_DIR}/zlib.h _zlib_h_contents) string(REGEX REPLACE ".*#define[ \t]+ZLIB_VERSION[ \t]+\"([-0-9A-Za-z.]+)\".*" @@ -183,8 +147,8 @@ if(MINGW) set(ZLIB_DLL_SRCS ${CMAKE_CURRENT_BINARY_DIR}/zlib1rc.obj) endif(MINGW) -add_library(zlib SHARED ${ZLIB_SRCS} ${ZLIB_ASMS} ${ZLIB_DLL_SRCS} ${ZLIB_PUBLIC_HDRS} ${ZLIB_PRIVATE_HDRS}) -add_library(zlibstatic STATIC ${ZLIB_SRCS} ${ZLIB_ASMS} ${ZLIB_PUBLIC_HDRS} ${ZLIB_PRIVATE_HDRS}) +add_library(zlib SHARED ${ZLIB_SRCS} ${ZLIB_DLL_SRCS} ${ZLIB_PUBLIC_HDRS} ${ZLIB_PRIVATE_HDRS}) +add_library(zlibstatic STATIC ${ZLIB_SRCS} ${ZLIB_PUBLIC_HDRS} ${ZLIB_PRIVATE_HDRS}) set_target_properties(zlib PROPERTIES DEFINE_SYMBOL ZLIB_DLL) set_target_properties(zlib PROPERTIES SOVERSION 1) diff --git a/compat/zlib/ChangeLog b/compat/zlib/ChangeLog index f0b0e61..457526b 100644 --- a/compat/zlib/ChangeLog +++ b/compat/zlib/ChangeLog @@ -1,6 +1,18 @@ ChangeLog file for zlib +Changes in 1.2.13 (13 Oct 2022) +- Fix configure issue that discarded provided CC definition +- Correct incorrect inputs provided to the CRC functions +- Repair prototypes and exporting of new CRC functions +- Fix inflateBack to detect invalid input with distances too far +- Have infback() deliver all of the available output up to any error +- Fix a bug when getting a gzip header extra field with inflate() +- Fix bug in block type selection when Z_FIXED used +- Tighten deflateBound bounds +- Remove deleted assembler code references +- Various portability and appearance improvements + Changes in 1.2.12 (27 Mar 2022) - Cygwin does not have _wopen(), so do not create gzopen_w() there - Permit a deflateParams() parameter change as soon as possible @@ -159,7 +171,7 @@ Changes in 1.2.7.1 (24 Mar 2013) - Fix types in contrib/minizip to match result of get_crc_table() - Simplify contrib/vstudio/vc10 with 'd' suffix - Add TOP support to win32/Makefile.msc -- Suport i686 and amd64 assembler builds in CMakeLists.txt +- Support i686 and amd64 assembler builds in CMakeLists.txt - Fix typos in the use of _LARGEFILE64_SOURCE in zconf.h - Add vc11 and vc12 build files to contrib/vstudio - Add gzvprintf() as an undocumented function in zlib @@ -359,14 +371,14 @@ Changes in 1.2.5.1 (10 Sep 2011) - Use u4 type for crc_table to avoid conversion warnings - Apply casts in zlib.h to avoid conversion warnings - Add OF to prototypes for adler32_combine_ and crc32_combine_ [Miller] -- Improve inflateSync() documentation to note indeterminancy +- Improve inflateSync() documentation to note indeterminacy - Add deflatePending() function to return the amount of pending output - Correct the spelling of "specification" in FAQ [Randers-Pehrson] - Add a check in configure for stdarg.h, use for gzprintf() - Check that pointers fit in ints when gzprint() compiled old style - Add dummy name before $(SHAREDLIBV) in Makefile [Bar-Lev, Bowler] - Delete line in configure that adds -L. libz.a to LDFLAGS [Weigelt] -- Add debug records in assmebler code [Londer] +- Add debug records in assembler code [Londer] - Update RFC references to use http://tools.ietf.org/html/... [Li] - Add --archs option, use of libtool to configure for Mac OS X [Borstel] @@ -1033,7 +1045,7 @@ Changes in 1.2.0.1 (17 March 2003) - Include additional header file on VMS for off_t typedef - Try to use _vsnprintf where it supplants vsprintf [Vollant] - Add some casts in inffast.c -- Enchance comments in zlib.h on what happens if gzprintf() tries to +- Enhance comments in zlib.h on what happens if gzprintf() tries to write more than 4095 bytes before compression - Remove unused state from inflateBackEnd() - Remove exit(0) from minigzip.c, example.c @@ -1211,7 +1223,7 @@ Changes in 1.0.9 (17 Feb 1998) - Avoid gcc 2.8.0 comparison bug a little differently than zlib 1.0.8 - in inftrees.c, avoid cc -O bug on HP (Farshid Elahi) - in zconf.h move the ZLIB_DLL stuff earlier to avoid problems with - the declaration of FAR (Gilles VOllant) + the declaration of FAR (Gilles Vollant) - install libz.so* with mode 755 (executable) instead of 644 (Marc Lehmann) - read_buf buf parameter of type Bytef* instead of charf* - zmemcpy parameters are of type Bytef*, not charf* (Joseph Strout) @@ -1567,7 +1579,7 @@ Changes in 0.4: - renamed deflateOptions as deflateInit2, call one or the other but not both - added the method parameter for deflateInit2 - added inflateInit2 -- simplied considerably deflateInit and inflateInit by not supporting +- simplified considerably deflateInit and inflateInit by not supporting user-provided history buffer. This is supported only in deflateInit2 and inflateInit2 diff --git a/compat/zlib/Makefile.in b/compat/zlib/Makefile.in index 3d858aa..7d2713f 100644 --- a/compat/zlib/Makefile.in +++ b/compat/zlib/Makefile.in @@ -7,10 +7,6 @@ # Normally configure builds both a static and a shared library. # If you want to build just a static library, use: ./configure --static -# To use the asm code, type: -# cp contrib/asm?86/match.S ./match.S -# make LOC=-DASMV OBJA=match.o - # To install /usr/local/lib/libz.* and /usr/local/include/zlib.h, type: # make install # To install in $HOME instead of /usr/local, use: @@ -26,13 +22,13 @@ CFLAGS=-O SFLAGS=-O LDFLAGS= -TEST_LDFLAGS=-L. libz.a +TEST_LDFLAGS=$(LDFLAGS) -L. libz.a LDSHARED=$(CC) CPP=$(CC) -E STATICLIB=libz.a SHAREDLIB=libz.so -SHAREDLIBV=libz.so.1.2.12 +SHAREDLIBV=libz.so.1.2.13 SHAREDLIBM=libz.so.1 LIBS=$(STATICLIB) $(SHAREDLIBV) @@ -87,7 +83,7 @@ test: all teststatic testshared teststatic: static @TMPST=tmpst_$$; \ - if echo hello world | ./minigzip | ./minigzip -d && ./example $$TMPST ; then \ + if echo hello world | ${QEMU_RUN} ./minigzip | ${QEMU_RUN} ./minigzip -d && ${QEMU_RUN} ./example $$TMPST ; then \ echo ' *** zlib test OK ***'; \ else \ echo ' *** zlib test FAILED ***'; false; \ @@ -100,7 +96,7 @@ testshared: shared DYLD_LIBRARY_PATH=`pwd`:$(DYLD_LIBRARY_PATH) ; export DYLD_LIBRARY_PATH; \ SHLIB_PATH=`pwd`:$(SHLIB_PATH) ; export SHLIB_PATH; \ TMPSH=tmpsh_$$; \ - if echo hello world | ./minigzipsh | ./minigzipsh -d && ./examplesh $$TMPSH; then \ + if echo hello world | ${QEMU_RUN} ./minigzipsh | ${QEMU_RUN} ./minigzipsh -d && ${QEMU_RUN} ./examplesh $$TMPSH; then \ echo ' *** zlib shared test OK ***'; \ else \ echo ' *** zlib shared test FAILED ***'; false; \ @@ -109,7 +105,7 @@ testshared: shared test64: all64 @TMP64=tmp64_$$; \ - if echo hello world | ./minigzip64 | ./minigzip64 -d && ./example64 $$TMP64; then \ + if echo hello world | ${QEMU_RUN} ./minigzip64 | ${QEMU_RUN} ./minigzip64 -d && ${QEMU_RUN} ./example64 $$TMP64; then \ echo ' *** zlib 64-bit test OK ***'; \ else \ echo ' *** zlib 64-bit test FAILED ***'; false; \ @@ -124,7 +120,7 @@ infcover: infcover.o libz.a cover: infcover rm -f *.gcda - ./infcover + ${QEMU_RUN} ./infcover gcov inf*.c libz.a: $(OBJS) @@ -292,10 +288,10 @@ minigzip$(EXE): minigzip.o $(STATICLIB) $(CC) $(CFLAGS) -o $@ minigzip.o $(TEST_LDFLAGS) examplesh$(EXE): example.o $(SHAREDLIBV) - $(CC) $(CFLAGS) -o $@ example.o -L. $(SHAREDLIBV) + $(CC) $(CFLAGS) -o $@ example.o $(LDFLAGS) -L. $(SHAREDLIBV) minigzipsh$(EXE): minigzip.o $(SHAREDLIBV) - $(CC) $(CFLAGS) -o $@ minigzip.o -L. $(SHAREDLIBV) + $(CC) $(CFLAGS) -o $@ minigzip.o $(LDFLAGS) -L. $(SHAREDLIBV) example64$(EXE): example64.o $(STATICLIB) $(CC) $(CFLAGS) -o $@ example64.o $(TEST_LDFLAGS) diff --git a/compat/zlib/README b/compat/zlib/README index 024b79d..ba34d18 100644 --- a/compat/zlib/README +++ b/compat/zlib/README @@ -1,6 +1,6 @@ ZLIB DATA COMPRESSION LIBRARY -zlib 1.2.12 is a general purpose data compression library. All the code is +zlib 1.2.13 is a general purpose data compression library. All the code is thread safe. The data format used by the zlib library is described by RFCs (Request for Comments) 1950 to 1952 in the files http://tools.ietf.org/html/rfc1950 (zlib format), rfc1951 (deflate format) and @@ -31,7 +31,7 @@ Mark Nelson wrote an article about zlib for the Jan. 1997 issue of Dr. Dobb's Journal; a copy of the article is available at http://marknelson.us/1997/01/01/zlib-engine/ . -The changes made in version 1.2.12 are documented in the file ChangeLog. +The changes made in version 1.2.13 are documented in the file ChangeLog. Unsupported third party contributions are provided in directory contrib/ . diff --git a/compat/zlib/compress.c b/compat/zlib/compress.c index e2db404..2ad5326 100644 --- a/compat/zlib/compress.c +++ b/compat/zlib/compress.c @@ -19,7 +19,7 @@ memory, Z_BUF_ERROR if there was not enough room in the output buffer, Z_STREAM_ERROR if the level parameter is invalid. */ -int ZEXPORT compress2 (dest, destLen, source, sourceLen, level) +int ZEXPORT compress2(dest, destLen, source, sourceLen, level) Bytef *dest; uLongf *destLen; const Bytef *source; @@ -65,7 +65,7 @@ int ZEXPORT compress2 (dest, destLen, source, sourceLen, level) /* =========================================================================== */ -int ZEXPORT compress (dest, destLen, source, sourceLen) +int ZEXPORT compress(dest, destLen, source, sourceLen) Bytef *dest; uLongf *destLen; const Bytef *source; @@ -78,7 +78,7 @@ int ZEXPORT compress (dest, destLen, source, sourceLen) If the default memLevel or windowBits for deflateInit() is changed, then this function needs to be updated. */ -uLong ZEXPORT compressBound (sourceLen) +uLong ZEXPORT compressBound(sourceLen) uLong sourceLen; { return sourceLen + (sourceLen >> 12) + (sourceLen >> 14) + diff --git a/compat/zlib/configure b/compat/zlib/configure index 3fa3e86..fa4d5da 100755 --- a/compat/zlib/configure +++ b/compat/zlib/configure @@ -32,8 +32,11 @@ fi # set command prefix for cross-compilation if [ -n "${CHOST}" ]; then - uname="`echo "${CHOST}" | sed -e 's/^[^-]*-\([^-]*\)$/\1/' -e 's/^[^-]*-[^-]*-\([^-]*\)$/\1/' -e 's/^[^-]*-[^-]*-\([^-]*\)-.*$/\1/'`" + uname=${CHOST} + mname=${CHOST} CROSS_PREFIX="${CHOST}-" +else + mname=`(uname -a || echo unknown) 2>/dev/null` fi # destination name for static library @@ -178,8 +181,6 @@ else cc=${CC} fi -cflags=${CFLAGS-"-O3"} -# to force the asm version use: CFLAGS="-O3 -DASMV" ./configure case "$cc" in *gcc*) gcc=1 ;; *clang*) gcc=1 ;; @@ -205,13 +206,13 @@ if test "$gcc" -eq 1 && ($cc -c $test.c) >> configure.log 2>&1; then fi if test "$warn" -eq 1; then if test "$zconst" -eq 1; then - CFLAGS="${CFLAGS} -Wall -Wextra -Wcast-qual -pedantic -DZLIB_CONST" + CFLAGS="${CFLAGS} -Wall -Wextra -Wcast-qual -DZLIB_CONST" else - CFLAGS="${CFLAGS} -Wall -Wextra -pedantic" + CFLAGS="${CFLAGS} -Wall -Wextra" fi fi if test $sanitize -eq 1; then - CFLAGS="${CFLAGS} -fsanitize=address" + CFLAGS="${CFLAGS} -g -fsanitize=address" fi if test $debug -eq 1; then CFLAGS="${CFLAGS} -DZLIB_DEBUG" @@ -221,47 +222,52 @@ if test "$gcc" -eq 1 && ($cc -c $test.c) >> configure.log 2>&1; then uname=`(uname -s || echo unknown) 2>/dev/null` fi case "$uname" in - Linux* | linux* | GNU | GNU/* | solaris*) + Linux* | linux* | *-linux* | GNU | GNU/* | solaris*) + case "$mname" in + *sparc*) + LDFLAGS="${LDFLAGS} -Wl,--no-warn-rwx-segments" ;; + esac LDSHARED=${LDSHARED-"$cc -shared -Wl,-soname,libz.so.1,--version-script,${SRCDIR}zlib.map"} ;; *BSD | *bsd* | DragonFly) LDSHARED=${LDSHARED-"$cc -shared -Wl,-soname,libz.so.1,--version-script,${SRCDIR}zlib.map"} LDCONFIG="ldconfig -m" ;; - CYGWIN* | Cygwin* | cygwin* | OS/2*) + CYGWIN* | Cygwin* | cygwin* | *-cygwin* | OS/2*) EXE='.exe' ;; - MINGW* | mingw*) -# temporary bypass + MINGW* | mingw* | *-mingw*) rm -f $test.[co] $test $test$shared_ext - echo "Please use win32/Makefile.gcc instead." | tee -a configure.log - leave 1 + echo "If this doesn't work for you, try win32/Makefile.gcc." | tee -a configure.log LDSHARED=${LDSHARED-"$cc -shared"} LDSHAREDLIBC="" EXE='.exe' ;; - QNX*) # This is for QNX6. I suppose that the QNX rule below is for QNX2,QNX4 - # (alain.bonnefoy@icbt.com) - LDSHARED=${LDSHARED-"$cc -shared -Wl,-hlibz.so.1"} ;; + QNX*) # This is for QNX6. I suppose that the QNX rule below is for QNX2,QNX4 + # (alain.bonnefoy@icbt.com) + LDSHARED=${LDSHARED-"$cc -shared -Wl,-hlibz.so.1"} ;; HP-UX*) - LDSHARED=${LDSHARED-"$cc -shared $SFLAGS"} - case `(uname -m || echo unknown) 2>/dev/null` in - ia64) - shared_ext='.so' - SHAREDLIB='libz.so' ;; - *) - shared_ext='.sl' - SHAREDLIB='libz.sl' ;; - esac ;; - Darwin* | darwin*) - shared_ext='.dylib' - SHAREDLIB=libz$shared_ext - SHAREDLIBV=libz.$VER$shared_ext - SHAREDLIBM=libz.$VER1$shared_ext - LDSHARED=${LDSHARED-"$cc -dynamiclib -install_name $libdir/$SHAREDLIBM -compatibility_version $VER1 -current_version $VER3"} - if libtool -V 2>&1 | grep Apple > /dev/null; then - AR="libtool" - else - AR="/usr/bin/libtool" - fi - ARFLAGS="-o" ;; - *) LDSHARED=${LDSHARED-"$cc -shared"} ;; + LDSHARED=${LDSHARED-"$cc -shared $SFLAGS"} + case `(uname -m || echo unknown) 2>/dev/null` in + ia64) + shared_ext='.so' + SHAREDLIB='libz.so' ;; + *) + shared_ext='.sl' + SHAREDLIB='libz.sl' ;; + esac ;; + AIX*) + LDFLAGS="${LDFLAGS} -Wl,-brtl" ;; + Darwin* | darwin* | *-darwin*) + shared_ext='.dylib' + SHAREDLIB=libz$shared_ext + SHAREDLIBV=libz.$VER$shared_ext + SHAREDLIBM=libz.$VER1$shared_ext + LDSHARED=${LDSHARED-"$cc -dynamiclib -install_name $libdir/$SHAREDLIBM -compatibility_version $VER1 -current_version $VER3"} + if libtool -V 2>&1 | grep Apple > /dev/null; then + AR="libtool" + else + AR="/usr/bin/libtool" + fi + ARFLAGS="-o" ;; + *) + LDSHARED=${LDSHARED-"$cc -shared"} ;; esac else # find system name and corresponding cc options @@ -453,20 +459,6 @@ else TEST="all teststatic testshared" fi -# check for underscores in external names for use by assembler code -CPP=${CPP-"$CC -E"} -case $CFLAGS in - *ASMV*) - echo >> configure.log - show "$NM $test.o | grep _hello" - if test "`$NM $test.o | grep _hello | tee -a configure.log`" = ""; then - CPP="$CPP -DNO_UNDERLINE" - echo Checking for underline in external names... No. | tee -a configure.log - else - echo Checking for underline in external names... Yes. | tee -a configure.log - fi ;; -esac - echo >> configure.log # check for size_t diff --git a/compat/zlib/contrib/README.contrib b/compat/zlib/contrib/README.contrib index 335e435..5e5f950 100644 --- a/compat/zlib/contrib/README.contrib +++ b/compat/zlib/contrib/README.contrib @@ -1,4 +1,4 @@ -All files under this contrib directory are UNSUPPORTED. There were +All files under this contrib directory are UNSUPPORTED. They were provided by users of zlib and were not tested by the authors of zlib. Use at your own risk. Please contact the authors of the contributions for help about these, not the zlib authors. Thanks. diff --git a/compat/zlib/contrib/delphi/ZLib.pas b/compat/zlib/contrib/delphi/ZLib.pas index d40dad8..8be5fa2 100644 --- a/compat/zlib/contrib/delphi/ZLib.pas +++ b/compat/zlib/contrib/delphi/ZLib.pas @@ -152,7 +152,7 @@ procedure DecompressToUserBuf(const InBuf: Pointer; InBytes: Integer; const OutBuf: Pointer; BufSize: Integer); const - zlib_version = '1.2.12'; + zlib_version = '1.2.13'; type EZlibError = class(Exception); diff --git a/compat/zlib/contrib/dotzlib/DotZLib/UnitTests.cs b/compat/zlib/contrib/dotzlib/DotZLib/UnitTests.cs index 865c802..16a0ebb 100644 --- a/compat/zlib/contrib/dotzlib/DotZLib/UnitTests.cs +++ b/compat/zlib/contrib/dotzlib/DotZLib/UnitTests.cs @@ -156,7 +156,7 @@ namespace DotZLibTests public void Info_Version() { Info info = new Info(); - Assert.AreEqual("1.2.12", Info.Version); + Assert.AreEqual("1.2.13", Info.Version); Assert.AreEqual(32, info.SizeOfUInt); Assert.AreEqual(32, info.SizeOfULong); Assert.AreEqual(32, info.SizeOfPointer); diff --git a/compat/zlib/contrib/infback9/inftree9.c b/compat/zlib/contrib/infback9/inftree9.c index 2175bde..10827a6 100644 --- a/compat/zlib/contrib/infback9/inftree9.c +++ b/compat/zlib/contrib/infback9/inftree9.c @@ -9,7 +9,7 @@ #define MAXBITS 15 const char inflate9_copyright[] = - " inflate9 1.2.12 Copyright 1995-2022 Mark Adler "; + " inflate9 1.2.13 Copyright 1995-2022 Mark Adler "; /* If you use the zlib library in a product, an acknowledgment is welcome in the documentation of your product. If for some reason you cannot @@ -64,7 +64,7 @@ unsigned short FAR *work; static const unsigned short lext[31] = { /* Length codes 257..285 extra */ 128, 128, 128, 128, 128, 128, 128, 128, 129, 129, 129, 129, 130, 130, 130, 130, 131, 131, 131, 131, 132, 132, 132, 132, - 133, 133, 133, 133, 144, 76, 202}; + 133, 133, 133, 133, 144, 194, 65}; static const unsigned short dbase[32] = { /* Distance codes 0..31 base */ 1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193, 257, 385, 513, 769, 1025, 1537, 2049, 3073, diff --git a/compat/zlib/contrib/infback9/inftree9.h b/compat/zlib/contrib/infback9/inftree9.h index 5ab21f0..3b39497 100644 --- a/compat/zlib/contrib/infback9/inftree9.h +++ b/compat/zlib/contrib/infback9/inftree9.h @@ -38,7 +38,7 @@ typedef struct { /* Maximum size of the dynamic table. The maximum number of code structures is 1446, which is the sum of 852 for literal/length codes and 594 for distance codes. These values were found by exhaustive searches using the program - examples/enough.c found in the zlib distribtution. The arguments to that + examples/enough.c found in the zlib distribution. The arguments to that program are the number of symbols, the initial root table size, and the maximum bit length of a code. "enough 286 9 15" for literal/length codes returns returns 852, and "enough 32 6 15" for distance codes returns 594. diff --git a/compat/zlib/contrib/minizip/configure.ac b/compat/zlib/contrib/minizip/configure.ac index 6409abc..bff300b 100644 --- a/compat/zlib/contrib/minizip/configure.ac +++ b/compat/zlib/contrib/minizip/configure.ac @@ -1,7 +1,7 @@ # -*- Autoconf -*- # Process this file with autoconf to produce a configure script. -AC_INIT([minizip], [1.2.12], [bugzilla.redhat.com]) +AC_INIT([minizip], [1.2.13], [bugzilla.redhat.com]) AC_CONFIG_SRCDIR([minizip.c]) AM_INIT_AUTOMAKE([foreign]) LT_INIT diff --git a/compat/zlib/contrib/minizip/crypt.h b/compat/zlib/contrib/minizip/crypt.h index 9da1537..1cc41f1 100644 --- a/compat/zlib/contrib/minizip/crypt.h +++ b/compat/zlib/contrib/minizip/crypt.h @@ -85,7 +85,7 @@ static void init_keys(const char* passwd,unsigned long* pkeys,const z_crc_t* pcr #define RAND_HEAD_LEN 12 /* "last resort" source for second part of crypt seed pattern */ # ifndef ZCR_SEED2 -# define ZCR_SEED2 3141592654L /* use PI as default pattern */ +# define ZCR_SEED2 3141592654UL /* use PI as default pattern */ # endif static unsigned crypthead(const char* passwd, /* password string */ diff --git a/compat/zlib/contrib/minizip/ioapi.c b/compat/zlib/contrib/minizip/ioapi.c index ffcb937..814a6fd 100644 --- a/compat/zlib/contrib/minizip/ioapi.c +++ b/compat/zlib/contrib/minizip/ioapi.c @@ -14,11 +14,7 @@ #define _CRT_SECURE_NO_WARNINGS #endif -#if defined(_WIN32) -#define FOPEN_FUNC(filename, mode) fopen(filename, mode) -#define FTELLO_FUNC(stream) _ftelli64(stream) -#define FSEEKO_FUNC(stream, offset, origin) _fseeki64(stream, offset, origin) -#elif defined(__APPLE__) || defined(IOAPI_NO_64) +#if defined(__APPLE__) || defined(IOAPI_NO_64) // In darwin and perhaps other BSD variants off_t is a 64 bit value, hence no need for specific 64 bit functions #define FOPEN_FUNC(filename, mode) fopen(filename, mode) #define FTELLO_FUNC(stream) ftello(stream) @@ -98,9 +94,9 @@ static int ZCALLBACK ferror_file_func OF((voidpf opaque, voidpf stream)); static voidpf ZCALLBACK fopen_file_func (voidpf opaque, const char* filename, int mode) { - (void)opaque; FILE* file = NULL; const char* mode_fopen = NULL; + (void)opaque; if ((mode & ZLIB_FILEFUNC_MODE_READWRITEFILTER)==ZLIB_FILEFUNC_MODE_READ) mode_fopen = "rb"; else @@ -117,9 +113,9 @@ static voidpf ZCALLBACK fopen_file_func (voidpf opaque, const char* filename, in static voidpf ZCALLBACK fopen64_file_func (voidpf opaque, const void* filename, int mode) { - (void)opaque; FILE* file = NULL; const char* mode_fopen = NULL; + (void)opaque; if ((mode & ZLIB_FILEFUNC_MODE_READWRITEFILTER)==ZLIB_FILEFUNC_MODE_READ) mode_fopen = "rb"; else @@ -137,24 +133,24 @@ static voidpf ZCALLBACK fopen64_file_func (voidpf opaque, const void* filename, static uLong ZCALLBACK fread_file_func (voidpf opaque, voidpf stream, void* buf, uLong size) { - (void)opaque; uLong ret; + (void)opaque; ret = (uLong)fread(buf, 1, (size_t)size, (FILE *)stream); return ret; } static uLong ZCALLBACK fwrite_file_func (voidpf opaque, voidpf stream, const void* buf, uLong size) { - (void)opaque; uLong ret; + (void)opaque; ret = (uLong)fwrite(buf, 1, (size_t)size, (FILE *)stream); return ret; } static long ZCALLBACK ftell_file_func (voidpf opaque, voidpf stream) { - (void)opaque; long ret; + (void)opaque; ret = ftell((FILE *)stream); return ret; } @@ -162,17 +158,17 @@ static long ZCALLBACK ftell_file_func (voidpf opaque, voidpf stream) static ZPOS64_T ZCALLBACK ftell64_file_func (voidpf opaque, voidpf stream) { - (void)opaque; ZPOS64_T ret; + (void)opaque; ret = (ZPOS64_T)FTELLO_FUNC((FILE *)stream); return ret; } static long ZCALLBACK fseek_file_func (voidpf opaque, voidpf stream, uLong offset, int origin) { - (void)opaque; int fseek_origin=0; long ret; + (void)opaque; switch (origin) { case ZLIB_FILEFUNC_SEEK_CUR : @@ -194,9 +190,9 @@ static long ZCALLBACK fseek_file_func (voidpf opaque, voidpf stream, uLong offs static long ZCALLBACK fseek64_file_func (voidpf opaque, voidpf stream, ZPOS64_T offset, int origin) { - (void)opaque; int fseek_origin=0; long ret; + (void)opaque; switch (origin) { case ZLIB_FILEFUNC_SEEK_CUR : @@ -212,7 +208,7 @@ static long ZCALLBACK fseek64_file_func (voidpf opaque, voidpf stream, ZPOS64_T } ret = 0; - if(FSEEKO_FUNC((FILE *)stream, (long)offset, fseek_origin) != 0) + if(FSEEKO_FUNC((FILE *)stream, (z_off_t)offset, fseek_origin) != 0) ret = -1; return ret; @@ -221,16 +217,16 @@ static long ZCALLBACK fseek64_file_func (voidpf opaque, voidpf stream, ZPOS64_T static int ZCALLBACK fclose_file_func (voidpf opaque, voidpf stream) { - (void)opaque; int ret; + (void)opaque; ret = fclose((FILE *)stream); return ret; } static int ZCALLBACK ferror_file_func (voidpf opaque, voidpf stream) { - (void)opaque; int ret; + (void)opaque; ret = ferror((FILE *)stream); return ret; } diff --git a/compat/zlib/contrib/minizip/ioapi.h b/compat/zlib/contrib/minizip/ioapi.h index 114bfab..ae9ca7e 100644 --- a/compat/zlib/contrib/minizip/ioapi.h +++ b/compat/zlib/contrib/minizip/ioapi.h @@ -50,7 +50,7 @@ #define ftello64 ftell #define fseeko64 fseek #else -#ifdef __FreeBSD__ +#if defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__) #define fopen64 fopen #define ftello64 ftello #define fseeko64 fseeko diff --git a/compat/zlib/contrib/minizip/miniunz.c b/compat/zlib/contrib/minizip/miniunz.c index f103815..0dc9b50 100644 --- a/compat/zlib/contrib/minizip/miniunz.c +++ b/compat/zlib/contrib/minizip/miniunz.c @@ -564,7 +564,7 @@ int main(argc,argv) while ((*p)!='\0') { - char c=*(p++);; + char c=*(p++); if ((c=='l') || (c=='L')) opt_do_list = 1; if ((c=='v') || (c=='V')) diff --git a/compat/zlib/contrib/minizip/unzip.c b/compat/zlib/contrib/minizip/unzip.c index 5e12e47..3036b47 100644 --- a/compat/zlib/contrib/minizip/unzip.c +++ b/compat/zlib/contrib/minizip/unzip.c @@ -112,7 +112,7 @@ # define ALLOC(size) (malloc(size)) #endif #ifndef TRYFREE -# define TRYFREE(p) {if (p) free(p);} +# define TRYFREE(p) { free(p);} #endif #define SIZECENTRALDIRITEM (0x2e) @@ -1566,6 +1566,7 @@ extern int ZEXPORT unzOpenCurrentFile3 (unzFile file, int* method, pfile_in_zip_read_info->stream_initialised=Z_BZIP2ED; else { + TRYFREE(pfile_in_zip_read_info->read_buffer); TRYFREE(pfile_in_zip_read_info); return err; } @@ -1586,6 +1587,7 @@ extern int ZEXPORT unzOpenCurrentFile3 (unzFile file, int* method, pfile_in_zip_read_info->stream_initialised=Z_DEFLATED; else { + TRYFREE(pfile_in_zip_read_info->read_buffer); TRYFREE(pfile_in_zip_read_info); return err; } diff --git a/compat/zlib/contrib/minizip/zip.c b/compat/zlib/contrib/minizip/zip.c index 4e611e1..66d693f 100644 --- a/compat/zlib/contrib/minizip/zip.c +++ b/compat/zlib/contrib/minizip/zip.c @@ -1471,11 +1471,6 @@ extern int ZEXPORT zipWriteInFileInZip (zipFile file,const void* buf,unsigned in { uLong uTotalOutBefore = zi->ci.stream.total_out; err=deflate(&zi->ci.stream, Z_NO_FLUSH); - if(uTotalOutBefore > zi->ci.stream.total_out) - { - int bBreak = 0; - bBreak++; - } zi->ci.pos_in_buffered_data += (uInt)(zi->ci.stream.total_out - uTotalOutBefore) ; } @@ -1959,7 +1954,7 @@ extern int ZEXPORT zipRemoveExtraInfoBlock (char* pData, int* dataLen, short sHe int retVal = ZIP_OK; - if(pData == NULL || *dataLen < 4) + if(pData == NULL || dataLen == NULL || *dataLen < 4) return ZIP_PARAMERROR; pNewHeader = (char*)ALLOC((unsigned)*dataLen); diff --git a/compat/zlib/contrib/pascal/zlibpas.pas b/compat/zlib/contrib/pascal/zlibpas.pas index adb5cd6..bf3fff6 100644 --- a/compat/zlib/contrib/pascal/zlibpas.pas +++ b/compat/zlib/contrib/pascal/zlibpas.pas @@ -10,7 +10,7 @@ unit zlibpas; interface const - ZLIB_VERSION = '1.2.12'; + ZLIB_VERSION = '1.2.13'; ZLIB_VERNUM = $12a0; type diff --git a/compat/zlib/contrib/puff/README b/compat/zlib/contrib/puff/README index bbc4cb5..d8192c7 100644 --- a/compat/zlib/contrib/puff/README +++ b/compat/zlib/contrib/puff/README @@ -38,7 +38,7 @@ Then you can call puff() to decompress a deflate stream that is in memory in its entirety at source, to a sufficiently sized block of memory for the decompressed data at dest. puff() is the only external symbol in puff.c The only C library functions that puff.c needs are setjmp() and longjmp(), which -are used to simplify error checking in the code to improve readabilty. puff.c +are used to simplify error checking in the code to improve readability. puff.c does no memory allocation, and uses less than 2K bytes off of the stack. If destlen is not enough space for the uncompressed data, then inflate will diff --git a/compat/zlib/contrib/puff/puff.c b/compat/zlib/contrib/puff/puff.c index c6c90d7..6737ff6 100644 --- a/compat/zlib/contrib/puff/puff.c +++ b/compat/zlib/contrib/puff/puff.c @@ -43,7 +43,7 @@ * - Use pointers instead of long to specify source and * destination sizes to avoid arbitrary 4 GB limits * 1.2 17 Mar 2002 - Add faster version of decode(), doubles speed (!), - * but leave simple version for readabilty + * but leave simple version for readability * - Make sure invalid distances detected if pointers * are 16 bits * - Fix fixed codes table error @@ -624,7 +624,7 @@ local int fixed(struct state *s) * are themselves compressed using Huffman codes and run-length encoding. In * the list of code lengths, a 0 symbol means no code, a 1..15 symbol means * that length, and the symbols 16, 17, and 18 are run-length instructions. - * Each of 16, 17, and 18 are follwed by extra bits to define the length of + * Each of 16, 17, and 18 are followed by extra bits to define the length of * the run. 16 copies the last length 3 to 6 times. 17 represents 3 to 10 * zero lengths, and 18 represents 11 to 138 zero lengths. Unused symbols * are common, hence the special coding for zero lengths. diff --git a/compat/zlib/contrib/puff/pufftest.c b/compat/zlib/contrib/puff/pufftest.c index 7764814..5f72ecc 100644 --- a/compat/zlib/contrib/puff/pufftest.c +++ b/compat/zlib/contrib/puff/pufftest.c @@ -143,7 +143,7 @@ int main(int argc, char **argv) len - sourcelen); } - /* if requested, inflate again and write decompressd data to stdout */ + /* if requested, inflate again and write decompressed data to stdout */ if (put && ret == 0) { if (fail) destlen >>= 1; diff --git a/compat/zlib/contrib/vstudio/readme.txt b/compat/zlib/contrib/vstudio/readme.txt index d396d43..17e693f 100644 --- a/compat/zlib/contrib/vstudio/readme.txt +++ b/compat/zlib/contrib/vstudio/readme.txt @@ -1,4 +1,4 @@ -Building instructions for the DLL versions of Zlib 1.2.12 +Building instructions for the DLL versions of Zlib 1.2.13 ======================================================== This directory contains projects that build zlib and minizip using @@ -17,9 +17,6 @@ More information can be found at this site. Build instructions for Visual Studio 2008 (32 bits or 64 bits) -------------------------------------------------------------- - Decompress current zlib, including all contrib/* files -- Compile assembly code (with Visual Studio Command Prompt) by running: - bld_ml64.bat (in contrib\masmx64) - bld_ml32.bat (in contrib\masmx86) - Open contrib\vstudio\vc9\zlibvc.sln with Microsoft Visual C++ 2008 - Or run: vcbuild /rebuild contrib\vstudio\vc9\zlibvc.sln "Release|Win32" diff --git a/compat/zlib/contrib/vstudio/vc10/miniunz.vcxproj.filters b/compat/zlib/contrib/vstudio/vc10/miniunz.vcxproj.filters index 0b2a3de..e53556a 100644 --- a/compat/zlib/contrib/vstudio/vc10/miniunz.vcxproj.filters +++ b/compat/zlib/contrib/vstudio/vc10/miniunz.vcxproj.filters @@ -3,7 +3,7 @@ {048af943-022b-4db6-beeb-a54c34774ee2} - cpp;c;cxx;def;odl;idl;hpj;bat;asm + cpp;c;cxx;def;odl;idl;hpj;bat {c1d600d2-888f-4aea-b73e-8b0dd9befa0c} diff --git a/compat/zlib/contrib/vstudio/vc10/minizip.vcxproj.filters b/compat/zlib/contrib/vstudio/vc10/minizip.vcxproj.filters index dd73cd3..bd18d71 100644 --- a/compat/zlib/contrib/vstudio/vc10/minizip.vcxproj.filters +++ b/compat/zlib/contrib/vstudio/vc10/minizip.vcxproj.filters @@ -3,7 +3,7 @@ {c0419b40-bf50-40da-b153-ff74215b79de} - cpp;c;cxx;def;odl;idl;hpj;bat;asm + cpp;c;cxx;def;odl;idl;hpj;bat {bb87b070-735b-478e-92ce-7383abb2f36c} diff --git a/compat/zlib/contrib/vstudio/vc10/testzlib.vcxproj b/compat/zlib/contrib/vstudio/vc10/testzlib.vcxproj index 9088d17..0e668f7 100644 --- a/compat/zlib/contrib/vstudio/vc10/testzlib.vcxproj +++ b/compat/zlib/contrib/vstudio/vc10/testzlib.vcxproj @@ -181,7 +181,7 @@ Disabled ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) + WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) true Default MultiThreadedDebug @@ -194,7 +194,7 @@ EditAndContinue - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)testzlib.exe true $(OutDir)testzlib.pdb @@ -241,7 +241,7 @@ OnlyExplicitInline true ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) + WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) true Default MultiThreaded @@ -254,7 +254,7 @@ ProgramDatabase - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)testzlib.exe true Console @@ -269,14 +269,14 @@ ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) + WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) Default MultiThreadedDebugDLL false $(IntDir) - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) + %(AdditionalDependencies) @@ -352,14 +352,14 @@ ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) + WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) Default MultiThreadedDLL false $(IntDir) - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) + %(AdditionalDependencies) @@ -398,14 +398,6 @@ - - true - true - true - true - true - true - diff --git a/compat/zlib/contrib/vstudio/vc10/testzlib.vcxproj.filters b/compat/zlib/contrib/vstudio/vc10/testzlib.vcxproj.filters index 249daa8..3cf52ee 100644 --- a/compat/zlib/contrib/vstudio/vc10/testzlib.vcxproj.filters +++ b/compat/zlib/contrib/vstudio/vc10/testzlib.vcxproj.filters @@ -3,7 +3,7 @@ {c1f6a2e3-5da5-4955-8653-310d3efe05a9} - cpp;c;cxx;def;odl;idl;hpj;bat;asm + cpp;c;cxx;def;odl;idl;hpj;bat {c2aaffdc-2c95-4d6f-8466-4bec5890af2c} @@ -30,9 +30,6 @@ Source Files - - Source Files - Source Files diff --git a/compat/zlib/contrib/vstudio/vc10/testzlibdll.vcxproj.filters b/compat/zlib/contrib/vstudio/vc10/testzlibdll.vcxproj.filters index 53a8693..aeb550e 100644 --- a/compat/zlib/contrib/vstudio/vc10/testzlibdll.vcxproj.filters +++ b/compat/zlib/contrib/vstudio/vc10/testzlibdll.vcxproj.filters @@ -3,7 +3,7 @@ {fa61a89f-93fc-4c89-b29e-36224b7592f4} - cpp;c;cxx;def;odl;idl;hpj;bat;asm + cpp;c;cxx;def;odl;idl;hpj;bat {d4b85da0-2ba2-4934-b57f-e2584e3848ee} diff --git a/compat/zlib/contrib/vstudio/vc10/zlib.rc b/compat/zlib/contrib/vstudio/vc10/zlib.rc index 8ad25f1..8760274 100644 --- a/compat/zlib/contrib/vstudio/vc10/zlib.rc +++ b/compat/zlib/contrib/vstudio/vc10/zlib.rc @@ -2,8 +2,8 @@ #define IDR_VERSION1 1 IDR_VERSION1 VERSIONINFO MOVEABLE IMPURE LOADONCALL DISCARDABLE - FILEVERSION 1, 2, 12, 0 - PRODUCTVERSION 1, 2, 12, 0 + FILEVERSION 1, 2, 13, 0 + PRODUCTVERSION 1, 2, 13, 0 FILEFLAGSMASK VS_FFI_FILEFLAGSMASK FILEFLAGS 0 FILEOS VOS_DOS_WINDOWS32 @@ -17,7 +17,7 @@ BEGIN BEGIN VALUE "FileDescription", "zlib data compression and ZIP file I/O library\0" - VALUE "FileVersion", "1.2.12\0" + VALUE "FileVersion", "1.2.13\0" VALUE "InternalName", "zlib\0" VALUE "OriginalFilename", "zlibwapi.dll\0" VALUE "ProductName", "ZLib.DLL\0" diff --git a/compat/zlib/contrib/vstudio/vc10/zlibstat.vcxproj b/compat/zlib/contrib/vstudio/vc10/zlibstat.vcxproj index b9f2bbe..c7ed09e 100644 --- a/compat/zlib/contrib/vstudio/vc10/zlibstat.vcxproj +++ b/compat/zlib/contrib/vstudio/vc10/zlibstat.vcxproj @@ -160,7 +160,7 @@ Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + %(AdditionalIncludeDirectories) WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) @@ -182,16 +182,12 @@ $(OutDir)zlibstat.lib true - - cd ..\..\masmx86 -bld_ml32.bat - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ASMV;ASMINF;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) true @@ -210,19 +206,15 @@ bld_ml32.bat /MACHINE:X86 /NODEFAULTLIB %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)zlibstat.lib true - - cd ..\..\masmx86 -bld_ml32.bat - OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) true @@ -252,7 +244,7 @@ bld_ml32.bat Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) @@ -274,10 +266,6 @@ bld_ml32.bat $(OutDir)zlibstat.lib true - - cd ..\..\masmx64 -bld_ml64.bat - @@ -285,7 +273,7 @@ bld_ml64.bat Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) @@ -314,8 +302,8 @@ bld_ml64.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) true @@ -334,14 +322,10 @@ bld_ml64.bat /MACHINE:AMD64 /NODEFAULTLIB %(AdditionalOptions) - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)zlibstat.lib true - - cd ..\..\masmx64 -bld_ml64.bat - @@ -349,7 +333,7 @@ bld_ml64.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) true @@ -379,7 +363,7 @@ bld_ml64.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) true @@ -409,7 +393,7 @@ bld_ml64.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) true @@ -443,14 +427,6 @@ bld_ml64.bat - - true - true - true - true - true - true - diff --git a/compat/zlib/contrib/vstudio/vc10/zlibstat.vcxproj.filters b/compat/zlib/contrib/vstudio/vc10/zlibstat.vcxproj.filters index c8c7f7e..ba7e23d 100644 --- a/compat/zlib/contrib/vstudio/vc10/zlibstat.vcxproj.filters +++ b/compat/zlib/contrib/vstudio/vc10/zlibstat.vcxproj.filters @@ -33,9 +33,6 @@ Source Files - - Source Files - Source Files diff --git a/compat/zlib/contrib/vstudio/vc10/zlibvc.sln b/compat/zlib/contrib/vstudio/vc10/zlibvc.sln index 6953136..6f6ffd5 100644 --- a/compat/zlib/contrib/vstudio/vc10/zlibvc.sln +++ b/compat/zlib/contrib/vstudio/vc10/zlibvc.sln @@ -1,4 +1,4 @@ - + Microsoft Visual Studio Solution File, Format Version 11.00 # Visual Studio 2010 Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibvc", "zlibvc.vcxproj", "{8FD826F8-3739-44E6-8CC8-997122E53B8D}" diff --git a/compat/zlib/contrib/vstudio/vc10/zlibvc.vcxproj b/compat/zlib/contrib/vstudio/vc10/zlibvc.vcxproj index 6ff9ddb..19dfc35 100644 --- a/compat/zlib/contrib/vstudio/vc10/zlibvc.vcxproj +++ b/compat/zlib/contrib/vstudio/vc10/zlibvc.vcxproj @@ -197,8 +197,8 @@ Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;%(PreprocessorDefinitions) MultiThreadedDebug @@ -219,7 +219,7 @@ /MACHINE:I386 %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) + %(AdditionalDependencies) true .\zlibvc.def true @@ -229,10 +229,6 @@ - - cd ..\..\masmx86 -bld_ml32.bat - @@ -244,7 +240,7 @@ bld_ml32.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;%(PreprocessorDefinitions) true @@ -288,8 +284,8 @@ bld_ml32.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;%(PreprocessorDefinitions) true @@ -312,7 +308,7 @@ bld_ml32.bat /MACHINE:I386 %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) + %(AdditionalDependencies) true false .\zlibvc.def @@ -322,10 +318,6 @@ bld_ml32.bat - - cd ..\..\masmx86 -bld_ml32.bat - @@ -337,8 +329,8 @@ bld_ml32.bat Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) MultiThreadedDebugDLL @@ -358,7 +350,7 @@ bld_ml32.bat 0x040c - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) + %(AdditionalDependencies) true .\zlibvc.def true @@ -366,10 +358,6 @@ bld_ml32.bat Windows MachineX64 - - cd ..\..\masmx64 -bld_ml64.bat - @@ -381,7 +369,7 @@ bld_ml64.bat Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) @@ -424,7 +412,7 @@ bld_ml64.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) true @@ -465,7 +453,7 @@ bld_ml64.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) true @@ -510,8 +498,8 @@ bld_ml64.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) true @@ -533,7 +521,7 @@ bld_ml64.bat 0x040c - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) + %(AdditionalDependencies) true false .\zlibvc.def @@ -541,10 +529,6 @@ bld_ml64.bat Windows MachineX64 - - cd ..\..\masmx64 -bld_ml64.bat - @@ -556,7 +540,7 @@ bld_ml64.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) true @@ -601,14 +585,6 @@ bld_ml64.bat - - true - true - true - true - true - true - diff --git a/compat/zlib/contrib/vstudio/vc10/zlibvc.vcxproj.filters b/compat/zlib/contrib/vstudio/vc10/zlibvc.vcxproj.filters index 180b71c..67c444a 100644 --- a/compat/zlib/contrib/vstudio/vc10/zlibvc.vcxproj.filters +++ b/compat/zlib/contrib/vstudio/vc10/zlibvc.vcxproj.filters @@ -42,9 +42,6 @@ Source Files - - Source Files - Source Files diff --git a/compat/zlib/contrib/vstudio/vc11/testzlib.vcxproj b/compat/zlib/contrib/vstudio/vc11/testzlib.vcxproj index 6d55954..c6198c1 100644 --- a/compat/zlib/contrib/vstudio/vc11/testzlib.vcxproj +++ b/compat/zlib/contrib/vstudio/vc11/testzlib.vcxproj @@ -187,7 +187,7 @@ Disabled ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) + WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) true Default MultiThreadedDebugDLL @@ -200,7 +200,7 @@ ProgramDatabase - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)testzlib.exe true $(OutDir)testzlib.pdb @@ -247,7 +247,7 @@ OnlyExplicitInline true ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) + WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) true Default MultiThreaded @@ -260,7 +260,7 @@ ProgramDatabase - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)testzlib.exe true Console @@ -275,14 +275,14 @@ ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) + WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) Default MultiThreadedDebugDLL false $(IntDir) - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) + %(AdditionalDependencies) @@ -358,14 +358,14 @@ ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) + WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) Default MultiThreadedDLL false $(IntDir) - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) + %(AdditionalDependencies) @@ -404,14 +404,6 @@ - - true - true - true - true - true - true - diff --git a/compat/zlib/contrib/vstudio/vc11/zlib.rc b/compat/zlib/contrib/vstudio/vc11/zlib.rc index 8ad25f1..8760274 100644 --- a/compat/zlib/contrib/vstudio/vc11/zlib.rc +++ b/compat/zlib/contrib/vstudio/vc11/zlib.rc @@ -2,8 +2,8 @@ #define IDR_VERSION1 1 IDR_VERSION1 VERSIONINFO MOVEABLE IMPURE LOADONCALL DISCARDABLE - FILEVERSION 1, 2, 12, 0 - PRODUCTVERSION 1, 2, 12, 0 + FILEVERSION 1, 2, 13, 0 + PRODUCTVERSION 1, 2, 13, 0 FILEFLAGSMASK VS_FFI_FILEFLAGSMASK FILEFLAGS 0 FILEOS VOS_DOS_WINDOWS32 @@ -17,7 +17,7 @@ BEGIN BEGIN VALUE "FileDescription", "zlib data compression and ZIP file I/O library\0" - VALUE "FileVersion", "1.2.12\0" + VALUE "FileVersion", "1.2.13\0" VALUE "InternalName", "zlib\0" VALUE "OriginalFilename", "zlibwapi.dll\0" VALUE "ProductName", "ZLib.DLL\0" diff --git a/compat/zlib/contrib/vstudio/vc11/zlibstat.vcxproj b/compat/zlib/contrib/vstudio/vc11/zlibstat.vcxproj index 806b76a..86fb1c8 100644 --- a/compat/zlib/contrib/vstudio/vc11/zlibstat.vcxproj +++ b/compat/zlib/contrib/vstudio/vc11/zlibstat.vcxproj @@ -167,7 +167,7 @@ Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) @@ -193,8 +193,8 @@ OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ASMV;ASMINF;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) true @@ -213,7 +213,7 @@ /MACHINE:X86 /NODEFAULTLIB %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)zlibstat.lib true @@ -221,7 +221,7 @@ OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) true @@ -251,7 +251,7 @@ Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) @@ -280,7 +280,7 @@ Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) @@ -309,8 +309,8 @@ OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) true @@ -329,7 +329,7 @@ /MACHINE:AMD64 /NODEFAULTLIB %(AdditionalOptions) - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)zlibstat.lib true @@ -340,7 +340,7 @@ OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) true @@ -370,7 +370,7 @@ OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) true @@ -400,7 +400,7 @@ OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) true @@ -434,14 +434,6 @@ - - true - true - true - true - true - true - diff --git a/compat/zlib/contrib/vstudio/vc11/zlibvc.sln b/compat/zlib/contrib/vstudio/vc11/zlibvc.sln index 7e340e6..9fcbafd 100644 --- a/compat/zlib/contrib/vstudio/vc11/zlibvc.sln +++ b/compat/zlib/contrib/vstudio/vc11/zlibvc.sln @@ -1,4 +1,4 @@ - + Microsoft Visual Studio Solution File, Format Version 12.00 # Visual Studio 2012 Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibvc", "zlibvc.vcxproj", "{8FD826F8-3739-44E6-8CC8-997122E53B8D}" diff --git a/compat/zlib/contrib/vstudio/vc11/zlibvc.vcxproj b/compat/zlib/contrib/vstudio/vc11/zlibvc.vcxproj index c65b95f..fc8cd9c 100644 --- a/compat/zlib/contrib/vstudio/vc11/zlibvc.vcxproj +++ b/compat/zlib/contrib/vstudio/vc11/zlibvc.vcxproj @@ -204,8 +204,8 @@ Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;%(PreprocessorDefinitions) MultiThreadedDebugDLL @@ -226,7 +226,7 @@ /MACHINE:I386 %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)zlibwapi.dll true .\zlibvc.def @@ -240,10 +240,6 @@ $(OutDir)zlibwapi.lib - - cd ..\..\masmx86 -bld_ml32.bat - @@ -255,7 +251,7 @@ bld_ml32.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;%(PreprocessorDefinitions) true @@ -303,8 +299,8 @@ bld_ml32.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;%(PreprocessorDefinitions) true @@ -327,7 +323,7 @@ bld_ml32.bat /MACHINE:I386 %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)zlibwapi.dll true false @@ -341,10 +337,6 @@ bld_ml32.bat $(OutDir)zlibwapi.lib - - cd ..\..\masmx86 -bld_ml32.bat - @@ -356,8 +348,8 @@ bld_ml32.bat Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) MultiThreadedDebugDLL @@ -377,7 +369,7 @@ bld_ml32.bat 0x040c - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)zlibwapi.dll true .\zlibvc.def @@ -389,10 +381,6 @@ bld_ml32.bat $(OutDir)zlibwapi.lib MachineX64 - - cd ..\..\contrib\masmx64 -bld_ml64.bat - @@ -404,7 +392,7 @@ bld_ml64.bat Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) @@ -447,7 +435,7 @@ bld_ml64.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) true @@ -492,7 +480,7 @@ bld_ml64.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) true @@ -537,8 +525,8 @@ bld_ml64.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) true @@ -560,7 +548,7 @@ bld_ml64.bat 0x040c - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)zlibwapi.dll true false @@ -572,10 +560,6 @@ bld_ml64.bat $(OutDir)zlibwapi.lib MachineX64 - - cd ..\..\masmx64 -bld_ml64.bat - @@ -587,7 +571,7 @@ bld_ml64.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) true @@ -632,14 +616,6 @@ bld_ml64.bat - - true - true - true - true - true - true - diff --git a/compat/zlib/contrib/vstudio/vc12/testzlib.vcxproj b/compat/zlib/contrib/vstudio/vc12/testzlib.vcxproj index 64b2cbe..41303c0 100644 --- a/compat/zlib/contrib/vstudio/vc12/testzlib.vcxproj +++ b/compat/zlib/contrib/vstudio/vc12/testzlib.vcxproj @@ -190,7 +190,7 @@ Disabled ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) + WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) true Default MultiThreadedDebugDLL @@ -203,7 +203,7 @@ ProgramDatabase - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)testzlib.exe true $(OutDir)testzlib.pdb @@ -250,7 +250,7 @@ OnlyExplicitInline true ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) + WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) true Default MultiThreaded @@ -263,7 +263,7 @@ ProgramDatabase - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)testzlib.exe true Console @@ -279,14 +279,14 @@ ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) + WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) Default MultiThreadedDebugDLL false $(IntDir) - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) + %(AdditionalDependencies) @@ -362,14 +362,14 @@ ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) + WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) Default MultiThreadedDLL false $(IntDir) - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) + %(AdditionalDependencies) @@ -408,14 +408,6 @@ - - true - true - true - true - true - true - diff --git a/compat/zlib/contrib/vstudio/vc12/zlib.rc b/compat/zlib/contrib/vstudio/vc12/zlib.rc index 9475873..cdd7985 100644 --- a/compat/zlib/contrib/vstudio/vc12/zlib.rc +++ b/compat/zlib/contrib/vstudio/vc12/zlib.rc @@ -2,8 +2,8 @@ #define IDR_VERSION1 1 IDR_VERSION1 VERSIONINFO MOVEABLE IMPURE LOADONCALL DISCARDABLE - FILEVERSION 1, 2, 12, 0 - PRODUCTVERSION 1, 2, 12, 0 + FILEVERSION 1, 2, 13, 0 + PRODUCTVERSION 1, 2, 13, 0 FILEFLAGSMASK VS_FFI_FILEFLAGSMASK FILEFLAGS 0 FILEOS VOS_DOS_WINDOWS32 @@ -17,7 +17,7 @@ BEGIN BEGIN VALUE "FileDescription", "zlib data compression and ZIP file I/O library\0" - VALUE "FileVersion", "1.2.12\0" + VALUE "FileVersion", "1.2.13\0" VALUE "InternalName", "zlib\0" VALUE "OriginalFilename", "zlibwapi.dll\0" VALUE "ProductName", "ZLib.DLL\0" diff --git a/compat/zlib/contrib/vstudio/vc12/zlibstat.vcxproj b/compat/zlib/contrib/vstudio/vc12/zlibstat.vcxproj index 3fdee7c..6629d8e 100644 --- a/compat/zlib/contrib/vstudio/vc12/zlibstat.vcxproj +++ b/compat/zlib/contrib/vstudio/vc12/zlibstat.vcxproj @@ -170,7 +170,7 @@ Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) @@ -196,8 +196,8 @@ OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ASMV;ASMINF;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) true @@ -216,7 +216,7 @@ /MACHINE:X86 /NODEFAULTLIB %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)zlibstat.lib true @@ -224,7 +224,7 @@ OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) true @@ -254,7 +254,7 @@ Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) @@ -283,7 +283,7 @@ Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) @@ -312,8 +312,8 @@ OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) true @@ -332,7 +332,7 @@ /MACHINE:AMD64 /NODEFAULTLIB %(AdditionalOptions) - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)zlibstat.lib true @@ -343,7 +343,7 @@ OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) true @@ -373,7 +373,7 @@ OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) true @@ -403,7 +403,7 @@ OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) true @@ -437,14 +437,6 @@ - - true - true - true - true - true - true - diff --git a/compat/zlib/contrib/vstudio/vc12/zlibvc.sln b/compat/zlib/contrib/vstudio/vc12/zlibvc.sln index 93b13c1..dcda229 100644 --- a/compat/zlib/contrib/vstudio/vc12/zlibvc.sln +++ b/compat/zlib/contrib/vstudio/vc12/zlibvc.sln @@ -1,119 +1,119 @@ - -Microsoft Visual Studio Solution File, Format Version 12.00 -# Visual Studio 2013 -VisualStudioVersion = 12.0.40629.0 -MinimumVisualStudioVersion = 10.0.40219.1 -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibvc", "zlibvc.vcxproj", "{8FD826F8-3739-44E6-8CC8-997122E53B8D}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibstat", "zlibstat.vcxproj", "{745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlib", "testzlib.vcxproj", "{AA6666AA-E09F-4135-9C0C-4FE50C3C654B}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlibdll", "testzlibdll.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694366A}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "minizip", "minizip.vcxproj", "{48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "miniunz", "miniunz.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694382A}" -EndProject -Global - GlobalSection(SolutionConfigurationPlatforms) = preSolution - Debug|Itanium = Debug|Itanium - Debug|Win32 = Debug|Win32 - Debug|x64 = Debug|x64 - Release|Itanium = Release|Itanium - Release|Win32 = Release|Win32 - Release|x64 = Release|x64 - ReleaseWithoutAsm|Itanium = ReleaseWithoutAsm|Itanium - ReleaseWithoutAsm|Win32 = ReleaseWithoutAsm|Win32 - ReleaseWithoutAsm|x64 = ReleaseWithoutAsm|x64 - EndGlobalSection - GlobalSection(ProjectConfigurationPlatforms) = postSolution - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Itanium.ActiveCfg = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.ActiveCfg = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.Build.0 = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.ActiveCfg = Debug|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.Build.0 = Debug|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Itanium.ActiveCfg = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.ActiveCfg = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.Build.0 = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.ActiveCfg = Release|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.Build.0 = Release|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Itanium.ActiveCfg = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.ActiveCfg = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.Build.0 = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.ActiveCfg = Debug|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.Build.0 = Debug|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Itanium.ActiveCfg = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.ActiveCfg = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.Build.0 = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.ActiveCfg = Release|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.Build.0 = Release|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Itanium.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.Build.0 = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.ActiveCfg = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.Build.0 = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.Build.0 = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.Build.0 = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Itanium.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.Build.0 = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.ActiveCfg = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.Build.0 = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.Build.0 = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.Build.0 = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - EndGlobalSection - GlobalSection(SolutionProperties) = preSolution - HideSolutionNode = FALSE - EndGlobalSection -EndGlobal + +Microsoft Visual Studio Solution File, Format Version 12.00 +# Visual Studio 2013 +VisualStudioVersion = 12.0.40629.0 +MinimumVisualStudioVersion = 10.0.40219.1 +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibvc", "zlibvc.vcxproj", "{8FD826F8-3739-44E6-8CC8-997122E53B8D}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibstat", "zlibstat.vcxproj", "{745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlib", "testzlib.vcxproj", "{AA6666AA-E09F-4135-9C0C-4FE50C3C654B}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlibdll", "testzlibdll.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694366A}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "minizip", "minizip.vcxproj", "{48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "miniunz", "miniunz.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694382A}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|Itanium = Debug|Itanium + Debug|Win32 = Debug|Win32 + Debug|x64 = Debug|x64 + Release|Itanium = Release|Itanium + Release|Win32 = Release|Win32 + Release|x64 = Release|x64 + ReleaseWithoutAsm|Itanium = ReleaseWithoutAsm|Itanium + ReleaseWithoutAsm|Win32 = ReleaseWithoutAsm|Win32 + ReleaseWithoutAsm|x64 = ReleaseWithoutAsm|x64 + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Itanium.ActiveCfg = Debug|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.ActiveCfg = Debug|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.Build.0 = Debug|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.ActiveCfg = Debug|x64 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.Build.0 = Debug|x64 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Itanium.ActiveCfg = Release|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.ActiveCfg = Release|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.Build.0 = Release|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.ActiveCfg = Release|x64 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.Build.0 = Release|x64 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Itanium.ActiveCfg = Debug|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.ActiveCfg = Debug|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.Build.0 = Debug|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.ActiveCfg = Debug|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.Build.0 = Debug|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Itanium.ActiveCfg = Release|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.ActiveCfg = Release|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.Build.0 = Release|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.ActiveCfg = Release|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.Build.0 = Release|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Itanium.ActiveCfg = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.ActiveCfg = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.Build.0 = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.ActiveCfg = Debug|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.Build.0 = Debug|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Itanium.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.Build.0 = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.ActiveCfg = Release|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.Build.0 = Release|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Itanium.ActiveCfg = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.ActiveCfg = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.Build.0 = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.ActiveCfg = Debug|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.Build.0 = Debug|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Itanium.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.Build.0 = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.ActiveCfg = Release|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.Build.0 = Release|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection +EndGlobal diff --git a/compat/zlib/contrib/vstudio/vc12/zlibvc.vcxproj b/compat/zlib/contrib/vstudio/vc12/zlibvc.vcxproj index ab2b6c3..4e0de69 100644 --- a/compat/zlib/contrib/vstudio/vc12/zlibvc.vcxproj +++ b/compat/zlib/contrib/vstudio/vc12/zlibvc.vcxproj @@ -207,8 +207,8 @@ Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;%(PreprocessorDefinitions) MultiThreadedDebugDLL @@ -229,7 +229,7 @@ /MACHINE:I386 %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)zlibwapi.dll true .\zlibvc.def @@ -243,10 +243,6 @@ $(OutDir)zlibwapi.lib - - cd ..\..\masmx86 -bld_ml32.bat - @@ -258,7 +254,7 @@ bld_ml32.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;%(PreprocessorDefinitions) true @@ -306,8 +302,8 @@ bld_ml32.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;%(PreprocessorDefinitions) true @@ -330,7 +326,7 @@ bld_ml32.bat /MACHINE:I386 %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)zlibwapi.dll true false @@ -345,10 +341,6 @@ bld_ml32.bat $(OutDir)zlibwapi.lib false - - cd ..\..\masmx86 -bld_ml32.bat - @@ -360,8 +352,8 @@ bld_ml32.bat Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) MultiThreadedDebugDLL @@ -381,7 +373,7 @@ bld_ml32.bat 0x040c - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)zlibwapi.dll true .\zlibvc.def @@ -393,10 +385,6 @@ bld_ml32.bat $(OutDir)zlibwapi.lib MachineX64 - - cd ..\..\contrib\masmx64 -bld_ml64.bat - @@ -408,7 +396,7 @@ bld_ml64.bat Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) @@ -451,7 +439,7 @@ bld_ml64.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) true @@ -496,7 +484,7 @@ bld_ml64.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) true @@ -541,8 +529,8 @@ bld_ml64.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) true @@ -564,7 +552,7 @@ bld_ml64.bat 0x040c - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)zlibwapi.dll true false @@ -576,10 +564,6 @@ bld_ml64.bat $(OutDir)zlibwapi.lib MachineX64 - - cd ..\..\masmx64 -bld_ml64.bat - @@ -591,7 +575,7 @@ bld_ml64.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) true @@ -636,14 +620,6 @@ bld_ml64.bat - - true - true - true - true - true - true - diff --git a/compat/zlib/contrib/vstudio/vc14/testzlib.vcxproj b/compat/zlib/contrib/vstudio/vc14/testzlib.vcxproj index 2c37125..5452049 100644 --- a/compat/zlib/contrib/vstudio/vc14/testzlib.vcxproj +++ b/compat/zlib/contrib/vstudio/vc14/testzlib.vcxproj @@ -190,7 +190,7 @@ Disabled ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) + WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) true Default MultiThreadedDebugDLL @@ -203,7 +203,7 @@ ProgramDatabase - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)testzlib.exe true $(OutDir)testzlib.pdb @@ -250,7 +250,7 @@ OnlyExplicitInline true ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) + WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) true Default MultiThreaded @@ -263,7 +263,7 @@ ProgramDatabase - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)testzlib.exe true Console @@ -279,14 +279,14 @@ ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) + WIN32;ZLIB_WINAPI;_DEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) Default MultiThreadedDebugDLL false $(IntDir) - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) + %(AdditionalDependencies) @@ -362,14 +362,14 @@ ..\..\..;%(AdditionalIncludeDirectories) - ASMV;ASMINF;WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) + WIN32;ZLIB_WINAPI;NDEBUG;_CONSOLE;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) Default MultiThreadedDLL false $(IntDir) - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) + %(AdditionalDependencies) @@ -408,14 +408,6 @@ - - true - true - true - true - true - true - diff --git a/compat/zlib/contrib/vstudio/vc14/zlib.rc b/compat/zlib/contrib/vstudio/vc14/zlib.rc index 9475873..cdd7985 100644 --- a/compat/zlib/contrib/vstudio/vc14/zlib.rc +++ b/compat/zlib/contrib/vstudio/vc14/zlib.rc @@ -2,8 +2,8 @@ #define IDR_VERSION1 1 IDR_VERSION1 VERSIONINFO MOVEABLE IMPURE LOADONCALL DISCARDABLE - FILEVERSION 1, 2, 12, 0 - PRODUCTVERSION 1, 2, 12, 0 + FILEVERSION 1, 2, 13, 0 + PRODUCTVERSION 1, 2, 13, 0 FILEFLAGSMASK VS_FFI_FILEFLAGSMASK FILEFLAGS 0 FILEOS VOS_DOS_WINDOWS32 @@ -17,7 +17,7 @@ BEGIN BEGIN VALUE "FileDescription", "zlib data compression and ZIP file I/O library\0" - VALUE "FileVersion", "1.2.12\0" + VALUE "FileVersion", "1.2.13\0" VALUE "InternalName", "zlib\0" VALUE "OriginalFilename", "zlibwapi.dll\0" VALUE "ProductName", "ZLib.DLL\0" diff --git a/compat/zlib/contrib/vstudio/vc14/zlibstat.vcxproj b/compat/zlib/contrib/vstudio/vc14/zlibstat.vcxproj index 3e4b986..85c1e89 100644 --- a/compat/zlib/contrib/vstudio/vc14/zlibstat.vcxproj +++ b/compat/zlib/contrib/vstudio/vc14/zlibstat.vcxproj @@ -170,7 +170,7 @@ Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) @@ -196,8 +196,8 @@ OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ASMV;ASMINF;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) true @@ -216,7 +216,7 @@ /MACHINE:X86 /NODEFAULTLIB %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)zlibstat.lib true @@ -224,7 +224,7 @@ OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;%(PreprocessorDefinitions) true @@ -254,7 +254,7 @@ Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) @@ -283,7 +283,7 @@ Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) @@ -312,8 +312,8 @@ OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) true @@ -332,7 +332,7 @@ /MACHINE:AMD64 /NODEFAULTLIB %(AdditionalOptions) - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)zlibstat.lib true @@ -343,7 +343,7 @@ OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) true @@ -373,7 +373,7 @@ OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) true @@ -403,7 +403,7 @@ OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) ZLIB_WINAPI;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;WIN64;%(PreprocessorDefinitions) true @@ -437,14 +437,6 @@ - - true - true - true - true - true - true - diff --git a/compat/zlib/contrib/vstudio/vc14/zlibvc.sln b/compat/zlib/contrib/vstudio/vc14/zlibvc.sln index 0f29237..6f4a107 100644 --- a/compat/zlib/contrib/vstudio/vc14/zlibvc.sln +++ b/compat/zlib/contrib/vstudio/vc14/zlibvc.sln @@ -1,119 +1,119 @@ - -Microsoft Visual Studio Solution File, Format Version 12.00 -# Visual Studio 14 -VisualStudioVersion = 14.0.25420.1 -MinimumVisualStudioVersion = 10.0.40219.1 -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibvc", "zlibvc.vcxproj", "{8FD826F8-3739-44E6-8CC8-997122E53B8D}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibstat", "zlibstat.vcxproj", "{745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlib", "testzlib.vcxproj", "{AA6666AA-E09F-4135-9C0C-4FE50C3C654B}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlibdll", "testzlibdll.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694366A}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "minizip", "minizip.vcxproj", "{48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}" -EndProject -Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "miniunz", "miniunz.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694382A}" -EndProject -Global - GlobalSection(SolutionConfigurationPlatforms) = preSolution - Debug|Itanium = Debug|Itanium - Debug|Win32 = Debug|Win32 - Debug|x64 = Debug|x64 - Release|Itanium = Release|Itanium - Release|Win32 = Release|Win32 - Release|x64 = Release|x64 - ReleaseWithoutAsm|Itanium = ReleaseWithoutAsm|Itanium - ReleaseWithoutAsm|Win32 = ReleaseWithoutAsm|Win32 - ReleaseWithoutAsm|x64 = ReleaseWithoutAsm|x64 - EndGlobalSection - GlobalSection(ProjectConfigurationPlatforms) = postSolution - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Itanium.ActiveCfg = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.ActiveCfg = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.Build.0 = Debug|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.ActiveCfg = Debug|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.Build.0 = Debug|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Itanium.ActiveCfg = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.ActiveCfg = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.Build.0 = Release|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.ActiveCfg = Release|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.Build.0 = Release|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Itanium.ActiveCfg = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.ActiveCfg = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.Build.0 = Debug|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.ActiveCfg = Debug|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.Build.0 = Debug|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Itanium.ActiveCfg = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.ActiveCfg = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.Build.0 = Release|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.ActiveCfg = Release|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.Build.0 = Release|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 - {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Itanium.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.Build.0 = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.ActiveCfg = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.Build.0 = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.Build.0 = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.Build.0 = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Itanium.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.ActiveCfg = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.Build.0 = Debug|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.ActiveCfg = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.Build.0 = Debug|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.Build.0 = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.ActiveCfg = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.Build.0 = Release|x64 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 - {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 - EndGlobalSection - GlobalSection(SolutionProperties) = preSolution - HideSolutionNode = FALSE - EndGlobalSection -EndGlobal + +Microsoft Visual Studio Solution File, Format Version 12.00 +# Visual Studio 14 +VisualStudioVersion = 14.0.25420.1 +MinimumVisualStudioVersion = 10.0.40219.1 +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibvc", "zlibvc.vcxproj", "{8FD826F8-3739-44E6-8CC8-997122E53B8D}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibstat", "zlibstat.vcxproj", "{745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlib", "testzlib.vcxproj", "{AA6666AA-E09F-4135-9C0C-4FE50C3C654B}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "testzlibdll", "testzlibdll.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694366A}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "minizip", "minizip.vcxproj", "{48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "miniunz", "miniunz.vcxproj", "{C52F9E7B-498A-42BE-8DB4-85A15694382A}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|Itanium = Debug|Itanium + Debug|Win32 = Debug|Win32 + Debug|x64 = Debug|x64 + Release|Itanium = Release|Itanium + Release|Win32 = Release|Win32 + Release|x64 = Release|x64 + ReleaseWithoutAsm|Itanium = ReleaseWithoutAsm|Itanium + ReleaseWithoutAsm|Win32 = ReleaseWithoutAsm|Win32 + ReleaseWithoutAsm|x64 = ReleaseWithoutAsm|x64 + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Itanium.ActiveCfg = Debug|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.ActiveCfg = Debug|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|Win32.Build.0 = Debug|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.ActiveCfg = Debug|x64 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Debug|x64.Build.0 = Debug|x64 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Itanium.ActiveCfg = Release|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.ActiveCfg = Release|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|Win32.Build.0 = Release|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.ActiveCfg = Release|x64 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.Release|x64.Build.0 = Release|x64 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 + {8FD826F8-3739-44E6-8CC8-997122E53B8D}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Itanium.ActiveCfg = Debug|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.ActiveCfg = Debug|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|Win32.Build.0 = Debug|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.ActiveCfg = Debug|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Debug|x64.Build.0 = Debug|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Itanium.ActiveCfg = Release|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.ActiveCfg = Release|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|Win32.Build.0 = Release|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.ActiveCfg = Release|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.Release|x64.Build.0 = Release|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 + {745DEC58-EBB3-47A9-A9B8-4C6627C01BF8}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = ReleaseWithoutAsm|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = ReleaseWithoutAsm|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.Build.0 = ReleaseWithoutAsm|Win32 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = ReleaseWithoutAsm|x64 + {AA6666AA-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.Build.0 = ReleaseWithoutAsm|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Itanium.ActiveCfg = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.ActiveCfg = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|Win32.Build.0 = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.ActiveCfg = Debug|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Debug|x64.Build.0 = Debug|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Itanium.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|Win32.Build.0 = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.ActiveCfg = Release|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.Release|x64.Build.0 = Release|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694366A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Itanium.ActiveCfg = Debug|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.ActiveCfg = Debug|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|Win32.Build.0 = Debug|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.ActiveCfg = Debug|x64 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Debug|x64.Build.0 = Debug|x64 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Itanium.ActiveCfg = Release|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.ActiveCfg = Release|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|Win32.Build.0 = Release|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.ActiveCfg = Release|x64 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.Release|x64.Build.0 = Release|x64 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 + {48CDD9DC-E09F-4135-9C0C-4FE50C3C654B}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Itanium.ActiveCfg = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.ActiveCfg = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|Win32.Build.0 = Debug|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.ActiveCfg = Debug|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Debug|x64.Build.0 = Debug|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Itanium.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|Win32.Build.0 = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.ActiveCfg = Release|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.Release|x64.Build.0 = Release|x64 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Itanium.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|Win32.ActiveCfg = Release|Win32 + {C52F9E7B-498A-42BE-8DB4-85A15694382A}.ReleaseWithoutAsm|x64.ActiveCfg = Release|x64 + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection +EndGlobal diff --git a/compat/zlib/contrib/vstudio/vc14/zlibvc.vcxproj b/compat/zlib/contrib/vstudio/vc14/zlibvc.vcxproj index f8f673c..424ff55 100644 --- a/compat/zlib/contrib/vstudio/vc14/zlibvc.vcxproj +++ b/compat/zlib/contrib/vstudio/vc14/zlibvc.vcxproj @@ -207,8 +207,8 @@ Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;%(PreprocessorDefinitions) MultiThreadedDebugDLL @@ -229,7 +229,7 @@ /MACHINE:I386 %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)zlibwapi.dll true .\zlibvc.def @@ -243,10 +243,6 @@ $(OutDir)zlibwapi.lib - - cd ..\..\masmx86 -bld_ml32.bat - @@ -258,7 +254,7 @@ bld_ml32.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;%(PreprocessorDefinitions) true @@ -306,8 +302,8 @@ bld_ml32.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;%(PreprocessorDefinitions) true @@ -330,7 +326,7 @@ bld_ml32.bat /MACHINE:I386 %(AdditionalOptions) - ..\..\masmx86\match686.obj;..\..\masmx86\inffas32.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)zlibwapi.dll true false @@ -345,10 +341,6 @@ bld_ml32.bat $(OutDir)zlibwapi.lib false - - cd ..\..\masmx86 -bld_ml32.bat - @@ -360,8 +352,8 @@ bld_ml32.bat Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) MultiThreadedDebugDLL @@ -381,7 +373,7 @@ bld_ml32.bat 0x040c - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)zlibwapi.dll true .\zlibvc.def @@ -393,10 +385,6 @@ bld_ml32.bat $(OutDir)zlibwapi.lib MachineX64 - - cd ..\..\contrib\masmx64 -bld_ml64.bat - @@ -408,7 +396,7 @@ bld_ml64.bat Disabled - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) @@ -451,7 +439,7 @@ bld_ml64.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) true @@ -496,7 +484,7 @@ bld_ml64.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) WIN32;_CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) true @@ -541,8 +529,8 @@ bld_ml64.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) - _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;ASMV;ASMINF;WIN64;%(PreprocessorDefinitions) + ..\..\..;%(AdditionalIncludeDirectories) + _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) true @@ -564,7 +552,7 @@ bld_ml64.bat 0x040c - ..\..\masmx64\gvmat64.obj;..\..\masmx64\inffasx64.obj;%(AdditionalDependencies) + %(AdditionalDependencies) $(OutDir)zlibwapi.dll true false @@ -576,10 +564,6 @@ bld_ml64.bat $(OutDir)zlibwapi.lib MachineX64 - - cd ..\..\masmx64 -bld_ml64.bat - @@ -591,7 +575,7 @@ bld_ml64.bat OnlyExplicitInline - ..\..\..;..\..\masmx86;%(AdditionalIncludeDirectories) + ..\..\..;%(AdditionalIncludeDirectories) _CRT_NONSTDC_NO_DEPRECATE;_CRT_SECURE_NO_DEPRECATE;_CRT_NONSTDC_NO_WARNINGS;ZLIB_WINAPI;WIN64;%(PreprocessorDefinitions) true @@ -636,14 +620,6 @@ bld_ml64.bat - - true - true - true - true - true - true - diff --git a/compat/zlib/contrib/vstudio/vc9/miniunz.vcproj b/compat/zlib/contrib/vstudio/vc9/miniunz.vcproj index 7da32b9..cc3d13a 100644 --- a/compat/zlib/contrib/vstudio/vc9/miniunz.vcproj +++ b/compat/zlib/contrib/vstudio/vc9/miniunz.vcproj @@ -542,7 +542,7 @@ - - - - - - - - - - - - - - - - - - - - diff --git a/compat/zlib/contrib/vstudio/vc9/testzlibdll.vcproj b/compat/zlib/contrib/vstudio/vc9/testzlibdll.vcproj index b1ddde0..6448b49 100644 --- a/compat/zlib/contrib/vstudio/vc9/testzlibdll.vcproj +++ b/compat/zlib/contrib/vstudio/vc9/testzlibdll.vcproj @@ -542,7 +542,7 @@ @@ -343,8 +342,8 @@ @@ -418,7 +416,7 @@ - - - - - - - - - - - - - - - - - - - - diff --git a/compat/zlib/contrib/vstudio/vc9/zlibvc.sln b/compat/zlib/contrib/vstudio/vc9/zlibvc.sln index 20568fa..b482967 100644 --- a/compat/zlib/contrib/vstudio/vc9/zlibvc.sln +++ b/compat/zlib/contrib/vstudio/vc9/zlibvc.sln @@ -1,4 +1,4 @@ - + Microsoft Visual Studio Solution File, Format Version 10.00 # Visual Studio 2008 Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "zlibvc", "zlibvc.vcproj", "{8FD826F8-3739-44E6-8CC8-997122E53B8D}" diff --git a/compat/zlib/contrib/vstudio/vc9/zlibvc.vcproj b/compat/zlib/contrib/vstudio/vc9/zlibvc.vcproj index c9a8947..f11dd1f 100644 --- a/compat/zlib/contrib/vstudio/vc9/zlibvc.vcproj +++ b/compat/zlib/contrib/vstudio/vc9/zlibvc.vcproj @@ -53,8 +53,8 @@ - - - - - - - - - - - - - - - - - - - - diff --git a/compat/zlib/crc32.c b/compat/zlib/crc32.c index 451887b..f8357b0 100644 --- a/compat/zlib/crc32.c +++ b/compat/zlib/crc32.c @@ -98,13 +98,22 @@ # endif #endif +/* If available, use the ARM processor CRC32 instruction. */ +#if defined(__aarch64__) && defined(__ARM_FEATURE_CRC32) && W == 8 +# define ARMCRC32 +#endif + /* Local functions. */ local z_crc_t multmodp OF((z_crc_t a, z_crc_t b)); local z_crc_t x2nmodp OF((z_off64_t n, unsigned k)); -/* If available, use the ARM processor CRC32 instruction. */ -#if defined(__aarch64__) && defined(__ARM_FEATURE_CRC32) && W == 8 -# define ARMCRC32 +#if defined(W) && (!defined(ARMCRC32) || defined(DYNAMIC_CRC_TABLE)) + local z_word_t byte_swap OF((z_word_t word)); +#endif + +#if defined(W) && !defined(ARMCRC32) + local z_crc_t crc_word OF((z_word_t data)); + local z_word_t crc_word_big OF((z_word_t data)); #endif #if defined(W) && (!defined(ARMCRC32) || defined(DYNAMIC_CRC_TABLE)) @@ -645,8 +654,8 @@ unsigned long ZEXPORT crc32_z(crc, buf, len) len &= 7; /* Do three interleaved CRCs to realize the throughput of one crc32x - instruction per cycle. Each CRC is calcuated on Z_BATCH words. The three - CRCs are combined into a single CRC after each set of batches. */ + instruction per cycle. Each CRC is calculated on Z_BATCH words. The + three CRCs are combined into a single CRC after each set of batches. */ while (num >= 3 * Z_BATCH) { crc1 = 0; crc2 = 0; @@ -1086,7 +1095,7 @@ uLong ZEXPORT crc32_combine(crc1, crc2, len2) uLong crc2; z_off_t len2; { - return crc32_combine64(crc1, crc2, len2); + return crc32_combine64(crc1, crc2, (z_off64_t)len2); } /* ========================================================================= */ @@ -1103,11 +1112,11 @@ uLong ZEXPORT crc32_combine_gen64(len2) uLong ZEXPORT crc32_combine_gen(len2) z_off_t len2; { - return crc32_combine_gen64(len2); + return crc32_combine_gen64((z_off64_t)len2); } /* ========================================================================= */ -uLong crc32_combine_op(crc1, crc2, op) +uLong ZEXPORT crc32_combine_op(crc1, crc2, op) uLong crc1; uLong crc2; uLong op; diff --git a/compat/zlib/deflate.c b/compat/zlib/deflate.c index 799fb93..4a689db 100644 --- a/compat/zlib/deflate.c +++ b/compat/zlib/deflate.c @@ -52,7 +52,7 @@ #include "deflate.h" const char deflate_copyright[] = - " deflate 1.2.12 Copyright 1995-2022 Jean-loup Gailly and Mark Adler "; + " deflate 1.2.13 Copyright 1995-2022 Jean-loup Gailly and Mark Adler "; /* If you use the zlib library in a product, an acknowledgment is welcome in the documentation of your product. If for some reason you cannot @@ -87,13 +87,7 @@ local void lm_init OF((deflate_state *s)); local void putShortMSB OF((deflate_state *s, uInt b)); local void flush_pending OF((z_streamp strm)); local unsigned read_buf OF((z_streamp strm, Bytef *buf, unsigned size)); -#ifdef ASMV -# pragma message("Assembler code may have bugs -- use at your own risk") - void match_init OF((void)); /* asm code initialization */ - uInt longest_match OF((deflate_state *s, IPos cur_match)); -#else local uInt longest_match OF((deflate_state *s, IPos cur_match)); -#endif #ifdef ZLIB_DEBUG local void check_match OF((deflate_state *s, IPos start, IPos match, @@ -160,7 +154,7 @@ local const config configuration_table[10] = { * characters, so that a running hash key can be computed from the previous * key instead of complete recalculation each time. */ -#define UPDATE_HASH(s,h,c) (h = (((h)<hash_shift) ^ (c)) & s->hash_mask) +#define UPDATE_HASH(s,h,c) (h = (((h) << s->hash_shift) ^ (c)) & s->hash_mask) /* =========================================================================== @@ -191,9 +185,9 @@ local const config configuration_table[10] = { */ #define CLEAR_HASH(s) \ do { \ - s->head[s->hash_size-1] = NIL; \ + s->head[s->hash_size - 1] = NIL; \ zmemzero((Bytef *)s->head, \ - (unsigned)(s->hash_size-1)*sizeof(*s->head)); \ + (unsigned)(s->hash_size - 1)*sizeof(*s->head)); \ } while (0) /* =========================================================================== @@ -285,6 +279,8 @@ int ZEXPORT deflateInit2_(strm, level, method, windowBits, memLevel, strategy, if (windowBits < 0) { /* suppress zlib wrapper */ wrap = 0; + if (windowBits < -15) + return Z_STREAM_ERROR; windowBits = -windowBits; } #ifdef GZIP @@ -314,7 +310,7 @@ int ZEXPORT deflateInit2_(strm, level, method, windowBits, memLevel, strategy, s->hash_bits = (uInt)memLevel + 7; s->hash_size = 1 << s->hash_bits; s->hash_mask = s->hash_size - 1; - s->hash_shift = ((s->hash_bits+MIN_MATCH-1)/MIN_MATCH); + s->hash_shift = ((s->hash_bits + MIN_MATCH-1) / MIN_MATCH); s->window = (Bytef *) ZALLOC(strm, s->w_size, 2*sizeof(Byte)); s->prev = (Posf *) ZALLOC(strm, s->w_size, sizeof(Pos)); @@ -340,11 +336,11 @@ int ZEXPORT deflateInit2_(strm, level, method, windowBits, memLevel, strategy, * sym_buf value to read moves forward three bytes. From that symbol, up to * 31 bits are written to pending_buf. The closest the written pending_buf * bits gets to the next sym_buf symbol to read is just before the last - * code is written. At that time, 31*(n-2) bits have been written, just - * after 24*(n-2) bits have been consumed from sym_buf. sym_buf starts at - * 8*n bits into pending_buf. (Note that the symbol buffer fills when n-1 + * code is written. At that time, 31*(n - 2) bits have been written, just + * after 24*(n - 2) bits have been consumed from sym_buf. sym_buf starts at + * 8*n bits into pending_buf. (Note that the symbol buffer fills when n - 1 * symbols are written.) The closest the writing gets to what is unread is - * then n+14 bits. Here n is lit_bufsize, which is 16384 by default, and + * then n + 14 bits. Here n is lit_bufsize, which is 16384 by default, and * can range from 128 to 32768. * * Therefore, at a minimum, there are 142 bits of space between what is @@ -390,7 +386,7 @@ int ZEXPORT deflateInit2_(strm, level, method, windowBits, memLevel, strategy, /* ========================================================================= * Check for a valid deflate stream state. Return 0 if ok, 1 if not. */ -local int deflateStateCheck (strm) +local int deflateStateCheck(strm) z_streamp strm; { deflate_state *s; @@ -413,7 +409,7 @@ local int deflateStateCheck (strm) } /* ========================================================================= */ -int ZEXPORT deflateSetDictionary (strm, dictionary, dictLength) +int ZEXPORT deflateSetDictionary(strm, dictionary, dictLength) z_streamp strm; const Bytef *dictionary; uInt dictLength; @@ -482,7 +478,7 @@ int ZEXPORT deflateSetDictionary (strm, dictionary, dictLength) } /* ========================================================================= */ -int ZEXPORT deflateGetDictionary (strm, dictionary, dictLength) +int ZEXPORT deflateGetDictionary(strm, dictionary, dictLength) z_streamp strm; Bytef *dictionary; uInt *dictLength; @@ -504,7 +500,7 @@ int ZEXPORT deflateGetDictionary (strm, dictionary, dictLength) } /* ========================================================================= */ -int ZEXPORT deflateResetKeep (strm) +int ZEXPORT deflateResetKeep(strm) z_streamp strm; { deflate_state *s; @@ -542,7 +538,7 @@ int ZEXPORT deflateResetKeep (strm) } /* ========================================================================= */ -int ZEXPORT deflateReset (strm) +int ZEXPORT deflateReset(strm) z_streamp strm; { int ret; @@ -554,7 +550,7 @@ int ZEXPORT deflateReset (strm) } /* ========================================================================= */ -int ZEXPORT deflateSetHeader (strm, head) +int ZEXPORT deflateSetHeader(strm, head) z_streamp strm; gz_headerp head; { @@ -565,7 +561,7 @@ int ZEXPORT deflateSetHeader (strm, head) } /* ========================================================================= */ -int ZEXPORT deflatePending (strm, pending, bits) +int ZEXPORT deflatePending(strm, pending, bits) unsigned *pending; int *bits; z_streamp strm; @@ -579,7 +575,7 @@ int ZEXPORT deflatePending (strm, pending, bits) } /* ========================================================================= */ -int ZEXPORT deflatePrime (strm, bits, value) +int ZEXPORT deflatePrime(strm, bits, value) z_streamp strm; int bits; int value; @@ -674,36 +670,50 @@ int ZEXPORT deflateTune(strm, good_length, max_lazy, nice_length, max_chain) } /* ========================================================================= - * For the default windowBits of 15 and memLevel of 8, this function returns - * a close to exact, as well as small, upper bound on the compressed size. - * They are coded as constants here for a reason--if the #define's are - * changed, then this function needs to be changed as well. The return - * value for 15 and 8 only works for those exact settings. + * For the default windowBits of 15 and memLevel of 8, this function returns a + * close to exact, as well as small, upper bound on the compressed size. This + * is an expansion of ~0.03%, plus a small constant. + * + * For any setting other than those defaults for windowBits and memLevel, one + * of two worst case bounds is returned. This is at most an expansion of ~4% or + * ~13%, plus a small constant. * - * For any setting other than those defaults for windowBits and memLevel, - * the value returned is a conservative worst case for the maximum expansion - * resulting from using fixed blocks instead of stored blocks, which deflate - * can emit on compressed data for some combinations of the parameters. + * Both the 0.03% and 4% derive from the overhead of stored blocks. The first + * one is for stored blocks of 16383 bytes (memLevel == 8), whereas the second + * is for stored blocks of 127 bytes (the worst case memLevel == 1). The + * expansion results from five bytes of header for each stored block. * - * This function could be more sophisticated to provide closer upper bounds for - * every combination of windowBits and memLevel. But even the conservative - * upper bound of about 14% expansion does not seem onerous for output buffer - * allocation. + * The larger expansion of 13% results from a window size less than or equal to + * the symbols buffer size (windowBits <= memLevel + 7). In that case some of + * the data being compressed may have slid out of the sliding window, impeding + * a stored block from being emitted. Then the only choice is a fixed or + * dynamic block, where a fixed block limits the maximum expansion to 9 bits + * per 8-bit byte, plus 10 bits for every block. The smallest block size for + * which this can occur is 255 (memLevel == 2). + * + * Shifts are used to approximate divisions, for speed. */ uLong ZEXPORT deflateBound(strm, sourceLen) z_streamp strm; uLong sourceLen; { deflate_state *s; - uLong complen, wraplen; + uLong fixedlen, storelen, wraplen; + + /* upper bound for fixed blocks with 9-bit literals and length 255 + (memLevel == 2, which is the lowest that may not use stored blocks) -- + ~13% overhead plus a small constant */ + fixedlen = sourceLen + (sourceLen >> 3) + (sourceLen >> 8) + + (sourceLen >> 9) + 4; - /* conservative upper bound for compressed data */ - complen = sourceLen + - ((sourceLen + 7) >> 3) + ((sourceLen + 63) >> 6) + 5; + /* upper bound for stored blocks with length 127 (memLevel == 1) -- + ~4% overhead plus a small constant */ + storelen = sourceLen + (sourceLen >> 5) + (sourceLen >> 7) + + (sourceLen >> 11) + 7; - /* if can't get parameters, return conservative bound plus zlib wrapper */ + /* if can't get parameters, return larger bound plus a zlib wrapper */ if (deflateStateCheck(strm)) - return complen + 6; + return (fixedlen > storelen ? fixedlen : storelen) + 6; /* compute wrapper length */ s = strm->state; @@ -740,11 +750,12 @@ uLong ZEXPORT deflateBound(strm, sourceLen) wraplen = 6; } - /* if not default parameters, return conservative bound */ + /* if not default parameters, return one of the conservative bounds */ if (s->w_bits != 15 || s->hash_bits != 8 + 7) - return complen + wraplen; + return (s->w_bits <= s->hash_bits ? fixedlen : storelen) + wraplen; - /* default settings: return tight bound for that case */ + /* default settings: return tight bound for that case -- ~0.03% overhead + plus a small constant */ return sourceLen + (sourceLen >> 12) + (sourceLen >> 14) + (sourceLen >> 25) + 13 - 6 + wraplen; } @@ -754,7 +765,7 @@ uLong ZEXPORT deflateBound(strm, sourceLen) * IN assertion: the stream state is correct and there is enough room in * pending_buf. */ -local void putShortMSB (s, b) +local void putShortMSB(s, b) deflate_state *s; uInt b; { @@ -801,7 +812,7 @@ local void flush_pending(strm) } while (0) /* ========================================================================= */ -int ZEXPORT deflate (strm, flush) +int ZEXPORT deflate(strm, flush) z_streamp strm; int flush; { @@ -856,7 +867,7 @@ int ZEXPORT deflate (strm, flush) s->status = BUSY_STATE; if (s->status == INIT_STATE) { /* zlib header */ - uInt header = (Z_DEFLATED + ((s->w_bits-8)<<4)) << 8; + uInt header = (Z_DEFLATED + ((s->w_bits - 8) << 4)) << 8; uInt level_flags; if (s->strategy >= Z_HUFFMAN_ONLY || s->level < 2) @@ -1116,7 +1127,7 @@ int ZEXPORT deflate (strm, flush) } /* ========================================================================= */ -int ZEXPORT deflateEnd (strm) +int ZEXPORT deflateEnd(strm) z_streamp strm; { int status; @@ -1142,7 +1153,7 @@ int ZEXPORT deflateEnd (strm) * To simplify the source, this is not supported for 16-bit MSDOS (which * doesn't have enough memory anyway to duplicate compression states). */ -int ZEXPORT deflateCopy (dest, source) +int ZEXPORT deflateCopy(dest, source) z_streamp dest; z_streamp source; { @@ -1231,7 +1242,7 @@ local unsigned read_buf(strm, buf, size) /* =========================================================================== * Initialize the "longest match" routines for a new zlib stream */ -local void lm_init (s) +local void lm_init(s) deflate_state *s; { s->window_size = (ulg)2L*s->w_size; @@ -1252,11 +1263,6 @@ local void lm_init (s) s->match_length = s->prev_length = MIN_MATCH-1; s->match_available = 0; s->ins_h = 0; -#ifndef FASTEST -#ifdef ASMV - match_init(); /* initialize the asm code */ -#endif -#endif } #ifndef FASTEST @@ -1269,10 +1275,6 @@ local void lm_init (s) * string (strstart) and its distance is <= MAX_DIST, and prev_length >= 1 * OUT assertion: the match length is not greater than s->lookahead. */ -#ifndef ASMV -/* For 80x86 and 680x0, an optimized version will be provided in match.asm or - * match.S. The code will be functionally equivalent. - */ local uInt longest_match(s, cur_match) deflate_state *s; IPos cur_match; /* current match */ @@ -1297,10 +1299,10 @@ local uInt longest_match(s, cur_match) */ register Bytef *strend = s->window + s->strstart + MAX_MATCH - 1; register ush scan_start = *(ushf*)scan; - register ush scan_end = *(ushf*)(scan+best_len-1); + register ush scan_end = *(ushf*)(scan + best_len - 1); #else register Bytef *strend = s->window + s->strstart + MAX_MATCH; - register Byte scan_end1 = scan[best_len-1]; + register Byte scan_end1 = scan[best_len - 1]; register Byte scan_end = scan[best_len]; #endif @@ -1318,7 +1320,8 @@ local uInt longest_match(s, cur_match) */ if ((uInt)nice_match > s->lookahead) nice_match = (int)s->lookahead; - Assert((ulg)s->strstart <= s->window_size-MIN_LOOKAHEAD, "need lookahead"); + Assert((ulg)s->strstart <= s->window_size - MIN_LOOKAHEAD, + "need lookahead"); do { Assert(cur_match < s->strstart, "no future"); @@ -1336,43 +1339,44 @@ local uInt longest_match(s, cur_match) /* This code assumes sizeof(unsigned short) == 2. Do not use * UNALIGNED_OK if your compiler uses a different size. */ - if (*(ushf*)(match+best_len-1) != scan_end || + if (*(ushf*)(match + best_len - 1) != scan_end || *(ushf*)match != scan_start) continue; /* It is not necessary to compare scan[2] and match[2] since they are * always equal when the other bytes match, given that the hash keys * are equal and that HASH_BITS >= 8. Compare 2 bytes at a time at - * strstart+3, +5, ... up to strstart+257. We check for insufficient + * strstart + 3, + 5, up to strstart + 257. We check for insufficient * lookahead only every 4th comparison; the 128th check will be made - * at strstart+257. If MAX_MATCH-2 is not a multiple of 8, it is + * at strstart + 257. If MAX_MATCH-2 is not a multiple of 8, it is * necessary to put more guard bytes at the end of the window, or * to check more often for insufficient lookahead. */ Assert(scan[2] == match[2], "scan[2]?"); scan++, match++; do { - } while (*(ushf*)(scan+=2) == *(ushf*)(match+=2) && - *(ushf*)(scan+=2) == *(ushf*)(match+=2) && - *(ushf*)(scan+=2) == *(ushf*)(match+=2) && - *(ushf*)(scan+=2) == *(ushf*)(match+=2) && + } while (*(ushf*)(scan += 2) == *(ushf*)(match += 2) && + *(ushf*)(scan += 2) == *(ushf*)(match += 2) && + *(ushf*)(scan += 2) == *(ushf*)(match += 2) && + *(ushf*)(scan += 2) == *(ushf*)(match += 2) && scan < strend); /* The funny "do {}" generates better code on most compilers */ - /* Here, scan <= window+strstart+257 */ - Assert(scan <= s->window+(unsigned)(s->window_size-1), "wild scan"); + /* Here, scan <= window + strstart + 257 */ + Assert(scan <= s->window + (unsigned)(s->window_size - 1), + "wild scan"); if (*scan == *match) scan++; - len = (MAX_MATCH - 1) - (int)(strend-scan); + len = (MAX_MATCH - 1) - (int)(strend - scan); scan = strend - (MAX_MATCH-1); #else /* UNALIGNED_OK */ - if (match[best_len] != scan_end || - match[best_len-1] != scan_end1 || - *match != *scan || - *++match != scan[1]) continue; + if (match[best_len] != scan_end || + match[best_len - 1] != scan_end1 || + *match != *scan || + *++match != scan[1]) continue; - /* The check at best_len-1 can be removed because it will be made + /* The check at best_len - 1 can be removed because it will be made * again later. (This heuristic is not always a win.) * It is not necessary to compare scan[2] and match[2] since they * are always equal when the other bytes match, given that @@ -1382,7 +1386,7 @@ local uInt longest_match(s, cur_match) Assert(*scan == *match, "match[2]?"); /* We check for insufficient lookahead only every 8th comparison; - * the 256th check will be made at strstart+258. + * the 256th check will be made at strstart + 258. */ do { } while (*++scan == *++match && *++scan == *++match && @@ -1391,7 +1395,8 @@ local uInt longest_match(s, cur_match) *++scan == *++match && *++scan == *++match && scan < strend); - Assert(scan <= s->window+(unsigned)(s->window_size-1), "wild scan"); + Assert(scan <= s->window + (unsigned)(s->window_size - 1), + "wild scan"); len = MAX_MATCH - (int)(strend - scan); scan = strend - MAX_MATCH; @@ -1403,9 +1408,9 @@ local uInt longest_match(s, cur_match) best_len = len; if (len >= nice_match) break; #ifdef UNALIGNED_OK - scan_end = *(ushf*)(scan+best_len-1); + scan_end = *(ushf*)(scan + best_len - 1); #else - scan_end1 = scan[best_len-1]; + scan_end1 = scan[best_len - 1]; scan_end = scan[best_len]; #endif } @@ -1415,7 +1420,6 @@ local uInt longest_match(s, cur_match) if ((uInt)best_len <= s->lookahead) return (uInt)best_len; return s->lookahead; } -#endif /* ASMV */ #else /* FASTEST */ @@ -1436,7 +1440,8 @@ local uInt longest_match(s, cur_match) */ Assert(s->hash_bits >= 8 && MAX_MATCH == 258, "Code too clever"); - Assert((ulg)s->strstart <= s->window_size-MIN_LOOKAHEAD, "need lookahead"); + Assert((ulg)s->strstart <= s->window_size - MIN_LOOKAHEAD, + "need lookahead"); Assert(cur_match < s->strstart, "no future"); @@ -1446,7 +1451,7 @@ local uInt longest_match(s, cur_match) */ if (match[0] != scan[0] || match[1] != scan[1]) return MIN_MATCH-1; - /* The check at best_len-1 can be removed because it will be made + /* The check at best_len - 1 can be removed because it will be made * again later. (This heuristic is not always a win.) * It is not necessary to compare scan[2] and match[2] since they * are always equal when the other bytes match, given that @@ -1456,7 +1461,7 @@ local uInt longest_match(s, cur_match) Assert(*scan == *match, "match[2]?"); /* We check for insufficient lookahead only every 8th comparison; - * the 256th check will be made at strstart+258. + * the 256th check will be made at strstart + 258. */ do { } while (*++scan == *++match && *++scan == *++match && @@ -1465,7 +1470,7 @@ local uInt longest_match(s, cur_match) *++scan == *++match && *++scan == *++match && scan < strend); - Assert(scan <= s->window+(unsigned)(s->window_size-1), "wild scan"); + Assert(scan <= s->window + (unsigned)(s->window_size - 1), "wild scan"); len = MAX_MATCH - (int)(strend - scan); @@ -1501,7 +1506,7 @@ local void check_match(s, start, match, length) z_error("invalid match"); } if (z_verbose > 1) { - fprintf(stderr,"\\[%d,%d]", start-match, length); + fprintf(stderr,"\\[%d,%d]", start - match, length); do { putc(s->window[start++], stderr); } while (--length != 0); } } @@ -1547,9 +1552,9 @@ local void fill_window(s) /* If the window is almost full and there is insufficient lookahead, * move the upper half to the lower one to make room in the upper half. */ - if (s->strstart >= wsize+MAX_DIST(s)) { + if (s->strstart >= wsize + MAX_DIST(s)) { - zmemcpy(s->window, s->window+wsize, (unsigned)wsize - more); + zmemcpy(s->window, s->window + wsize, (unsigned)wsize - more); s->match_start -= wsize; s->strstart -= wsize; /* we now have strstart >= MAX_DIST */ s->block_start -= (long) wsize; @@ -1680,7 +1685,7 @@ local void fill_window(s) * * deflate_stored() is written to minimize the number of times an input byte is * copied. It is most efficient with large input and output buffers, which - * maximizes the opportunites to have a single copy from next_in to next_out. + * maximizes the opportunities to have a single copy from next_in to next_out. */ local block_state deflate_stored(s, flush) deflate_state *s; @@ -1890,7 +1895,7 @@ local block_state deflate_fast(s, flush) if (s->lookahead == 0) break; /* flush the current block */ } - /* Insert the string window[strstart .. strstart+2] in the + /* Insert the string window[strstart .. strstart + 2] in the * dictionary, and set hash_head to the head of the hash chain: */ hash_head = NIL; @@ -1938,7 +1943,7 @@ local block_state deflate_fast(s, flush) s->strstart += s->match_length; s->match_length = 0; s->ins_h = s->window[s->strstart]; - UPDATE_HASH(s, s->ins_h, s->window[s->strstart+1]); + UPDATE_HASH(s, s->ins_h, s->window[s->strstart + 1]); #if MIN_MATCH != 3 Call UPDATE_HASH() MIN_MATCH-3 more times #endif @@ -1949,7 +1954,7 @@ local block_state deflate_fast(s, flush) } else { /* No match, output a literal byte */ Tracevv((stderr,"%c", s->window[s->strstart])); - _tr_tally_lit (s, s->window[s->strstart], bflush); + _tr_tally_lit(s, s->window[s->strstart], bflush); s->lookahead--; s->strstart++; } @@ -1993,7 +1998,7 @@ local block_state deflate_slow(s, flush) if (s->lookahead == 0) break; /* flush the current block */ } - /* Insert the string window[strstart .. strstart+2] in the + /* Insert the string window[strstart .. strstart + 2] in the * dictionary, and set hash_head to the head of the hash chain: */ hash_head = NIL; @@ -2035,17 +2040,17 @@ local block_state deflate_slow(s, flush) uInt max_insert = s->strstart + s->lookahead - MIN_MATCH; /* Do not insert strings in hash table beyond this. */ - check_match(s, s->strstart-1, s->prev_match, s->prev_length); + check_match(s, s->strstart - 1, s->prev_match, s->prev_length); - _tr_tally_dist(s, s->strstart -1 - s->prev_match, + _tr_tally_dist(s, s->strstart - 1 - s->prev_match, s->prev_length - MIN_MATCH, bflush); /* Insert in hash table all strings up to the end of the match. - * strstart-1 and strstart are already inserted. If there is not + * strstart - 1 and strstart are already inserted. If there is not * enough lookahead, the last two strings are not inserted in * the hash table. */ - s->lookahead -= s->prev_length-1; + s->lookahead -= s->prev_length - 1; s->prev_length -= 2; do { if (++s->strstart <= max_insert) { @@ -2063,8 +2068,8 @@ local block_state deflate_slow(s, flush) * single literal. If there was a match but the current match * is longer, truncate the previous match to a single literal. */ - Tracevv((stderr,"%c", s->window[s->strstart-1])); - _tr_tally_lit(s, s->window[s->strstart-1], bflush); + Tracevv((stderr,"%c", s->window[s->strstart - 1])); + _tr_tally_lit(s, s->window[s->strstart - 1], bflush); if (bflush) { FLUSH_BLOCK_ONLY(s, 0); } @@ -2082,8 +2087,8 @@ local block_state deflate_slow(s, flush) } Assert (flush != Z_NO_FLUSH, "no flush?"); if (s->match_available) { - Tracevv((stderr,"%c", s->window[s->strstart-1])); - _tr_tally_lit(s, s->window[s->strstart-1], bflush); + Tracevv((stderr,"%c", s->window[s->strstart - 1])); + _tr_tally_lit(s, s->window[s->strstart - 1], bflush); s->match_available = 0; } s->insert = s->strstart < MIN_MATCH-1 ? s->strstart : MIN_MATCH-1; @@ -2140,7 +2145,8 @@ local block_state deflate_rle(s, flush) if (s->match_length > s->lookahead) s->match_length = s->lookahead; } - Assert(scan <= s->window+(uInt)(s->window_size-1), "wild scan"); + Assert(scan <= s->window + (uInt)(s->window_size - 1), + "wild scan"); } /* Emit match if have run of MIN_MATCH or longer, else emit literal */ @@ -2155,7 +2161,7 @@ local block_state deflate_rle(s, flush) } else { /* No match, output a literal byte */ Tracevv((stderr,"%c", s->window[s->strstart])); - _tr_tally_lit (s, s->window[s->strstart], bflush); + _tr_tally_lit(s, s->window[s->strstart], bflush); s->lookahead--; s->strstart++; } @@ -2195,7 +2201,7 @@ local block_state deflate_huff(s, flush) /* Output a literal byte */ s->match_length = 0; Tracevv((stderr,"%c", s->window[s->strstart])); - _tr_tally_lit (s, s->window[s->strstart], bflush); + _tr_tally_lit(s, s->window[s->strstart], bflush); s->lookahead--; s->strstart++; if (bflush) FLUSH_BLOCK(s, 0); diff --git a/compat/zlib/examples/enough.c b/compat/zlib/examples/enough.c index 19cf08c..8a3cade 100644 --- a/compat/zlib/examples/enough.c +++ b/compat/zlib/examples/enough.c @@ -486,7 +486,7 @@ local void enough(int syms) { // are 286, 9, and 15 respectively, for the deflate literal/length code. The // possible codes are counted for each number of coded symbols from two to the // maximum. The counts for each of those and the total number of codes are -// shown. The maximum number of inflate table entires is then calculated across +// shown. The maximum number of inflate table entries is then calculated across // all possible codes. Each new maximum number of table entries and the // associated sub-code (starting at root + 1 == 10 bits) is shown. // diff --git a/compat/zlib/examples/fitblk.c b/compat/zlib/examples/fitblk.c index c61de5c..68f5680 100644 --- a/compat/zlib/examples/fitblk.c +++ b/compat/zlib/examples/fitblk.c @@ -17,7 +17,7 @@ data in order to determine how much of that input will compress to nearly the requested output block size. The first pass generates enough deflate blocks to produce output to fill the requested - output size plus a specfied excess amount (see the EXCESS define + output size plus a specified excess amount (see the EXCESS define below). The last deflate block may go quite a bit past that, but is discarded. The second pass decompresses and recompresses just the compressed data that fit in the requested plus excess sized @@ -109,7 +109,7 @@ local int recompress(z_streamp inf, z_streamp def) if (ret == Z_MEM_ERROR) return ret; - /* compress what was decompresed until done or no room */ + /* compress what was decompressed until done or no room */ def->avail_in = RAWLEN - inf->avail_out; def->next_in = raw; if (inf->avail_out != 0) diff --git a/compat/zlib/examples/gun.c b/compat/zlib/examples/gun.c index be44fa5..bea5497 100644 --- a/compat/zlib/examples/gun.c +++ b/compat/zlib/examples/gun.c @@ -43,7 +43,7 @@ gun will also decompress files made by Unix compress, which uses LZW compression. These files are automatically detected by virtue of their magic header bytes. Since the end of Unix compress stream is marked by the - end-of-file, they cannot be concantenated. If a Unix compress stream is + end-of-file, they cannot be concatenated. If a Unix compress stream is encountered in an input file, it is the last stream in that file. Like gunzip and uncompress, the file attributes of the original compressed diff --git a/compat/zlib/examples/gzappend.c b/compat/zlib/examples/gzappend.c index d7eea3e..23e93cf 100644 --- a/compat/zlib/examples/gzappend.c +++ b/compat/zlib/examples/gzappend.c @@ -33,7 +33,7 @@ * - Add L to constants in lseek() calls * - Remove some debugging information in error messages * - Use new data_type definition for zlib 1.2.1 - * - Simplfy and unify file operations + * - Simplify and unify file operations * - Finish off gzip file in gztack() * - Use deflatePrime() instead of adding empty blocks * - Keep gzip file clean on appended file read errors @@ -54,7 +54,7 @@ block boundary to facilitate locating and modifying the last block bit at the start of the final deflate block. Also whether using Z_BLOCK or not, another required feature of zlib 1.2.x is that inflate() now provides the - number of unusued bits in the last input byte used. gzappend will not work + number of unused bits in the last input byte used. gzappend will not work with versions of zlib earlier than 1.2.1. gzappend first decompresses the gzip file internally, discarding all but diff --git a/compat/zlib/examples/gzlog.h b/compat/zlib/examples/gzlog.h index 86f0cec..4f05109 100644 --- a/compat/zlib/examples/gzlog.h +++ b/compat/zlib/examples/gzlog.h @@ -40,7 +40,7 @@ its new size at that time. After each write operation, the log file is a valid gzip file that can decompressed to recover what was written. - The gzlog operations can be interupted at any point due to an application or + The gzlog operations can be interrupted at any point due to an application or system crash, and the log file will be recovered the next time the log is opened with gzlog_open(). */ diff --git a/compat/zlib/examples/zran.c b/compat/zlib/examples/zran.c index f279db7..879c47c 100644 --- a/compat/zlib/examples/zran.c +++ b/compat/zlib/examples/zran.c @@ -21,7 +21,7 @@ An access point can be created at the start of any deflate block, by saving the starting file offset and bit of that block, and the 32K bytes of uncompressed data that precede that block. Also the uncompressed offset of - that block is saved to provide a referece for locating a desired starting + that block is saved to provide a reference for locating a desired starting point in the uncompressed stream. deflate_index_build() works by decompressing the input zlib or gzip stream a block at a time, and at the end of each block deciding if enough uncompressed data has gone by to diff --git a/compat/zlib/gzlib.c b/compat/zlib/gzlib.c index dddaf26..55da46a 100644 --- a/compat/zlib/gzlib.c +++ b/compat/zlib/gzlib.c @@ -30,7 +30,7 @@ local gzFile gz_open OF((const void *, int, const char *)); The gz_strwinerror function does not change the current setting of GetLastError. */ -char ZLIB_INTERNAL *gz_strwinerror (error) +char ZLIB_INTERNAL *gz_strwinerror(error) DWORD error; { static char buf[1024]; diff --git a/compat/zlib/gzread.c b/compat/zlib/gzread.c index 884c9bf..dd77381 100644 --- a/compat/zlib/gzread.c +++ b/compat/zlib/gzread.c @@ -157,11 +157,9 @@ local int gz_look(state) the output buffer is larger than the input buffer, which also assures space for gzungetc() */ state->x.next = state->out; - if (strm->avail_in) { - memcpy(state->x.next, strm->next_in, strm->avail_in); - state->x.have = strm->avail_in; - strm->avail_in = 0; - } + memcpy(state->x.next, strm->next_in, strm->avail_in); + state->x.have = strm->avail_in; + strm->avail_in = 0; state->how = COPY; state->direct = 1; return 0; diff --git a/compat/zlib/gzwrite.c b/compat/zlib/gzwrite.c index a8ffc8f..eb8a0e5 100644 --- a/compat/zlib/gzwrite.c +++ b/compat/zlib/gzwrite.c @@ -474,7 +474,7 @@ int ZEXPORTVA gzprintf(gzFile file, const char *format, ...) #else /* !STDC && !Z_HAVE_STDARG_H */ /* -- see zlib.h -- */ -int ZEXPORTVA gzprintf (file, format, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, +int ZEXPORTVA gzprintf(file, format, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20) gzFile file; const char *format; diff --git a/compat/zlib/infback.c b/compat/zlib/infback.c index a390c58..babeaf1 100644 --- a/compat/zlib/infback.c +++ b/compat/zlib/infback.c @@ -66,6 +66,7 @@ int stream_size; state->window = window; state->wnext = 0; state->whave = 0; + state->sane = 1; return Z_OK; } @@ -605,25 +606,27 @@ void FAR *out_desc; break; case DONE: - /* inflate stream terminated properly -- write leftover output */ + /* inflate stream terminated properly */ ret = Z_STREAM_END; - if (left < state->wsize) { - if (out(out_desc, state->window, state->wsize - left)) - ret = Z_BUF_ERROR; - } goto inf_leave; case BAD: ret = Z_DATA_ERROR; goto inf_leave; - default: /* can't happen, but makes compilers happy */ + default: + /* can't happen, but makes compilers happy */ ret = Z_STREAM_ERROR; goto inf_leave; } - /* Return unused input */ + /* Write leftover output and return unused input */ inf_leave: + if (left < state->wsize) { + if (out(out_desc, state->window, state->wsize - left) && + ret == Z_STREAM_END) + ret = Z_BUF_ERROR; + } strm->next_in = next; strm->avail_in = have; return ret; diff --git a/compat/zlib/inflate.c b/compat/zlib/inflate.c index 7be8c63..8acbef4 100644 --- a/compat/zlib/inflate.c +++ b/compat/zlib/inflate.c @@ -168,6 +168,8 @@ int windowBits; /* extract wrap request from windowBits parameter */ if (windowBits < 0) { + if (windowBits < -15) + return Z_STREAM_ERROR; wrap = 0; windowBits = -windowBits; } @@ -764,8 +766,9 @@ int flush; if (copy > have) copy = have; if (copy) { if (state->head != Z_NULL && - state->head->extra != Z_NULL) { - len = state->head->extra_len - state->length; + state->head->extra != Z_NULL && + (len = state->head->extra_len - state->length) < + state->head->extra_max) { zmemcpy(state->head->extra + len, next, len + copy > state->head->extra_max ? state->head->extra_max - len : copy); diff --git a/compat/zlib/inftrees.c b/compat/zlib/inftrees.c index a2f386c..57d2793 100644 --- a/compat/zlib/inftrees.c +++ b/compat/zlib/inftrees.c @@ -9,7 +9,7 @@ #define MAXBITS 15 const char inflate_copyright[] = - " inflate 1.2.12 Copyright 1995-2022 Mark Adler "; + " inflate 1.2.13 Copyright 1995-2022 Mark Adler "; /* If you use the zlib library in a product, an acknowledgment is welcome in the documentation of your product. If for some reason you cannot @@ -62,7 +62,7 @@ unsigned short FAR *work; 35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258, 0, 0}; static const unsigned short lext[31] = { /* Length codes 257..285 extra */ 16, 16, 16, 16, 16, 16, 16, 16, 17, 17, 17, 17, 18, 18, 18, 18, - 19, 19, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 16, 76, 202}; + 19, 19, 19, 19, 20, 20, 20, 20, 21, 21, 21, 21, 16, 194, 65}; static const unsigned short dbase[32] = { /* Distance codes 0..29 base */ 1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193, 257, 385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145, diff --git a/compat/zlib/inftrees.h b/compat/zlib/inftrees.h index baa53a0..f536653 100644 --- a/compat/zlib/inftrees.h +++ b/compat/zlib/inftrees.h @@ -38,7 +38,7 @@ typedef struct { /* Maximum size of the dynamic table. The maximum number of code structures is 1444, which is the sum of 852 for literal/length codes and 592 for distance codes. These values were found by exhaustive searches using the program - examples/enough.c found in the zlib distribtution. The arguments to that + examples/enough.c found in the zlib distribution. The arguments to that program are the number of symbols, the initial root table size, and the maximum bit length of a code. "enough 286 9 15" for literal/length codes returns returns 852, and "enough 30 6 15" for distance codes returns 592. diff --git a/compat/zlib/make_vms.com b/compat/zlib/make_vms.com index 65e9d0c..4dc8a89 100644 --- a/compat/zlib/make_vms.com +++ b/compat/zlib/make_vms.com @@ -14,9 +14,9 @@ $! 0.02 20061008 Adapt to new Makefile.in $! 0.03 20091224 Add support for large file check $! 0.04 20100110 Add new gzclose, gzlib, gzread, gzwrite $! 0.05 20100221 Exchange zlibdefs.h by zconf.h.in -$! 0.06 20120111 Fix missing amiss_err, update zconf_h.in, fix new exmples +$! 0.06 20120111 Fix missing amiss_err, update zconf_h.in, fix new examples $! subdir path, update module search in makefile.in -$! 0.07 20120115 Triggered by work done by Alexey Chupahin completly redesigned +$! 0.07 20120115 Triggered by work done by Alexey Chupahin completely redesigned $! shared image creation $! 0.08 20120219 Make it work on VAX again, pre-load missing symbols to shared $! image diff --git a/compat/zlib/os400/README400 b/compat/zlib/os400/README400 index 10f6c9d..c06fa84 100644 --- a/compat/zlib/os400/README400 +++ b/compat/zlib/os400/README400 @@ -1,9 +1,9 @@ - ZLIB version 1.2.12 for OS/400 installation instructions + ZLIB version 1.2.13 for OS/400 installation instructions 1) Download and unpack the zlib tarball to some IFS directory. (i.e.: /path/to/the/zlib/ifs/source/directory) - If the installed IFS command suppors gzip format, this is straightforward, + If the installed IFS command supports gzip format, this is straightforward, else you have to unpack first to some directory on a system supporting it, then move the whole directory to the IFS via the network (via SMB or FTP). @@ -43,6 +43,6 @@ Notes: For OS/400 ILE RPG programmers, a /copy member defining the ZLIB Remember that most foreign textual data are ASCII coded: this implementation does not handle conversion from/to ASCII, so - text data code conversions must be done explicitely. + text data code conversions must be done explicitly. Mainly for the reason above, always open zipped files in binary mode. diff --git a/compat/zlib/os400/bndsrc b/compat/zlib/os400/bndsrc index 5e6e0a2..9f92bb1 100644 --- a/compat/zlib/os400/bndsrc +++ b/compat/zlib/os400/bndsrc @@ -116,4 +116,12 @@ STRPGMEXP PGMLVL(*CURRENT) SIGNATURE('ZLIB') EXPORT SYMBOL("inflateValidate") EXPORT SYMBOL("uncompress2") +/*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*/ +/* Version 1.2.12 additional entry points. */ +/*@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@*/ + + EXPORT SYMBOL("crc32_combine_gen64") + EXPORT SYMBOL("crc32_combine_gen") + EXPORT SYMBOL("crc32_combine_op") + ENDPGMEXP diff --git a/compat/zlib/os400/zlib.inc b/compat/zlib/os400/zlib.inc index fda156b..c273c86 100644 --- a/compat/zlib/os400/zlib.inc +++ b/compat/zlib/os400/zlib.inc @@ -1,7 +1,7 @@ * ZLIB.INC - Interface to the general purpose compression library * * ILE RPG400 version by Patrick Monnerat, DATASPHERE. - * Version 1.2.12 + * Version 1.2.13 * * * WARNING: @@ -22,12 +22,12 @@ * * Versioning information. * - D ZLIB_VERSION C '1.2.12' + D ZLIB_VERSION C '1.2.13' D ZLIB_VERNUM C X'12a0' D ZLIB_VER_MAJOR C 1 D ZLIB_VER_MINOR C 2 D ZLIB_VER_REVISION... - D C 12 + D C 13 D ZLIB_VER_SUBREVISION... D C 0 * diff --git a/compat/zlib/qnx/package.qpg b/compat/zlib/qnx/package.qpg index badd1d5..ba2f1a2 100644 --- a/compat/zlib/qnx/package.qpg +++ b/compat/zlib/qnx/package.qpg @@ -25,10 +25,10 @@ - - - - + + + + @@ -63,7 +63,7 @@ - 1.2.12 + 1.2.13 Medium Stable diff --git a/compat/zlib/test/example.c b/compat/zlib/test/example.c index 949f4f6..1470bc8 100644 --- a/compat/zlib/test/example.c +++ b/compat/zlib/test/example.c @@ -555,7 +555,8 @@ int main(argc, argv) exit(1); } else if (strcmp(zlibVersion(), ZLIB_VERSION) != 0) { - fprintf(stderr, "warning: different zlib version\n"); + fprintf(stderr, "warning: different zlib version linked: %s\n", + zlibVersion()); } printf("zlib version %s = 0x%04x, compile flags = 0x%lx\n", diff --git a/compat/zlib/test/minigzip.c b/compat/zlib/test/minigzip.c index e22fb08..a649d2b 100644 --- a/compat/zlib/test/minigzip.c +++ b/compat/zlib/test/minigzip.c @@ -500,7 +500,7 @@ void file_uncompress(file) char *infile, *outfile; FILE *out; gzFile in; - unsigned len = strlen(file); + z_size_t len = strlen(file); if (len + strlen(GZ_SUFFIX) >= sizeof(buf)) { fprintf(stderr, "%s: filename too long\n", prog); diff --git a/compat/zlib/treebuild.xml b/compat/zlib/treebuild.xml index 781b4c9..0017a45 100644 --- a/compat/zlib/treebuild.xml +++ b/compat/zlib/treebuild.xml @@ -1,6 +1,6 @@ - - + + zip compression library diff --git a/compat/zlib/trees.c b/compat/zlib/trees.c index 8b438cc..5f305c4 100644 --- a/compat/zlib/trees.c +++ b/compat/zlib/trees.c @@ -193,7 +193,7 @@ local void send_bits(s, value, length) s->bits_sent += (ulg)length; /* If not enough room in bi_buf, use (valid) bits from bi_buf and - * (16 - bi_valid) bits from value, leaving (width - (16-bi_valid)) + * (16 - bi_valid) bits from value, leaving (width - (16 - bi_valid)) * unused bits in value. */ if (s->bi_valid > (int)Buf_size - length) { @@ -256,7 +256,7 @@ local void tr_static_init() length = 0; for (code = 0; code < LENGTH_CODES-1; code++) { base_length[code] = length; - for (n = 0; n < (1< dist code (0..29) */ dist = 0; for (code = 0 ; code < 16; code++) { base_dist[code] = dist; - for (n = 0; n < (1<>= 7; /* from now on, all distances are divided by 128 */ for ( ; code < D_CODES; code++) { base_dist[code] = dist << 7; - for (n = 0; n < (1<<(extra_dbits[code]-7)); n++) { + for (n = 0; n < (1 << (extra_dbits[code] - 7)); n++) { _dist_code[256 + dist++] = (uch)code; } } - Assert (dist == 256, "tr_static_init: 256+dist != 512"); + Assert (dist == 256, "tr_static_init: 256 + dist != 512"); /* Construct the codes of the static literal tree */ for (bits = 0; bits <= MAX_BITS; bits++) bl_count[bits] = 0; @@ -312,7 +312,7 @@ local void tr_static_init() } /* =========================================================================== - * Genererate the file trees.h describing the static trees. + * Generate the file trees.h describing the static trees. */ #ifdef GEN_TREES_H # ifndef ZLIB_DEBUG @@ -321,7 +321,7 @@ local void tr_static_init() # define SEPARATOR(i, last, width) \ ((i) == (last)? "\n};\n\n" : \ - ((i) % (width) == (width)-1 ? ",\n" : ", ")) + ((i) % (width) == (width) - 1 ? ",\n" : ", ")) void gen_trees_header() { @@ -458,7 +458,7 @@ local void pqdownheap(s, tree, k) while (j <= s->heap_len) { /* Set j to the smallest of the two sons: */ if (j < s->heap_len && - smaller(tree, s->heap[j+1], s->heap[j], s->depth)) { + smaller(tree, s->heap[j + 1], s->heap[j], s->depth)) { j++; } /* Exit if v is smaller than both sons */ @@ -507,7 +507,7 @@ local void gen_bitlen(s, desc) */ tree[s->heap[s->heap_max]].Len = 0; /* root of the heap */ - for (h = s->heap_max+1; h < HEAP_SIZE; h++) { + for (h = s->heap_max + 1; h < HEAP_SIZE; h++) { n = s->heap[h]; bits = tree[tree[n].Dad].Len + 1; if (bits > max_length) bits = max_length, overflow++; @@ -518,7 +518,7 @@ local void gen_bitlen(s, desc) s->bl_count[bits]++; xbits = 0; - if (n >= base) xbits = extra[n-base]; + if (n >= base) xbits = extra[n - base]; f = tree[n].Freq; s->opt_len += (ulg)f * (unsigned)(bits + xbits); if (stree) s->static_len += (ulg)f * (unsigned)(stree[n].Len + xbits); @@ -530,10 +530,10 @@ local void gen_bitlen(s, desc) /* Find the first bit length which could increase: */ do { - bits = max_length-1; + bits = max_length - 1; while (s->bl_count[bits] == 0) bits--; - s->bl_count[bits]--; /* move one leaf down the tree */ - s->bl_count[bits+1] += 2; /* move one overflow item as its brother */ + s->bl_count[bits]--; /* move one leaf down the tree */ + s->bl_count[bits + 1] += 2; /* move one overflow item as its brother */ s->bl_count[max_length]--; /* The brother of the overflow item also moves one step up, * but this does not affect bl_count[max_length] @@ -569,7 +569,7 @@ local void gen_bitlen(s, desc) * OUT assertion: the field code is set for all tree elements of non * zero code length. */ -local void gen_codes (tree, max_code, bl_count) +local void gen_codes(tree, max_code, bl_count) ct_data *tree; /* the tree to decorate */ int max_code; /* largest code with non zero frequency */ ushf *bl_count; /* number of codes at each bit length */ @@ -583,13 +583,13 @@ local void gen_codes (tree, max_code, bl_count) * without bit reversal. */ for (bits = 1; bits <= MAX_BITS; bits++) { - code = (code + bl_count[bits-1]) << 1; + code = (code + bl_count[bits - 1]) << 1; next_code[bits] = (ush)code; } /* Check that the bit counts in bl_count are consistent. The last code * must be all ones. */ - Assert (code + bl_count[MAX_BITS]-1 == (1<heap_len = 0, s->heap_max = HEAP_SIZE; @@ -652,7 +652,7 @@ local void build_tree(s, desc) } desc->max_code = max_code; - /* The elements heap[heap_len/2+1 .. heap_len] are leaves of the tree, + /* The elements heap[heap_len/2 + 1 .. heap_len] are leaves of the tree, * establish sub-heaps of increasing lengths: */ for (n = s->heap_len/2; n >= 1; n--) pqdownheap(s, tree, n); @@ -700,7 +700,7 @@ local void build_tree(s, desc) * Scan a literal or distance tree to determine the frequencies of the codes * in the bit length tree. */ -local void scan_tree (s, tree, max_code) +local void scan_tree(s, tree, max_code) deflate_state *s; ct_data *tree; /* the tree to be scanned */ int max_code; /* and its largest code of non zero frequency */ @@ -714,10 +714,10 @@ local void scan_tree (s, tree, max_code) int min_count = 4; /* min repeat count */ if (nextlen == 0) max_count = 138, min_count = 3; - tree[max_code+1].Len = (ush)0xffff; /* guard */ + tree[max_code + 1].Len = (ush)0xffff; /* guard */ for (n = 0; n <= max_code; n++) { - curlen = nextlen; nextlen = tree[n+1].Len; + curlen = nextlen; nextlen = tree[n + 1].Len; if (++count < max_count && curlen == nextlen) { continue; } else if (count < min_count) { @@ -745,7 +745,7 @@ local void scan_tree (s, tree, max_code) * Send a literal or distance tree in compressed form, using the codes in * bl_tree. */ -local void send_tree (s, tree, max_code) +local void send_tree(s, tree, max_code) deflate_state *s; ct_data *tree; /* the tree to be scanned */ int max_code; /* and its largest code of non zero frequency */ @@ -758,11 +758,11 @@ local void send_tree (s, tree, max_code) int max_count = 7; /* max repeat count */ int min_count = 4; /* min repeat count */ - /* tree[max_code+1].Len = -1; */ /* guard already set */ + /* tree[max_code + 1].Len = -1; */ /* guard already set */ if (nextlen == 0) max_count = 138, min_count = 3; for (n = 0; n <= max_code; n++) { - curlen = nextlen; nextlen = tree[n+1].Len; + curlen = nextlen; nextlen = tree[n + 1].Len; if (++count < max_count && curlen == nextlen) { continue; } else if (count < min_count) { @@ -773,13 +773,13 @@ local void send_tree (s, tree, max_code) send_code(s, curlen, s->bl_tree); count--; } Assert(count >= 3 && count <= 6, " 3_6?"); - send_code(s, REP_3_6, s->bl_tree); send_bits(s, count-3, 2); + send_code(s, REP_3_6, s->bl_tree); send_bits(s, count - 3, 2); } else if (count <= 10) { - send_code(s, REPZ_3_10, s->bl_tree); send_bits(s, count-3, 3); + send_code(s, REPZ_3_10, s->bl_tree); send_bits(s, count - 3, 3); } else { - send_code(s, REPZ_11_138, s->bl_tree); send_bits(s, count-11, 7); + send_code(s, REPZ_11_138, s->bl_tree); send_bits(s, count - 11, 7); } count = 0; prevlen = curlen; if (nextlen == 0) { @@ -807,8 +807,8 @@ local int build_bl_tree(s) /* Build the bit length tree: */ build_tree(s, (tree_desc *)(&(s->bl_desc))); - /* opt_len now includes the length of the tree representations, except - * the lengths of the bit lengths codes and the 5+5+4 bits for the counts. + /* opt_len now includes the length of the tree representations, except the + * lengths of the bit lengths codes and the 5 + 5 + 4 bits for the counts. */ /* Determine the number of bit length codes to send. The pkzip format @@ -819,7 +819,7 @@ local int build_bl_tree(s) if (s->bl_tree[bl_order[max_blindex]].Len != 0) break; } /* Update opt_len to include the bit length tree and counts */ - s->opt_len += 3*((ulg)max_blindex+1) + 5+5+4; + s->opt_len += 3*((ulg)max_blindex + 1) + 5 + 5 + 4; Tracev((stderr, "\ndyn trees: dyn %ld, stat %ld", s->opt_len, s->static_len)); @@ -841,19 +841,19 @@ local void send_all_trees(s, lcodes, dcodes, blcodes) Assert (lcodes <= L_CODES && dcodes <= D_CODES && blcodes <= BL_CODES, "too many codes"); Tracev((stderr, "\nbl counts: ")); - send_bits(s, lcodes-257, 5); /* not +255 as stated in appnote.txt */ - send_bits(s, dcodes-1, 5); - send_bits(s, blcodes-4, 4); /* not -3 as stated in appnote.txt */ + send_bits(s, lcodes - 257, 5); /* not +255 as stated in appnote.txt */ + send_bits(s, dcodes - 1, 5); + send_bits(s, blcodes - 4, 4); /* not -3 as stated in appnote.txt */ for (rank = 0; rank < blcodes; rank++) { Tracev((stderr, "\nbl code %2d ", bl_order[rank])); send_bits(s, s->bl_tree[bl_order[rank]].Len, 3); } Tracev((stderr, "\nbl tree: sent %ld", s->bits_sent)); - send_tree(s, (ct_data *)s->dyn_ltree, lcodes-1); /* literal tree */ + send_tree(s, (ct_data *)s->dyn_ltree, lcodes - 1); /* literal tree */ Tracev((stderr, "\nlit tree: sent %ld", s->bits_sent)); - send_tree(s, (ct_data *)s->dyn_dtree, dcodes-1); /* distance tree */ + send_tree(s, (ct_data *)s->dyn_dtree, dcodes - 1); /* distance tree */ Tracev((stderr, "\ndist tree: sent %ld", s->bits_sent)); } @@ -866,7 +866,7 @@ void ZLIB_INTERNAL _tr_stored_block(s, buf, stored_len, last) ulg stored_len; /* length of input block */ int last; /* one if this is the last block for a file */ { - send_bits(s, (STORED_BLOCK<<1)+last, 3); /* send block type */ + send_bits(s, (STORED_BLOCK<<1) + last, 3); /* send block type */ bi_windup(s); /* align on byte boundary */ put_short(s, (ush)stored_len); put_short(s, (ush)~stored_len); @@ -877,7 +877,7 @@ void ZLIB_INTERNAL _tr_stored_block(s, buf, stored_len, last) s->compressed_len = (s->compressed_len + 3 + 7) & (ulg)~7L; s->compressed_len += (stored_len + 4) << 3; s->bits_sent += 2*16; - s->bits_sent += stored_len<<3; + s->bits_sent += stored_len << 3; #endif } @@ -943,14 +943,17 @@ void ZLIB_INTERNAL _tr_flush_block(s, buf, stored_len, last) max_blindex = build_bl_tree(s); /* Determine the best encoding. Compute the block lengths in bytes. */ - opt_lenb = (s->opt_len+3+7)>>3; - static_lenb = (s->static_len+3+7)>>3; + opt_lenb = (s->opt_len + 3 + 7) >> 3; + static_lenb = (s->static_len + 3 + 7) >> 3; Tracev((stderr, "\nopt %lu(%lu) stat %lu(%lu) stored %lu lit %u ", opt_lenb, s->opt_len, static_lenb, s->static_len, stored_len, s->sym_next / 3)); - if (static_lenb <= opt_lenb) opt_lenb = static_lenb; +#ifndef FORCE_STATIC + if (static_lenb <= opt_lenb || s->strategy == Z_FIXED) +#endif + opt_lenb = static_lenb; } else { Assert(buf != (char*)0, "lost buf"); @@ -960,7 +963,7 @@ void ZLIB_INTERNAL _tr_flush_block(s, buf, stored_len, last) #ifdef FORCE_STORED if (buf != (char*)0) { /* force stored block */ #else - if (stored_len+4 <= opt_lenb && buf != (char*)0) { + if (stored_len + 4 <= opt_lenb && buf != (char*)0) { /* 4: two words for the lengths */ #endif /* The test buf != NULL is only necessary if LIT_BUFSIZE > WSIZE. @@ -971,21 +974,17 @@ void ZLIB_INTERNAL _tr_flush_block(s, buf, stored_len, last) */ _tr_stored_block(s, buf, stored_len, last); -#ifdef FORCE_STATIC - } else if (static_lenb >= 0) { /* force static trees */ -#else - } else if (s->strategy == Z_FIXED || static_lenb == opt_lenb) { -#endif - send_bits(s, (STATIC_TREES<<1)+last, 3); + } else if (static_lenb == opt_lenb) { + send_bits(s, (STATIC_TREES<<1) + last, 3); compress_block(s, (const ct_data *)static_ltree, (const ct_data *)static_dtree); #ifdef ZLIB_DEBUG s->compressed_len += 3 + s->static_len; #endif } else { - send_bits(s, (DYN_TREES<<1)+last, 3); - send_all_trees(s, s->l_desc.max_code+1, s->d_desc.max_code+1, - max_blindex+1); + send_bits(s, (DYN_TREES<<1) + last, 3); + send_all_trees(s, s->l_desc.max_code + 1, s->d_desc.max_code + 1, + max_blindex + 1); compress_block(s, (const ct_data *)s->dyn_ltree, (const ct_data *)s->dyn_dtree); #ifdef ZLIB_DEBUG @@ -1004,18 +1003,18 @@ void ZLIB_INTERNAL _tr_flush_block(s, buf, stored_len, last) s->compressed_len += 7; /* align on byte boundary */ #endif } - Tracev((stderr,"\ncomprlen %lu(%lu) ", s->compressed_len>>3, - s->compressed_len-7*last)); + Tracev((stderr,"\ncomprlen %lu(%lu) ", s->compressed_len >> 3, + s->compressed_len - 7*last)); } /* =========================================================================== * Save the match info and tally the frequency counts. Return true if * the current block must be flushed. */ -int ZLIB_INTERNAL _tr_tally (s, dist, lc) +int ZLIB_INTERNAL _tr_tally(s, dist, lc) deflate_state *s; unsigned dist; /* distance of matched string */ - unsigned lc; /* match length-MIN_MATCH or unmatched char (if dist==0) */ + unsigned lc; /* match length - MIN_MATCH or unmatched char (dist==0) */ { s->sym_buf[s->sym_next++] = (uch)dist; s->sym_buf[s->sym_next++] = (uch)(dist >> 8); @@ -1031,7 +1030,7 @@ int ZLIB_INTERNAL _tr_tally (s, dist, lc) (ush)lc <= (ush)(MAX_MATCH-MIN_MATCH) && (ush)d_code(dist) < (ush)D_CODES, "_tr_tally: bad match"); - s->dyn_ltree[_length_code[lc]+LITERALS+1].Freq++; + s->dyn_ltree[_length_code[lc] + LITERALS + 1].Freq++; s->dyn_dtree[d_code(dist)].Freq++; } return (s->sym_next == s->sym_end); @@ -1061,7 +1060,7 @@ local void compress_block(s, ltree, dtree) } else { /* Here, lc is the match length - MIN_MATCH */ code = _length_code[lc]; - send_code(s, code+LITERALS+1, ltree); /* send the length code */ + send_code(s, code + LITERALS + 1, ltree); /* send length code */ extra = extra_lbits[code]; if (extra != 0) { lc -= base_length[code]; @@ -1177,6 +1176,6 @@ local void bi_windup(s) s->bi_buf = 0; s->bi_valid = 0; #ifdef ZLIB_DEBUG - s->bits_sent = (s->bits_sent+7) & ~7; + s->bits_sent = (s->bits_sent + 7) & ~7; #endif } diff --git a/compat/zlib/uncompr.c b/compat/zlib/uncompr.c index f03a1a8..f9532f4 100644 --- a/compat/zlib/uncompr.c +++ b/compat/zlib/uncompr.c @@ -24,7 +24,7 @@ Z_DATA_ERROR if the input data was corrupted, including if the input data is an incomplete zlib stream. */ -int ZEXPORT uncompress2 (dest, destLen, source, sourceLen) +int ZEXPORT uncompress2(dest, destLen, source, sourceLen) Bytef *dest; uLongf *destLen; const Bytef *source; @@ -83,7 +83,7 @@ int ZEXPORT uncompress2 (dest, destLen, source, sourceLen) err; } -int ZEXPORT uncompress (dest, destLen, source, sourceLen) +int ZEXPORT uncompress(dest, destLen, source, sourceLen) Bytef *dest; uLongf *destLen; const Bytef *source; diff --git a/compat/zlib/win32/README-WIN32.txt b/compat/zlib/win32/README-WIN32.txt index 536cfec..050197d 100644 --- a/compat/zlib/win32/README-WIN32.txt +++ b/compat/zlib/win32/README-WIN32.txt @@ -1,6 +1,6 @@ ZLIB DATA COMPRESSION LIBRARY -zlib 1.2.12 is a general purpose data compression library. All the code is +zlib 1.2.13 is a general purpose data compression library. All the code is thread safe. The data format used by the zlib library is described by RFCs (Request for Comments) 1950 to 1952 in the files http://www.ietf.org/rfc/rfc1950.txt (zlib format), rfc1951.txt (deflate format) @@ -22,7 +22,7 @@ before asking for help. Manifest: -The package zlib-1.2.12-win32-x86.zip will contain the following files: +The package zlib-1.2.13-win32-x86.zip will contain the following files: README-WIN32.txt This document ChangeLog Changes since previous zlib packages diff --git a/compat/zlib/win32/zlib1.rc b/compat/zlib/win32/zlib1.rc index 234e641..ceb4ee5 100644 --- a/compat/zlib/win32/zlib1.rc +++ b/compat/zlib/win32/zlib1.rc @@ -26,7 +26,7 @@ BEGIN VALUE "FileDescription", "zlib data compression library\0" VALUE "FileVersion", ZLIB_VERSION "\0" VALUE "InternalName", "zlib1.dll\0" - VALUE "LegalCopyright", "(C) 1995-2017 Jean-loup Gailly & Mark Adler\0" + VALUE "LegalCopyright", "(C) 1995-2022 Jean-loup Gailly & Mark Adler\0" VALUE "OriginalFilename", "zlib1.dll\0" VALUE "ProductName", "zlib\0" VALUE "ProductVersion", ZLIB_VERSION "\0" diff --git a/compat/zlib/zconf.h b/compat/zlib/zconf.h index 5e1d68a..bf977d3 100644 --- a/compat/zlib/zconf.h +++ b/compat/zlib/zconf.h @@ -38,6 +38,9 @@ # define crc32 z_crc32 # define crc32_combine z_crc32_combine # define crc32_combine64 z_crc32_combine64 +# define crc32_combine_gen z_crc32_combine_gen +# define crc32_combine_gen64 z_crc32_combine_gen64 +# define crc32_combine_op z_crc32_combine_op # define crc32_z z_crc32_z # define deflate z_deflate # define deflateBound z_deflateBound @@ -349,6 +352,9 @@ # ifdef FAR # undef FAR # endif +# ifndef WIN32_LEAN_AND_MEAN +# define WIN32_LEAN_AND_MEAN +# endif # include /* No need for _export, use ZLIB.DEF instead. */ /* For complete Windows compatibility, use WINAPI, not __stdcall. */ @@ -467,11 +473,18 @@ typedef uLong FAR uLongf; # undef _LARGEFILE64_SOURCE #endif -#if defined(__WATCOMC__) && !defined(Z_HAVE_UNISTD_H) -# define Z_HAVE_UNISTD_H +#ifndef Z_HAVE_UNISTD_H +# ifdef __WATCOMC__ +# define Z_HAVE_UNISTD_H +# endif +#endif +#ifndef Z_HAVE_UNISTD_H +# if defined(_LARGEFILE64_SOURCE) && !defined(_WIN32) +# define Z_HAVE_UNISTD_H +# endif #endif #ifndef Z_SOLO -# if defined(Z_HAVE_UNISTD_H) || defined(_LARGEFILE64_SOURCE) +# if defined(Z_HAVE_UNISTD_H) # include /* for SEEK_*, off_t, and _LFS64_LARGEFILE */ # ifdef VMS # include /* for off_t */ diff --git a/compat/zlib/zconf.h.cmakein b/compat/zlib/zconf.h.cmakein index a7f24cc..247ba24 100644 --- a/compat/zlib/zconf.h.cmakein +++ b/compat/zlib/zconf.h.cmakein @@ -40,6 +40,9 @@ # define crc32 z_crc32 # define crc32_combine z_crc32_combine # define crc32_combine64 z_crc32_combine64 +# define crc32_combine_gen z_crc32_combine_gen +# define crc32_combine_gen64 z_crc32_combine_gen64 +# define crc32_combine_op z_crc32_combine_op # define crc32_z z_crc32_z # define deflate z_deflate # define deflateBound z_deflateBound @@ -351,6 +354,9 @@ # ifdef FAR # undef FAR # endif +# ifndef WIN32_LEAN_AND_MEAN +# define WIN32_LEAN_AND_MEAN +# endif # include /* No need for _export, use ZLIB.DEF instead. */ /* For complete Windows compatibility, use WINAPI, not __stdcall. */ @@ -469,11 +475,18 @@ typedef uLong FAR uLongf; # undef _LARGEFILE64_SOURCE #endif -#if defined(__WATCOMC__) && !defined(Z_HAVE_UNISTD_H) -# define Z_HAVE_UNISTD_H +#ifndef Z_HAVE_UNISTD_H +# ifdef __WATCOMC__ +# define Z_HAVE_UNISTD_H +# endif +#endif +#ifndef Z_HAVE_UNISTD_H +# if defined(_LARGEFILE64_SOURCE) && !defined(_WIN32) +# define Z_HAVE_UNISTD_H +# endif #endif #ifndef Z_SOLO -# if defined(Z_HAVE_UNISTD_H) || defined(_LARGEFILE64_SOURCE) +# if defined(Z_HAVE_UNISTD_H) # include /* for SEEK_*, off_t, and _LFS64_LARGEFILE */ # ifdef VMS # include /* for off_t */ diff --git a/compat/zlib/zconf.h.in b/compat/zlib/zconf.h.in index 5e1d68a..bf977d3 100644 --- a/compat/zlib/zconf.h.in +++ b/compat/zlib/zconf.h.in @@ -38,6 +38,9 @@ # define crc32 z_crc32 # define crc32_combine z_crc32_combine # define crc32_combine64 z_crc32_combine64 +# define crc32_combine_gen z_crc32_combine_gen +# define crc32_combine_gen64 z_crc32_combine_gen64 +# define crc32_combine_op z_crc32_combine_op # define crc32_z z_crc32_z # define deflate z_deflate # define deflateBound z_deflateBound @@ -349,6 +352,9 @@ # ifdef FAR # undef FAR # endif +# ifndef WIN32_LEAN_AND_MEAN +# define WIN32_LEAN_AND_MEAN +# endif # include /* No need for _export, use ZLIB.DEF instead. */ /* For complete Windows compatibility, use WINAPI, not __stdcall. */ @@ -467,11 +473,18 @@ typedef uLong FAR uLongf; # undef _LARGEFILE64_SOURCE #endif -#if defined(__WATCOMC__) && !defined(Z_HAVE_UNISTD_H) -# define Z_HAVE_UNISTD_H +#ifndef Z_HAVE_UNISTD_H +# ifdef __WATCOMC__ +# define Z_HAVE_UNISTD_H +# endif +#endif +#ifndef Z_HAVE_UNISTD_H +# if defined(_LARGEFILE64_SOURCE) && !defined(_WIN32) +# define Z_HAVE_UNISTD_H +# endif #endif #ifndef Z_SOLO -# if defined(Z_HAVE_UNISTD_H) || defined(_LARGEFILE64_SOURCE) +# if defined(Z_HAVE_UNISTD_H) # include /* for SEEK_*, off_t, and _LFS64_LARGEFILE */ # ifdef VMS # include /* for off_t */ diff --git a/compat/zlib/zlib.3 b/compat/zlib/zlib.3 index bcaebd9..6f6e914 100644 --- a/compat/zlib/zlib.3 +++ b/compat/zlib/zlib.3 @@ -1,4 +1,4 @@ -.TH ZLIB 3 "27 Mar 2022" +.TH ZLIB 3 "13 Oct 2022" .SH NAME zlib \- compression/decompression library .SH SYNOPSIS @@ -105,7 +105,7 @@ before asking for help. Send questions and/or comments to zlib@gzip.org, or (for the Windows DLL version) to Gilles Vollant (info@winimage.com). .SH AUTHORS AND LICENSE -Version 1.2.12 +Version 1.2.13 .LP Copyright (C) 1995-2022 Jean-loup Gailly and Mark Adler .LP diff --git a/compat/zlib/zlib.3.pdf b/compat/zlib/zlib.3.pdf index 54d677a..8132d84 100644 Binary files a/compat/zlib/zlib.3.pdf and b/compat/zlib/zlib.3.pdf differ diff --git a/compat/zlib/zlib.h b/compat/zlib/zlib.h index 4a98e38..953cb50 100644 --- a/compat/zlib/zlib.h +++ b/compat/zlib/zlib.h @@ -1,5 +1,5 @@ /* zlib.h -- interface of the 'zlib' general purpose compression library - version 1.2.12, March 11th, 2022 + version 1.2.13, October 13th, 2022 Copyright (C) 1995-2022 Jean-loup Gailly and Mark Adler @@ -37,11 +37,11 @@ extern "C" { #endif -#define ZLIB_VERSION "1.2.12" -#define ZLIB_VERNUM 0x12c0 +#define ZLIB_VERSION "1.2.13" +#define ZLIB_VERNUM 0x12d0 #define ZLIB_VER_MAJOR 1 #define ZLIB_VER_MINOR 2 -#define ZLIB_VER_REVISION 12 +#define ZLIB_VER_REVISION 13 #define ZLIB_VER_SUBREVISION 0 /* @@ -276,7 +276,7 @@ ZEXTERN int ZEXPORT deflate OF((z_streamp strm, int flush)); == 0), or after each call of deflate(). If deflate returns Z_OK and with zero avail_out, it must be called again after making room in the output buffer because there might be more output pending. See deflatePending(), - which can be used if desired to determine whether or not there is more ouput + which can be used if desired to determine whether or not there is more output in that case. Normally the parameter flush is set to Z_NO_FLUSH, which allows deflate to @@ -660,7 +660,7 @@ ZEXTERN int ZEXPORT deflateGetDictionary OF((z_streamp strm, to dictionary. dictionary must have enough space, where 32768 bytes is always enough. If deflateGetDictionary() is called with dictionary equal to Z_NULL, then only the dictionary length is returned, and nothing is copied. - Similary, if dictLength is Z_NULL, then it is not set. + Similarly, if dictLength is Z_NULL, then it is not set. deflateGetDictionary() may return a length less than the window size, even when more than the window size in input has been provided. It may return up @@ -915,7 +915,7 @@ ZEXTERN int ZEXPORT inflateGetDictionary OF((z_streamp strm, to dictionary. dictionary must have enough space, where 32768 bytes is always enough. If inflateGetDictionary() is called with dictionary equal to Z_NULL, then only the dictionary length is returned, and nothing is copied. - Similary, if dictLength is Z_NULL, then it is not set. + Similarly, if dictLength is Z_NULL, then it is not set. inflateGetDictionary returns Z_OK on success, or Z_STREAM_ERROR if the stream state is inconsistent. @@ -1437,12 +1437,12 @@ ZEXTERN z_size_t ZEXPORT gzfread OF((voidp buf, z_size_t size, z_size_t nitems, In the event that the end of file is reached and only a partial item is available at the end, i.e. the remaining uncompressed data length is not a - multiple of size, then the final partial item is nevetheless read into buf + multiple of size, then the final partial item is nevertheless read into buf and the end-of-file flag is set. The length of the partial item read is not provided, but could be inferred from the result of gztell(). This behavior is the same as the behavior of fread() implementations in common libraries, but it prevents the direct use of gzfread() to read a concurrently written - file, reseting and retrying on end-of-file, when size is not 1. + file, resetting and retrying on end-of-file, when size is not 1. */ ZEXTERN int ZEXPORT gzwrite OF((gzFile file, voidpc buf, unsigned len)); @@ -1913,7 +1913,7 @@ ZEXTERN int ZEXPORT inflateSyncPoint OF((z_streamp)); ZEXTERN const z_crc_t FAR * ZEXPORT get_crc_table OF((void)); ZEXTERN int ZEXPORT inflateUndermine OF((z_streamp, int)); ZEXTERN int ZEXPORT inflateValidate OF((z_streamp, int)); -ZEXTERN unsigned long ZEXPORT inflateCodesUsed OF ((z_streamp)); +ZEXTERN unsigned long ZEXPORT inflateCodesUsed OF((z_streamp)); ZEXTERN int ZEXPORT inflateResetKeep OF((z_streamp)); ZEXTERN int ZEXPORT deflateResetKeep OF((z_streamp)); #if defined(_WIN32) && !defined(Z_SOLO) diff --git a/compat/zlib/zlib2ansi b/compat/zlib/zlib2ansi index 15e3e16..23b2a1d 100755 --- a/compat/zlib/zlib2ansi +++ b/compat/zlib/zlib2ansi @@ -8,7 +8,7 @@ # TODO # -# Asumes no function pointer parameters. unless they are typedefed. +# Assumes no function pointer parameters. unless they are typedefed. # Assumes no literal strings that look like function definitions # Assumes functions start at the beginning of a line @@ -104,7 +104,7 @@ sub StripComments no warnings; - # Strip C & C++ coments + # Strip C & C++ comments # From the perlfaq $_[0] =~ diff --git a/compat/zlib/zutil.c b/compat/zlib/zutil.c index dcab28a..9543ae8 100644 --- a/compat/zlib/zutil.c +++ b/compat/zlib/zutil.c @@ -61,9 +61,11 @@ uLong ZEXPORT zlibCompileFlags() #ifdef ZLIB_DEBUG flags += 1 << 8; #endif + /* #if defined(ASMV) || defined(ASMINF) flags += 1 << 9; #endif + */ #ifdef ZLIB_WINAPI flags += 1 << 10; #endif @@ -119,7 +121,7 @@ uLong ZEXPORT zlibCompileFlags() # endif int ZLIB_INTERNAL z_verbose = verbose; -void ZLIB_INTERNAL z_error (m) +void ZLIB_INTERNAL z_error(m) char *m; { fprintf(stderr, "%s\n", m); @@ -214,7 +216,7 @@ local ptr_table table[MAX_PTR]; * a protected system like OS/2. Use Microsoft C instead. */ -voidpf ZLIB_INTERNAL zcalloc (voidpf opaque, unsigned items, unsigned size) +voidpf ZLIB_INTERNAL zcalloc(voidpf opaque, unsigned items, unsigned size) { voidpf buf; ulg bsize = (ulg)items*size; @@ -240,7 +242,7 @@ voidpf ZLIB_INTERNAL zcalloc (voidpf opaque, unsigned items, unsigned size) return buf; } -void ZLIB_INTERNAL zcfree (voidpf opaque, voidpf ptr) +void ZLIB_INTERNAL zcfree(voidpf opaque, voidpf ptr) { int n; @@ -277,13 +279,13 @@ void ZLIB_INTERNAL zcfree (voidpf opaque, voidpf ptr) # define _hfree hfree #endif -voidpf ZLIB_INTERNAL zcalloc (voidpf opaque, uInt items, uInt size) +voidpf ZLIB_INTERNAL zcalloc(voidpf opaque, uInt items, uInt size) { (void)opaque; return _halloc((long)items, size); } -void ZLIB_INTERNAL zcfree (voidpf opaque, voidpf ptr) +void ZLIB_INTERNAL zcfree(voidpf opaque, voidpf ptr) { (void)opaque; _hfree(ptr); @@ -302,7 +304,7 @@ extern voidp calloc OF((uInt items, uInt size)); extern void free OF((voidpf ptr)); #endif -voidpf ZLIB_INTERNAL zcalloc (opaque, items, size) +voidpf ZLIB_INTERNAL zcalloc(opaque, items, size) voidpf opaque; unsigned items; unsigned size; @@ -312,7 +314,7 @@ voidpf ZLIB_INTERNAL zcalloc (opaque, items, size) (voidpf)calloc(items, size); } -void ZLIB_INTERNAL zcfree (opaque, ptr) +void ZLIB_INTERNAL zcfree(opaque, ptr) voidpf opaque; voidpf ptr; { diff --git a/compat/zlib/zutil.h b/compat/zlib/zutil.h index d9a20ae..0bc7f4e 100644 --- a/compat/zlib/zutil.h +++ b/compat/zlib/zutil.h @@ -193,6 +193,7 @@ extern z_const char * const z_errmsg[10]; /* indexed by 2-zlib_error */ (!defined(_LARGEFILE64_SOURCE) || _LFS64_LARGEFILE-0 == 0) ZEXTERN uLong ZEXPORT adler32_combine64 OF((uLong, uLong, z_off_t)); ZEXTERN uLong ZEXPORT crc32_combine64 OF((uLong, uLong, z_off_t)); + ZEXTERN uLong ZEXPORT crc32_combine_gen64 OF((z_off_t)); #endif /* common defaults */ -- cgit v0.12 From f1c94fa67e7f4a99e9bbb00223c9beb83f69fab2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 19 Oct 2022 07:28:18 +0000 Subject: Make minizip/ioapi.c work (again) on win32. Build zlib1.dll for win64-arm --- compat/zlib/contrib/minizip/ioapi.c | 6 +++++- compat/zlib/win64-arm/zlib1.dll | Bin 95232 -> 95232 bytes 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/compat/zlib/contrib/minizip/ioapi.c b/compat/zlib/contrib/minizip/ioapi.c index 814a6fd..9370ae2 100644 --- a/compat/zlib/contrib/minizip/ioapi.c +++ b/compat/zlib/contrib/minizip/ioapi.c @@ -14,7 +14,11 @@ #define _CRT_SECURE_NO_WARNINGS #endif -#if defined(__APPLE__) || defined(IOAPI_NO_64) +#if defined(_WIN32) +#define FOPEN_FUNC(filename, mode) fopen(filename, mode) +#define FTELLO_FUNC(stream) _ftelli64(stream) +#define FSEEKO_FUNC(stream, offset, origin) _fseeki64(stream, offset, origin) +#elif defined(__APPLE__) || defined(IOAPI_NO_64) // In darwin and perhaps other BSD variants off_t is a 64 bit value, hence no need for specific 64 bit functions #define FOPEN_FUNC(filename, mode) fopen(filename, mode) #define FTELLO_FUNC(stream) ftello(stream) diff --git a/compat/zlib/win64-arm/zlib1.dll b/compat/zlib/win64-arm/zlib1.dll index 9025467..32d70b4 100755 Binary files a/compat/zlib/win64-arm/zlib1.dll and b/compat/zlib/win64-arm/zlib1.dll differ -- cgit v0.12 From dd1a24d32d14cc98d847387e1d79d925a12bc717 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 19 Oct 2022 08:30:20 +0000 Subject: Re-build zlib1 1.2.13 for win32/win64 --- compat/zlib/win32/zlib1.dll | Bin 122880 -> 123904 bytes compat/zlib/win64/zlib1.dll | Bin 134144 -> 134656 bytes 2 files changed, 0 insertions(+), 0 deletions(-) diff --git a/compat/zlib/win32/zlib1.dll b/compat/zlib/win32/zlib1.dll index e87de8c..8a24ded 100755 Binary files a/compat/zlib/win32/zlib1.dll and b/compat/zlib/win32/zlib1.dll differ diff --git a/compat/zlib/win64/zlib1.dll b/compat/zlib/win64/zlib1.dll index 9e38c08..35ed527 100755 Binary files a/compat/zlib/win64/zlib1.dll and b/compat/zlib/win64/zlib1.dll differ -- cgit v0.12 From a344103b2df59b2fbd11188bb6b16293aa44c8ca Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 19 Oct 2022 20:05:52 +0000 Subject: Re-build win64/zlib1.dll (with ucrt support) --- compat/zlib/win64/zlib1.dll | Bin 102400 -> 102400 bytes 1 file changed, 0 insertions(+), 0 deletions(-) diff --git a/compat/zlib/win64/zlib1.dll b/compat/zlib/win64/zlib1.dll index c822c70..3e88520 100755 Binary files a/compat/zlib/win64/zlib1.dll and b/compat/zlib/win64/zlib1.dll differ -- cgit v0.12 From 50abb43dbe760b723114adb2d75e9697c9c5ce8e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 20 Oct 2022 15:28:10 +0000 Subject: Fix [af65af3655]: clock.n: unbalanced parenthesis --- doc/clock.n | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/clock.n b/doc/clock.n index c46b797..3c408fc 100644 --- a/doc/clock.n +++ b/doc/clock.n @@ -188,9 +188,9 @@ Surprising results may be obtained when crossing a point at which a leap second is inserted or removed; the \fBclock add\fR command simply ignores leap seconds and therefore assumes that times come in sequence, -23:59:58, 23:59:59, 00:00:00. (This assumption is handled by +23:59:58, 23:59:59, 00:00:00. This assumption is handled by the fact that Tcl's model of time reacts to leap seconds by speeding -or slowing the clock by a minuscule amount until Tcl's time +or slowing the clock by a miniscule amount until Tcl's time is back in step with the world. .PP The fact that adding and subtracting hours is defined in terms of -- cgit v0.12 From 5a7f45638f425ed4e56942f1ca3df6705bfd5d4a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 20 Oct 2022 15:31:47 +0000 Subject: =?UTF-8?q?Fix=20[d554e5554e]:=20fix=20typo=20=E2=80=9Cdefintion?= =?UTF-8?q?=E2=80=9D?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- generic/tclAssembly.c | 2 +- generic/tclCompCmds.c | 62 ++++++++++++++--------------- generic/tclCompCmdsGR.c | 68 ++++++++++++++++---------------- generic/tclCompCmdsSZ.c | 102 ++++++++++++++++++++++++------------------------ generic/tclCompile.c | 2 +- generic/tclEnsemble.c | 28 ++++++------- generic/tclFileSystem.h | 2 +- 7 files changed, 133 insertions(+), 133 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 42c0c47..e69348c 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -949,7 +949,7 @@ TclCompileAssembleCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 0f52338..306334b 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -134,7 +134,7 @@ TclCompileAppendCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -260,7 +260,7 @@ TclCompileArrayExistsCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -292,7 +292,7 @@ TclCompileArraySetCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -465,7 +465,7 @@ TclCompileArrayUnsetCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -525,7 +525,7 @@ TclCompileBreakCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -583,7 +583,7 @@ TclCompileCatchCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -766,7 +766,7 @@ TclCompileClockClicksCmd( Tcl_Interp* interp, /* Tcl interpreter */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -830,7 +830,7 @@ TclCompileClockReadingCmd( Tcl_Interp* interp, /* Tcl interpreter */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -866,7 +866,7 @@ TclCompileConcatCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -953,7 +953,7 @@ TclCompileContinueCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1016,7 +1016,7 @@ TclCompileDictSetCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1069,7 +1069,7 @@ TclCompileDictIncrCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1141,7 +1141,7 @@ TclCompileDictGetCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1178,7 +1178,7 @@ TclCompileDictExistsCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1215,7 +1215,7 @@ TclCompileDictUnsetCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1268,7 +1268,7 @@ TclCompileDictCreateCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1361,7 +1361,7 @@ TclCompileDictMergeCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1475,7 +1475,7 @@ TclCompileDictForCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1488,7 +1488,7 @@ TclCompileDictMapCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1501,7 +1501,7 @@ CompileDictEachCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr, /* Holds resulting instructions. */ int collect) /* Flag == TCL_EACH_COLLECT to collect and @@ -1730,7 +1730,7 @@ TclCompileDictUpdateCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1881,7 +1881,7 @@ TclCompileDictAppendCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1936,7 +1936,7 @@ TclCompileDictLappendCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1981,7 +1981,7 @@ TclCompileDictWithCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -2332,7 +2332,7 @@ TclCompileErrorCmd( Tcl_Interp *interp, /* Used for context. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -2406,7 +2406,7 @@ TclCompileExprCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -2451,7 +2451,7 @@ TclCompileForCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -2600,7 +2600,7 @@ TclCompileForeachCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -2631,7 +2631,7 @@ TclCompileLmapCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -2662,7 +2662,7 @@ CompileEachloopCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr, /* Holds resulting instructions. */ int collect) /* Select collecting or accumulating mode @@ -3133,7 +3133,7 @@ TclCompileFormatCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index a324706..4328ace 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -88,7 +88,7 @@ TclCompileGlobalCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -167,7 +167,7 @@ TclCompileIfCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -470,7 +470,7 @@ TclCompileIncrCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -581,7 +581,7 @@ TclCompileInfoCommandsCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -642,7 +642,7 @@ TclCompileInfoCoroutineCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -667,7 +667,7 @@ TclCompileInfoExistsCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -716,7 +716,7 @@ TclCompileInfoLevelCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -751,7 +751,7 @@ TclCompileInfoObjectClassCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -771,7 +771,7 @@ TclCompileInfoObjectIsACmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -807,7 +807,7 @@ TclCompileInfoObjectNamespaceCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -845,7 +845,7 @@ TclCompileLappendCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -961,7 +961,7 @@ TclCompileLassignCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1065,7 +1065,7 @@ TclCompileLindexCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1156,7 +1156,7 @@ TclCompileListCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1270,7 +1270,7 @@ TclCompileLlengthCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1303,7 +1303,7 @@ TclCompileLrangeCmd( Tcl_Interp *interp, /* Tcl interpreter for context. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the * command. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { @@ -1364,7 +1364,7 @@ TclCompileLinsertCmd( Tcl_Interp *interp, /* Tcl interpreter for context. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the * command. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { @@ -1467,7 +1467,7 @@ TclCompileLreplaceCmd( Tcl_Interp *interp, /* Tcl interpreter for context. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the * command. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { @@ -1631,7 +1631,7 @@ TclCompileLsetCmd( Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the * command. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { @@ -1778,7 +1778,7 @@ TclCompileNamespaceCurrentCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1803,7 +1803,7 @@ TclCompileNamespaceCodeCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1853,7 +1853,7 @@ TclCompileNamespaceOriginCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1875,7 +1875,7 @@ TclCompileNamespaceQualifiersCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1911,7 +1911,7 @@ TclCompileNamespaceTailCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1948,7 +1948,7 @@ TclCompileNamespaceUpvarCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -2009,7 +2009,7 @@ TclCompileNamespaceWhichCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -2073,7 +2073,7 @@ TclCompileRegexpCmd( Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the * command. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { @@ -2238,7 +2238,7 @@ TclCompileRegsubCmd( Tcl_Interp *interp, /* Tcl interpreter for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the * command. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { @@ -2413,7 +2413,7 @@ TclCompileReturnCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -2665,7 +2665,7 @@ TclCompileUpvarCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -2772,7 +2772,7 @@ TclCompileVariableCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -2946,7 +2946,7 @@ TclCompileObjectNextCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -2971,7 +2971,7 @@ TclCompileObjectNextToCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -2996,7 +2996,7 @@ TclCompileObjectSelfCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index bfa1957..70d8909 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -131,7 +131,7 @@ TclCompileSetCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -225,7 +225,7 @@ TclCompileStringCatCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -297,7 +297,7 @@ TclCompileStringCmpCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -329,7 +329,7 @@ TclCompileStringEqualCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -361,7 +361,7 @@ TclCompileStringFirstCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -393,7 +393,7 @@ TclCompileStringLastCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -425,7 +425,7 @@ TclCompileStringIndexCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -453,7 +453,7 @@ TclCompileStringIsCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -732,7 +732,7 @@ TclCompileStringMatchCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -813,7 +813,7 @@ TclCompileStringLenCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -853,7 +853,7 @@ TclCompileStringMapCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -916,7 +916,7 @@ TclCompileStringRangeCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -992,7 +992,7 @@ TclCompileStringReplaceCmd( Tcl_Interp *interp, /* Tcl interpreter for context. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the * command. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { @@ -1194,7 +1194,7 @@ TclCompileStringTrimLCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1222,7 +1222,7 @@ TclCompileStringTrimRCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1250,7 +1250,7 @@ TclCompileStringTrimCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1278,7 +1278,7 @@ TclCompileStringToUpperCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1300,7 +1300,7 @@ TclCompileStringToLowerCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1322,7 +1322,7 @@ TclCompileStringToTitleCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1399,7 +1399,7 @@ TclCompileSubstCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -1732,7 +1732,7 @@ TclCompileSwitchCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -2610,7 +2610,7 @@ TclCompileTailcallCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -2657,7 +2657,7 @@ TclCompileThrowCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -2761,7 +2761,7 @@ TclCompileTryCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -3574,7 +3574,7 @@ TclCompileUnsetCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -3713,7 +3713,7 @@ TclCompileWhileCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -3891,7 +3891,7 @@ TclCompileYieldCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -3934,7 +3934,7 @@ TclCompileYieldToCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -4184,7 +4184,7 @@ int TclCompileInvertOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4195,7 +4195,7 @@ int TclCompileNotOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4206,7 +4206,7 @@ int TclCompileAddOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4218,7 +4218,7 @@ int TclCompileMulOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4230,7 +4230,7 @@ int TclCompileAndOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4242,7 +4242,7 @@ int TclCompileOrOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4254,7 +4254,7 @@ int TclCompileXorOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4266,7 +4266,7 @@ int TclCompilePowOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4297,7 +4297,7 @@ int TclCompileLshiftOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4308,7 +4308,7 @@ int TclCompileRshiftOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4319,7 +4319,7 @@ int TclCompileModOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4330,7 +4330,7 @@ int TclCompileNeqOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4341,7 +4341,7 @@ int TclCompileStrneqOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4352,7 +4352,7 @@ int TclCompileInOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4363,7 +4363,7 @@ int TclCompileNiOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4375,7 +4375,7 @@ int TclCompileLessOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4386,7 +4386,7 @@ int TclCompileLeqOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4397,7 +4397,7 @@ int TclCompileGreaterOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4408,7 +4408,7 @@ int TclCompileGeqOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4419,7 +4419,7 @@ int TclCompileEqOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4430,7 +4430,7 @@ int TclCompileStreqOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4441,7 +4441,7 @@ int TclCompileMinusOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { @@ -4487,7 +4487,7 @@ int TclCompileDivOpCmd( Tcl_Interp *interp, Tcl_Parse *parsePtr, - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) { diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 9a59b71..bffe7f8 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2700,7 +2700,7 @@ TclCompileNoOp( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 5e0a9e2..3b80a21 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -2906,7 +2906,7 @@ TclCompileEnsemble( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -3460,7 +3460,7 @@ CompileBasicNArgCommand( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -3480,7 +3480,7 @@ TclCompileBasic0ArgCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -3502,7 +3502,7 @@ TclCompileBasic1ArgCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -3524,7 +3524,7 @@ TclCompileBasic2ArgCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -3546,7 +3546,7 @@ TclCompileBasic3ArgCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -3568,7 +3568,7 @@ TclCompileBasic0Or1ArgCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -3590,7 +3590,7 @@ TclCompileBasic1Or2ArgCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -3612,7 +3612,7 @@ TclCompileBasic2Or3ArgCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -3634,7 +3634,7 @@ TclCompileBasic0To2ArgCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -3656,7 +3656,7 @@ TclCompileBasic1To3ArgCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -3678,7 +3678,7 @@ TclCompileBasicMin0ArgCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -3700,7 +3700,7 @@ TclCompileBasicMin1ArgCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { @@ -3722,7 +3722,7 @@ TclCompileBasicMin2ArgCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being + Command *cmdPtr, /* Points to definition of command being * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { diff --git a/generic/tclFileSystem.h b/generic/tclFileSystem.h index 1eec7ff..e5dcffb 100644 --- a/generic/tclFileSystem.h +++ b/generic/tclFileSystem.h @@ -1,7 +1,7 @@ /* * tclFileSystem.h -- * - * This file contains the common defintions and prototypes for use by + * This file contains the common definitions and prototypes for use by * Tcl's filesystem and path handling layers. * * Copyright (c) 2003 Vince Darley. -- cgit v0.12 From c8a85bbc05960b91123999e18cdf1c872896dec7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 21 Oct 2022 09:01:36 +0000 Subject: Change version field to Tcl_ObjTypeVersion --- generic/tcl.h | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 4def1b3..3f54c6d 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -360,6 +360,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_Channel_ *Tcl_Channel; typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion; +typedef struct Tcl_ObjTypeVersion_ *Tcl_ObjTypeVersion; typedef struct Tcl_Command_ *Tcl_Command; typedef struct Tcl_Condition_ *Tcl_Condition; typedef struct Tcl_Dict_ *Tcl_Dict; @@ -616,11 +617,11 @@ typedef struct Tcl_ObjType { /* Called to convert the object's internal rep * to this type. Frees the internal rep of the * old type. Returns TCL_ERROR on failure. */ - unsigned char version; + Tcl_ObjTypeVersion version; } Tcl_ObjType; -#define TCL_OBJTYPE_V0 0 /* Pre-Tcl 9. Set to 0 so compiler will auto-init - * when existing code that does not init this field - * is compiled with Tcl9 headers */ +#define TCL_OBJTYPE_V0 ((Tcl_ObjTypeVersion)0) /* Pre-Tcl 9. Set to 0 so + * compiler will auto-init when existing code that does + * not init this field is compiled with Tcl9 headers */ #define TCL_OBJTYPE_CURRENT TCL_OBJTYPE_V0 /* -- cgit v0.12 From c08af43916648199e4e782f3d1d4fa937619eb3c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 21 Oct 2022 14:58:54 +0000 Subject: Don't bother _MSC_VER < 1900 any more --- win/tclWinTime.c | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/win/tclWinTime.c b/win/tclWinTime.c index a7e8474..e8401a5 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -791,14 +791,14 @@ TclpGetDate( { struct tm *tmPtr; time_t time; -#if defined(_WIN64) || (defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400)) +#if defined(_WIN64) || defined(_USE_64BIT_TIME_T) # define t2 *t /* no need to cripple time to 32-bit */ #else time_t t2 = *(__time32_t *) t; #endif if (!useGMT) { -#if defined(_MSC_VER) && (_MSC_VER >= 1900) +#if defined(_MSC_VER) # undef timezone /* prevent conflict with timezone() function */ long timezone = 0; #endif @@ -815,7 +815,7 @@ TclpGetDate( return TclpLocaltime(&t2); } -#if defined(_MSC_VER) && (_MSC_VER >= 1900) +#if defined(_MSC_VER) _get_timezone(&timezone); #endif @@ -1451,11 +1451,11 @@ TclpGmtime( * Posix gmtime_r function. */ -#if defined(_WIN64) || defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400) +#if defined(_WIN64) || defined(_USE_64BIT_TIME_T) return gmtime(timePtr); #else return _gmtime32((const __time32_t *) timePtr); -#endif /* _WIN64 || _USE_64BIT_TIME_T || _MSC_VER < 1400 */ +#endif /* _WIN64 || _USE_64BIT_TIME_T */ } /* @@ -1486,11 +1486,11 @@ TclpLocaltime( * provide a Posix localtime_r function. */ -#if defined(_WIN64) || defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400) +#if defined(_WIN64) || defined(_USE_64BIT_TIME_T) return localtime(timePtr); #else return _localtime32((const __time32_t *) timePtr); -#endif /* _WIN64 || _USE_64BIT_TIME_T || _MSC_VER < 1400 */ +#endif /* _WIN64 || _USE_64BIT_TIME_T */ } #endif /* TCL_NO_DEPRECATED */ -- cgit v0.12 From 500e1529f18c04152dbf1a395c6c7a61f08f63b3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 21 Oct 2022 15:00:03 +0000 Subject: typedef Tcl_Size as int (which is the Tcl 8.7 part of TIP #628) --- generic/tcl.decls | 226 +++++++++++----------- generic/tcl.h | 193 ++++++++++--------- generic/tclArithSeries.c | 2 +- generic/tclCompile.h | 186 +++++++++---------- generic/tclDecls.h | 473 ++++++++++++++++++++++++----------------------- generic/tclIO.h | 16 +- generic/tclInt.h | 246 ++++++++++++------------ generic/tclListObj.c | 174 ++++++++--------- generic/tclPlatDecls.h | 4 +- generic/tclTest.c | 4 +- 10 files changed, 766 insertions(+), 758 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 268fe33..209fb9a 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -86,10 +86,10 @@ declare 15 { void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...) } declare 16 { - void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, int length) + void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, Tcl_Size length) } declare 17 { - Tcl_Obj *Tcl_ConcatObj(int objc, Tcl_Obj *const objv[]) + Tcl_Obj *Tcl_ConcatObj(Tcl_Size objc, Tcl_Obj *const objv[]) } declare 18 { int Tcl_ConvertToType(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -109,14 +109,14 @@ declare 22 {deprecated {No longer in use, changed to macro}} { } declare 23 { Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, - int numBytes, const char *file, int line) + Tcl_Size numBytes, const char *file, int line) } declare 24 { Tcl_Obj *Tcl_DbNewDoubleObj(double doubleValue, const char *file, int line) } declare 25 { - Tcl_Obj *Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv, + Tcl_Obj *Tcl_DbNewListObj(Tcl_Size objc, Tcl_Obj *const *objv, const char *file, int line) } declare 26 {deprecated {No longer in use, changed to macro}} { @@ -126,7 +126,7 @@ declare 27 { Tcl_Obj *Tcl_DbNewObj(const char *file, int line) } declare 28 { - Tcl_Obj *Tcl_DbNewStringObj(const char *bytes, int length, + Tcl_Obj *Tcl_DbNewStringObj(const char *bytes, Tcl_Size length, const char *file, int line) } declare 29 { @@ -188,7 +188,7 @@ declare 45 { int *objcPtr, Tcl_Obj ***objvPtr) } declare 46 { - int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, + int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj **objPtrPtr) } declare 47 { @@ -196,14 +196,14 @@ declare 47 { int *lengthPtr) } declare 48 { - int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, - int count, int objc, Tcl_Obj *const objv[]) + int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size first, + Tcl_Size count, Tcl_Size objc, Tcl_Obj *const objv[]) } declare 49 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_NewBooleanObj(int intValue) } declare 50 { - Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, int numBytes) + Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, Tcl_Size numBytes) } declare 51 { Tcl_Obj *Tcl_NewDoubleObj(double doubleValue) @@ -212,7 +212,7 @@ declare 52 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_NewIntObj(int intValue) } declare 53 { - Tcl_Obj *Tcl_NewListObj(int objc, Tcl_Obj *const objv[]) + Tcl_Obj *Tcl_NewListObj(Tcl_Size objc, Tcl_Obj *const objv[]) } declare 54 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_NewLongObj(long longValue) @@ -221,17 +221,17 @@ declare 55 { Tcl_Obj *Tcl_NewObj(void) } declare 56 { - Tcl_Obj *Tcl_NewStringObj(const char *bytes, int length) + Tcl_Obj *Tcl_NewStringObj(const char *bytes, Tcl_Size length) } declare 57 {deprecated {No longer in use, changed to macro}} { void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int intValue) } declare 58 { - unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int numBytes) + unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, Tcl_Size numBytes) } declare 59 { void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes, - int numBytes) + Tcl_Size numBytes) } declare 60 { void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue) @@ -240,16 +240,16 @@ declare 61 {deprecated {No longer in use, changed to macro}} { void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue) } declare 62 { - void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]) + void Tcl_SetListObj(Tcl_Obj *objPtr, Tcl_Size objc, Tcl_Obj *const objv[]) } declare 63 {deprecated {No longer in use, changed to macro}} { void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue) } declare 64 { - void Tcl_SetObjLength(Tcl_Obj *objPtr, int length) + void Tcl_SetObjLength(Tcl_Obj *objPtr, Tcl_Size length) } declare 65 { - void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length) + void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, Tcl_Size length) } declare 66 {deprecated {No longer in use, changed to macro}} { void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message) @@ -308,23 +308,23 @@ declare 82 { int Tcl_CommandComplete(const char *cmd) } declare 83 { - char *Tcl_Concat(int argc, const char *const *argv) + char *Tcl_Concat(Tcl_Size argc, const char *const *argv) } declare 84 { - int Tcl_ConvertElement(const char *src, char *dst, int flags) + Tcl_Size Tcl_ConvertElement(const char *src, char *dst, int flags) } declare 85 { - int Tcl_ConvertCountedElement(const char *src, int length, char *dst, + Tcl_Size Tcl_ConvertCountedElement(const char *src, Tcl_Size length, char *dst, int flags) } declare 86 { int Tcl_CreateAlias(Tcl_Interp *childInterp, const char *childCmd, - Tcl_Interp *target, const char *targetCmd, int argc, + Tcl_Interp *target, const char *targetCmd, Tcl_Size argc, const char *const *argv) } declare 87 { int Tcl_CreateAliasObj(Tcl_Interp *childInterp, const char *childCmd, - Tcl_Interp *target, const char *targetCmd, int objc, + Tcl_Interp *target, const char *targetCmd, Tcl_Size objc, Tcl_Obj *const objv[]) } declare 88 { @@ -414,7 +414,7 @@ declare 110 { void Tcl_DeleteInterp(Tcl_Interp *interp) } declare 111 { - void Tcl_DetachPids(int numPids, Tcl_Pid *pidPtr) + void Tcl_DetachPids(Tcl_Size numPids, Tcl_Pid *pidPtr) } declare 112 { void Tcl_DeleteTimerHandler(Tcl_TimerToken token) @@ -433,7 +433,7 @@ declare 116 { void Tcl_DoWhenIdle(Tcl_IdleProc *proc, void *clientData) } declare 117 { - char *Tcl_DStringAppend(Tcl_DString *dsPtr, const char *bytes, int length) + char *Tcl_DStringAppend(Tcl_DString *dsPtr, const char *bytes, Tcl_Size length) } declare 118 { char *Tcl_DStringAppendElement(Tcl_DString *dsPtr, const char *element) @@ -454,7 +454,7 @@ declare 123 { void Tcl_DStringResult(Tcl_Interp *interp, Tcl_DString *dsPtr) } declare 124 { - void Tcl_DStringSetLength(Tcl_DString *dsPtr, int length) + void Tcl_DStringSetLength(Tcl_DString *dsPtr, Tcl_Size length) } declare 125 { void Tcl_DStringStartSublist(Tcl_DString *dsPtr) @@ -547,7 +547,7 @@ declare 151 { int *modePtr) } declare 152 { - int Tcl_GetChannelBufferSize(Tcl_Channel chan) + Tcl_Size Tcl_GetChannelBufferSize(Tcl_Channel chan) } declare 153 { int Tcl_GetChannelHandle(Tcl_Channel chan, int direction, @@ -609,10 +609,10 @@ declare 168 { Tcl_PathType Tcl_GetPathType(const char *path) } declare 169 { - int Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr) + Tcl_Size Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr) } declare 170 { - int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr) + Tcl_Size Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr) } declare 171 { int Tcl_GetServiceMode(void) @@ -664,7 +664,7 @@ declare 185 { } # Obsolete, use Tcl_FSJoinPath declare 186 { - char *Tcl_JoinPath(int argc, const char *const *argv, + char *Tcl_JoinPath(Tcl_Size argc, const char *const *argv, Tcl_DString *resultPtr) } declare 187 { @@ -687,7 +687,7 @@ declare 191 { Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket) } declare 192 { - char *Tcl_Merge(int argc, const char *const *argv) + char *Tcl_Merge(Tcl_Size argc, const char *const *argv) } declare 193 { Tcl_HashEntry *Tcl_NextHashEntry(Tcl_HashSearch *searchPtr) @@ -704,7 +704,7 @@ declare 196 { Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags) } declare 197 { - Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc, + Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, Tcl_Size argc, const char **argv, int flags) } # This is obsolete, use Tcl_FSOpenFileChannel @@ -737,7 +737,7 @@ declare 205 { void Tcl_QueueEvent(Tcl_Event *evPtr, int position) } declare 206 { - int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead) + Tcl_Size Tcl_Read(Tcl_Channel chan, char *bufPtr, Tcl_Size toRead) } declare 207 { void Tcl_ReapDetachedProcs(void) @@ -766,7 +766,7 @@ declare 214 { const char *pattern) } declare 215 { - void Tcl_RegExpRange(Tcl_RegExp regexp, int index, + void Tcl_RegExpRange(Tcl_RegExp regexp, Tcl_Size index, const char **startPtr, const char **endPtr) } declare 216 { @@ -776,10 +776,10 @@ declare 217 { void Tcl_ResetResult(Tcl_Interp *interp) } declare 218 { - int Tcl_ScanElement(const char *src, int *flagPtr) + Tcl_Size Tcl_ScanElement(const char *src, int *flagPtr) } declare 219 { - int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr) + Tcl_Size Tcl_ScanCountedElement(const char *src, Tcl_Size length, int *flagPtr) } declare 220 {deprecated {}} { int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode) @@ -795,7 +795,7 @@ declare 223 { Tcl_InterpDeleteProc *proc, void *clientData) } declare 224 { - void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz) + void Tcl_SetChannelBufferSize(Tcl_Channel chan, Tcl_Size sz) } declare 225 { int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, @@ -818,7 +818,7 @@ declare 230 {nostub {Don't use this function in a stub-enabled extension}} { const char *Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc) } declare 231 { - int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth) + Tcl_Size Tcl_SetRecursionLimit(Tcl_Interp *interp, Tcl_Size depth) } declare 232 { void Tcl_SetResult(Tcl_Interp *interp, char *result, @@ -884,7 +884,7 @@ declare 249 { Tcl_DString *bufferPtr) } declare 250 { - int Tcl_Ungets(Tcl_Channel chan, const char *str, int len, int atHead) + Tcl_Size Tcl_Ungets(Tcl_Channel chan, const char *str, Tcl_Size len, int atHead) } declare 251 { void Tcl_UnlinkVar(Tcl_Interp *interp, const char *varName) @@ -932,10 +932,10 @@ declare 262 { void *prevClientData) } declare 263 { - int Tcl_Write(Tcl_Channel chan, const char *s, int slen) + Tcl_Size Tcl_Write(Tcl_Channel chan, const char *s, Tcl_Size slen) } declare 264 { - void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc, + void Tcl_WrongNumArgs(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], const char *message) } declare 265 { @@ -1047,11 +1047,11 @@ declare 290 {deprecated {Use Tcl_DiscardInterpState}} { void Tcl_DiscardResult(Tcl_SavedResult *statePtr) } declare 291 { - int Tcl_EvalEx(Tcl_Interp *interp, const char *script, int numBytes, + int Tcl_EvalEx(Tcl_Interp *interp, const char *script, Tcl_Size numBytes, int flags) } declare 292 { - int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], + int Tcl_EvalObjv(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags) } declare 293 { @@ -1062,13 +1062,13 @@ declare 294 { } declare 295 { int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding, - const char *src, int srcLen, int flags, - Tcl_EncodingState *statePtr, char *dst, int dstLen, + const char *src, Tcl_Size srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr) } declare 296 { char *Tcl_ExternalToUtfDString(Tcl_Encoding encoding, - const char *src, int srcLen, Tcl_DString *dsPtr) + const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr) } declare 297 { void Tcl_FinalizeThread(void) @@ -1093,11 +1093,11 @@ declare 303 { } declare 304 { int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr, - const void *tablePtr, int offset, const char *msg, int flags, + const void *tablePtr, Tcl_Size offset, const char *msg, int flags, void *indexPtr) } declare 305 { - void *Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, int size) + void *Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, Tcl_Size size) } declare 306 { Tcl_Obj *Tcl_GetVar2Ex(Tcl_Interp *interp, const char *part1, @@ -1120,11 +1120,11 @@ declare 311 { const Tcl_Time *timePtr) } declare 312 { - int Tcl_NumUtfChars(const char *src, int length) + Tcl_Size Tcl_NumUtfChars(const char *src, Tcl_Size length) } declare 313 { - int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, - int charsToRead, int appendFlag) + Tcl_Size Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, + Tcl_Size charsToRead, int appendFlag) } declare 314 {deprecated {Use Tcl_RestoreInterpState}} { void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) @@ -1147,7 +1147,7 @@ declare 319 { int position) } declare 320 { - int Tcl_UniCharAtIndex(const char *src, int index) + int Tcl_UniCharAtIndex(const char *src, Tcl_Size index) } declare 321 { int Tcl_UniCharToLower(int ch) @@ -1162,13 +1162,13 @@ declare 324 { int Tcl_UniCharToUtf(int ch, char *buf) } declare 325 { - const char *Tcl_UtfAtIndex(const char *src, int index) + const char *Tcl_UtfAtIndex(const char *src, Tcl_Size index) } declare 326 { - int TclUtfCharComplete(const char *src, int length) + int TclUtfCharComplete(const char *src, Tcl_Size length) } declare 327 { - int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst) + Tcl_Size Tcl_UtfBackslash(const char *src, int *readPtr, char *dst) } declare 328 { const char *Tcl_UtfFindFirst(const char *src, int ch) @@ -1184,13 +1184,13 @@ declare 331 { } declare 332 { int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, - const char *src, int srcLen, int flags, - Tcl_EncodingState *statePtr, char *dst, int dstLen, + const char *src, Tcl_Size srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr) } declare 333 { char *Tcl_UtfToExternalDString(Tcl_Encoding encoding, - const char *src, int srcLen, Tcl_DString *dsPtr) + const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr) } declare 334 { int Tcl_UtfToLower(char *src) @@ -1205,10 +1205,10 @@ declare 337 { int Tcl_UtfToUpper(char *src) } declare 338 { - int Tcl_WriteChars(Tcl_Channel chan, const char *src, int srcLen) + Tcl_Size Tcl_WriteChars(Tcl_Channel chan, const char *src, Tcl_Size srcLen) } declare 339 { - int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr) + Tcl_Size Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr) } declare 340 { char *Tcl_GetString(Tcl_Obj *objPtr) @@ -1247,7 +1247,7 @@ declare 351 { int Tcl_UniCharIsWordChar(int ch) } declare 352 { - int Tcl_Char16Len(const unsigned short *uniStr) + Tcl_Size Tcl_Char16Len(const unsigned short *uniStr) } declare 353 {deprecated {Use Tcl_UtfNcmp}} { int Tcl_UniCharNcmp(const unsigned short *ucs, const unsigned short *uct, @@ -1255,11 +1255,11 @@ declare 353 {deprecated {Use Tcl_UtfNcmp}} { } declare 354 { char *Tcl_Char16ToUtfDString(const unsigned short *uniStr, - int uniLength, Tcl_DString *dsPtr) + Tcl_Size uniLength, Tcl_DString *dsPtr) } declare 355 { unsigned short *Tcl_UtfToChar16DString(const char *src, - int length, Tcl_DString *dsPtr) + Tcl_Size length, Tcl_DString *dsPtr) } declare 356 { Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, @@ -1274,29 +1274,29 @@ declare 358 { } declare 359 { void Tcl_LogCommandInfo(Tcl_Interp *interp, const char *script, - const char *command, int length) + const char *command, Tcl_Size length) } declare 360 { int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, - int numBytes, Tcl_Parse *parsePtr, int append, + Tcl_Size numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr) } declare 361 { int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, - int numBytes, int nested, Tcl_Parse *parsePtr) + Tcl_Size numBytes, int nested, Tcl_Parse *parsePtr) } declare 362 { int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, - int numBytes, Tcl_Parse *parsePtr) + Tcl_Size numBytes, Tcl_Parse *parsePtr) } declare 363 { int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start, - int numBytes, Tcl_Parse *parsePtr, int append, + Tcl_Size numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr) } declare 364 { int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, - int numBytes, Tcl_Parse *parsePtr, int append) + Tcl_Size numBytes, Tcl_Parse *parsePtr, int append) } # These 4 functions are obsolete, use Tcl_FSGetCwd, Tcl_FSChdir, # Tcl_FSAccess and Tcl_FSStat @@ -1335,33 +1335,33 @@ declare 375 { } declare 376 { int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp, - Tcl_Obj *textObj, int offset, int nmatches, int flags) + Tcl_Obj *textObj, Tcl_Size offset, Tcl_Size nmatches, int flags) } declare 377 { void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr) } declare 378 { - Tcl_Obj *Tcl_NewUnicodeObj(const unsigned short *unicode, int numChars) + Tcl_Obj *Tcl_NewUnicodeObj(const unsigned short *unicode, Tcl_Size numChars) } declare 379 { void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const unsigned short *unicode, - int numChars) + Tcl_Size numChars) } declare 380 { - int Tcl_GetCharLength(Tcl_Obj *objPtr) + Tcl_Size Tcl_GetCharLength(Tcl_Obj *objPtr) } declare 381 { - int Tcl_GetUniChar(Tcl_Obj *objPtr, int index) + int Tcl_GetUniChar(Tcl_Obj *objPtr, Tcl_Size index) } declare 382 {deprecated {No longer in use, changed to macro}} { unsigned short *Tcl_GetUnicode(Tcl_Obj *objPtr) } declare 383 { - Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, int first, int last) + Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last) } declare 384 { void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const unsigned short *unicode, - int length) + Tcl_Size length) } declare 385 { int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, @@ -1381,7 +1381,7 @@ declare 389 { } declare 390 { int Tcl_ProcObjCmd(void *clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) + Tcl_Size objc, Tcl_Obj *const objv[]) } declare 391 { void Tcl_ConditionFinalize(Tcl_Condition *condPtr) @@ -1391,15 +1391,15 @@ declare 392 { } declare 393 { int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, - void *clientData, int stackSize, int flags) + void *clientData, Tcl_Size stackSize, int flags) } # Introduced in 8.3.2 declare 394 { - int Tcl_ReadRaw(Tcl_Channel chan, char *dst, int bytesToRead) + Tcl_Size Tcl_ReadRaw(Tcl_Channel chan, char *dst, Tcl_Size bytesToRead) } declare 395 { - int Tcl_WriteRaw(Tcl_Channel chan, const char *src, int srcLen) + Tcl_Size Tcl_WriteRaw(Tcl_Channel chan, const char *src, Tcl_Size srcLen) } declare 396 { Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan) @@ -1534,7 +1534,7 @@ declare 431 { const char *file, int line) } declare 432 { - int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length) + int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, Tcl_Size length) } # TIP#10 (thread-aware channels) akupries @@ -1640,7 +1640,7 @@ declare 459 { int Tcl_FSConvertToPathType(Tcl_Interp *interp, Tcl_Obj *pathPtr) } declare 460 { - Tcl_Obj *Tcl_FSJoinPath(Tcl_Obj *listObj, int elements) + Tcl_Obj *Tcl_FSJoinPath(Tcl_Obj *listObj, Tcl_Size elements) } declare 461 { Tcl_Obj *Tcl_FSSplitPath(Tcl_Obj *pathPtr, int *lenPtr) @@ -1652,7 +1652,7 @@ declare 463 { Tcl_Obj *Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr) } declare 464 { - Tcl_Obj *Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc, + Tcl_Obj *Tcl_FSJoinToPath(Tcl_Obj *pathPtr, Tcl_Size objc, Tcl_Obj *const objv[]) } declare 465 { @@ -1712,7 +1712,7 @@ declare 480 { # TIP#56 (evaluate a parsed script) msofer declare 481 { int Tcl_EvalTokensStandard(Tcl_Interp *interp, Tcl_Token *tokenPtr, - int count) + Tcl_Size count) } # TIP#73 (access to current time) kbk @@ -1798,11 +1798,11 @@ declare 500 { } declare 501 { int Tcl_DictObjPutKeyList(Tcl_Interp *interp, Tcl_Obj *dictPtr, - int keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr) + Tcl_Size keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr) } declare 502 { int Tcl_DictObjRemoveKeyList(Tcl_Interp *interp, Tcl_Obj *dictPtr, - int keyc, Tcl_Obj *const *keyv) + Tcl_Size keyc, Tcl_Obj *const *keyv) } declare 503 { Tcl_Obj *Tcl_NewDictObj(void) @@ -1895,7 +1895,7 @@ declare 524 { int Tcl_LimitExceeded(Tcl_Interp *interp) } declare 525 { - void Tcl_LimitSetCommands(Tcl_Interp *interp, int commandLimit) + void Tcl_LimitSetCommands(Tcl_Interp *interp, Tcl_Size commandLimit) } declare 526 { void Tcl_LimitSetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr) @@ -2084,7 +2084,7 @@ declare 572 { # TIP#268 (extended version numbers and requirements) akupries declare 573 { int Tcl_PkgRequireProc(Tcl_Interp *interp, const char *name, - int objc, Tcl_Obj *const objv[], void *clientDataPtr) + Tcl_Size objc, Tcl_Obj *const objv[], void *clientDataPtr) } # TIP#270 (utility C routines for string formatting) dgp @@ -2093,15 +2093,15 @@ declare 574 { } declare 575 { void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, const char *bytes, - int length, int limit, const char *ellipsis) + Tcl_Size length, Tcl_Size limit, const char *ellipsis) } declare 576 { - Tcl_Obj *Tcl_Format(Tcl_Interp *interp, const char *format, int objc, + Tcl_Obj *Tcl_Format(Tcl_Interp *interp, const char *format, Tcl_Size objc, Tcl_Obj *const objv[]) } declare 577 { int Tcl_AppendFormatToObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - const char *format, int objc, Tcl_Obj *const objv[]) + const char *format, Tcl_Size objc, Tcl_Obj *const objv[]) } declare 578 { Tcl_Obj *Tcl_ObjPrintf(const char *format, ...) @@ -2138,11 +2138,11 @@ declare 584 { int Tcl_NREvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) } declare 585 { - int Tcl_NREvalObjv(Tcl_Interp *interp, int objc, + int Tcl_NREvalObjv(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags) } declare 586 { - int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, int objc, + int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, Tcl_Size objc, Tcl_Obj *const objv[], int flags) } declare 587 { @@ -2154,7 +2154,7 @@ declare 587 { # classic objProc declare 588 { int Tcl_NRCallObjProc(Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, - void *clientData, int objc, Tcl_Obj *const objv[]) + void *clientData, Tcl_Size objc, Tcl_Obj *const objv[]) } # TIP#316 (Tcl_StatBuf reader functions) dkf @@ -2245,15 +2245,15 @@ declare 610 { } declare 611 { int Tcl_ZlibInflate(Tcl_Interp *interp, int format, Tcl_Obj *data, - int buffersize, Tcl_Obj *gzipHeaderDictObj) + Tcl_Size buffersize, Tcl_Obj *gzipHeaderDictObj) } declare 612 { unsigned int Tcl_ZlibCRC32(unsigned int crc, const unsigned char *buf, - int len) + Tcl_Size len) } declare 613 { unsigned int Tcl_ZlibAdler32(unsigned int adler, const unsigned char *buf, - int len) + Tcl_Size len) } declare 614 { int Tcl_ZlibStreamInit(Tcl_Interp *interp, int mode, int format, @@ -2273,7 +2273,7 @@ declare 618 { } declare 619 { int Tcl_ZlibStreamGet(Tcl_ZlibStream zshandle, Tcl_Obj *data, - int count) + Tcl_Size count) } declare 620 { int Tcl_ZlibStreamClose(Tcl_ZlibStream zshandle) @@ -2385,12 +2385,12 @@ declare 643 { # TIP#312 New Tcl_LinkArray() function declare 644 { int Tcl_LinkArray(Tcl_Interp *interp, const char *varName, void *addr, - int type, int size) + int type, Tcl_Size size) } declare 645 { int Tcl_GetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, - int endValue, int *indexPtr) + Tcl_Size endValue, Tcl_Size *indexPtr) } # TIP #548 @@ -2399,11 +2399,11 @@ declare 646 { } declare 647 { char *Tcl_UniCharToUtfDString(const int *uniStr, - int uniLength, Tcl_DString *dsPtr) + Tcl_Size uniLength, Tcl_DString *dsPtr) } declare 648 { int *Tcl_UtfToUniCharDString(const char *src, - int length, Tcl_DString *dsPtr) + Tcl_Size length, Tcl_DString *dsPtr) } # TIP #568 @@ -2430,7 +2430,7 @@ declare 653 { # TIP #575 declare 654 { - int Tcl_UtfCharComplete(const char *src, int length) + int Tcl_UtfCharComplete(const char *src, Tcl_Size length) } declare 655 { const char *Tcl_UtfNext(const char *src) @@ -2442,12 +2442,12 @@ declare 657 { int Tcl_UniCharIsUnicode(int ch) } declare 658 { - int Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, - const char *src, int srcLen, int flags, Tcl_DString *dsPtr) + Tcl_Size Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, + const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr) } declare 659 { - int Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, - const char *src, int srcLen, int flags, Tcl_DString *dsPtr) + Tcl_Size Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, + const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr) } # TIP #511 @@ -2484,22 +2484,22 @@ declare 667 { # TIP #617 declare 668 { - int Tcl_UniCharLen(const int *uniStr) + Tcl_Size Tcl_UniCharLen(const int *uniStr) } declare 669 { - int TclNumUtfChars(const char *src, int length) + Tcl_Size TclNumUtfChars(const char *src, Tcl_Size length) } declare 670 { - int TclGetCharLength(Tcl_Obj *objPtr) + Tcl_Size TclGetCharLength(Tcl_Obj *objPtr) } declare 671 { - const char *TclUtfAtIndex(const char *src, int index) + const char *TclUtfAtIndex(const char *src, Tcl_Size index) } declare 672 { - Tcl_Obj *TclGetRange(Tcl_Obj *objPtr, int first, int last) + Tcl_Obj *TclGetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last) } declare 673 { - int TclGetUniChar(Tcl_Obj *objPtr, int index) + int TclGetUniChar(Tcl_Obj *objPtr, Tcl_Size index) } declare 674 { @@ -2586,7 +2586,7 @@ declare 0 macosx { declare 1 macosx { int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, - int hasResourceFile, int maxPathLen, char *libraryPath) + int hasResourceFile, Tcl_Size maxPathLen, char *libraryPath) } declare 2 macosx { void Tcl_MacOSXNotifierAddRunLoopMode(const void *runLoopMode) @@ -2600,7 +2600,7 @@ export { void Tcl_Main(int argc, char **argv, Tcl_AppInitProc *appInitProc) } export { - void Tcl_MainEx(int argc, char **argv, Tcl_AppInitProc *appInitProc, + void Tcl_MainEx(Tcl_Size argc, char **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp) } export { diff --git a/generic/tcl.h b/generic/tcl.h index 849278b..3560481 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -48,10 +48,10 @@ extern "C" { */ #if !defined(TCL_MAJOR_VERSION) -#define TCL_MAJOR_VERSION 8 +# define TCL_MAJOR_VERSION 8 #endif #if TCL_MAJOR_VERSION != 8 -#error "This header-file is for Tcl 8 only" +# error "This header-file is for Tcl 8 only" #endif #define TCL_MINOR_VERSION 7 #define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE @@ -156,13 +156,8 @@ extern "C" { # endif #else # define TCL_FORMAT_PRINTF(a,b) -# if defined(_MSC_VER) && (_MSC_VER >= 1310) -# define TCL_NORETURN _declspec(noreturn) -# define TCL_NOINLINE __declspec(noinline) -# else -# define TCL_NORETURN /* nothing */ -# define TCL_NOINLINE /* nothing */ -# endif +# define TCL_NORETURN _declspec(noreturn) +# define TCL_NOINLINE __declspec(noinline) # define TCL_NORETURN1 /* nothing */ #endif @@ -410,11 +405,11 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; #ifdef _WIN32 # if defined(_WIN64) || defined(_USE_64BIT_TIME_T) typedef struct __stat64 Tcl_StatBuf; -# elif (defined(_MSC_VER) && (_MSC_VER < 1400)) || defined(_USE_32BIT_TIME_T) +# elif defined(_USE_32BIT_TIME_T) typedef struct _stati64 Tcl_StatBuf; # else typedef struct _stat32i64 Tcl_StatBuf; -# endif /* _MSC_VER < 1400 */ +# endif #elif defined(__CYGWIN__) typedef struct { dev_t st_dev; @@ -499,9 +494,9 @@ typedef struct Tcl_ZLibStream_ *Tcl_ZlibStream; */ #if defined _WIN32 -typedef unsigned (__stdcall Tcl_ThreadCreateProc) (ClientData clientData); +typedef unsigned (__stdcall Tcl_ThreadCreateProc) (void *clientData); #else -typedef void (Tcl_ThreadCreateProc) (ClientData clientData); +typedef void (Tcl_ThreadCreateProc) (void *clientData); #endif /* @@ -665,67 +660,67 @@ struct Tcl_Obj; */ typedef int (Tcl_AppInitProc) (Tcl_Interp *interp); -typedef int (Tcl_AsyncProc) (ClientData clientData, Tcl_Interp *interp, +typedef int (Tcl_AsyncProc) (void *clientData, Tcl_Interp *interp, int code); -typedef void (Tcl_ChannelProc) (ClientData clientData, int mask); -typedef void (Tcl_CloseProc) (ClientData data); -typedef void (Tcl_CmdDeleteProc) (ClientData clientData); -typedef int (Tcl_CmdProc) (ClientData clientData, Tcl_Interp *interp, +typedef void (Tcl_ChannelProc) (void *clientData, int mask); +typedef void (Tcl_CloseProc) (void *data); +typedef void (Tcl_CmdDeleteProc) (void *clientData); +typedef int (Tcl_CmdProc) (void *clientData, Tcl_Interp *interp, int argc, const char *argv[]); -typedef void (Tcl_CmdTraceProc) (ClientData clientData, Tcl_Interp *interp, +typedef void (Tcl_CmdTraceProc) (void *clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc, - ClientData cmdClientData, int argc, const char *argv[]); -typedef int (Tcl_CmdObjTraceProc) (ClientData clientData, Tcl_Interp *interp, + void *cmdClientData, int argc, const char *argv[]); +typedef int (Tcl_CmdObjTraceProc) (void *clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandInfo, int objc, struct Tcl_Obj *const *objv); typedef int (Tcl_CmdObjTraceProc2) (void *clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandInfo, size_t objc, struct Tcl_Obj *const *objv); -typedef void (Tcl_CmdObjTraceDeleteProc) (ClientData clientData); +typedef void (Tcl_CmdObjTraceDeleteProc) (void *clientData); typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr, struct Tcl_Obj *dupPtr); -typedef int (Tcl_EncodingConvertProc) (ClientData clientData, const char *src, +typedef int (Tcl_EncodingConvertProc) (void *clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); -typedef void (Tcl_EncodingFreeProc) (ClientData clientData); +typedef void (Tcl_EncodingFreeProc) (void *clientData); typedef int (Tcl_EventProc) (Tcl_Event *evPtr, int flags); -typedef void (Tcl_EventCheckProc) (ClientData clientData, int flags); -typedef int (Tcl_EventDeleteProc) (Tcl_Event *evPtr, ClientData clientData); -typedef void (Tcl_EventSetupProc) (ClientData clientData, int flags); -typedef void (Tcl_ExitProc) (ClientData clientData); -typedef void (Tcl_FileProc) (ClientData clientData, int mask); -typedef void (Tcl_FileFreeProc) (ClientData clientData); +typedef void (Tcl_EventCheckProc) (void *clientData, int flags); +typedef int (Tcl_EventDeleteProc) (Tcl_Event *evPtr, void *clientData); +typedef void (Tcl_EventSetupProc) (void *clientData, int flags); +typedef void (Tcl_ExitProc) (void *clientData); +typedef void (Tcl_FileProc) (void *clientData, int mask); +typedef void (Tcl_FileFreeProc) (void *clientData); typedef void (Tcl_FreeInternalRepProc) (struct Tcl_Obj *objPtr); typedef void (Tcl_FreeProc) (char *blockPtr); -typedef void (Tcl_IdleProc) (ClientData clientData); -typedef void (Tcl_InterpDeleteProc) (ClientData clientData, +typedef void (Tcl_IdleProc) (void *clientData); +typedef void (Tcl_InterpDeleteProc) (void *clientData, Tcl_Interp *interp); -typedef int (Tcl_MathProc) (ClientData clientData, Tcl_Interp *interp, +typedef int (Tcl_MathProc) (void *clientData, Tcl_Interp *interp, Tcl_Value *args, Tcl_Value *resultPtr); -typedef void (Tcl_NamespaceDeleteProc) (ClientData clientData); -typedef int (Tcl_ObjCmdProc) (ClientData clientData, Tcl_Interp *interp, +typedef void (Tcl_NamespaceDeleteProc) (void *clientData); +typedef int (Tcl_ObjCmdProc) (void *clientData, Tcl_Interp *interp, int objc, struct Tcl_Obj *const *objv); typedef int (Tcl_ObjCmdProc2) (void *clientData, Tcl_Interp *interp, size_t objc, struct Tcl_Obj *const *objv); typedef int (Tcl_LibraryInitProc) (Tcl_Interp *interp); typedef int (Tcl_LibraryUnloadProc) (Tcl_Interp *interp, int flags); typedef void (Tcl_PanicProc) (const char *format, ...); -typedef void (Tcl_TcpAcceptProc) (ClientData callbackData, Tcl_Channel chan, +typedef void (Tcl_TcpAcceptProc) (void *callbackData, Tcl_Channel chan, char *address, int port); -typedef void (Tcl_TimerProc) (ClientData clientData); +typedef void (Tcl_TimerProc) (void *clientData); typedef int (Tcl_SetFromAnyProc) (Tcl_Interp *interp, struct Tcl_Obj *objPtr); typedef void (Tcl_UpdateStringProc) (struct Tcl_Obj *objPtr); -typedef char * (Tcl_VarTraceProc) (ClientData clientData, Tcl_Interp *interp, +typedef char * (Tcl_VarTraceProc) (void *clientData, Tcl_Interp *interp, const char *part1, const char *part2, int flags); -typedef void (Tcl_CommandTraceProc) (ClientData clientData, Tcl_Interp *interp, +typedef void (Tcl_CommandTraceProc) (void *clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); typedef void (Tcl_CreateFileHandlerProc) (int fd, int mask, Tcl_FileProc *proc, - ClientData clientData); + void *clientData); typedef void (Tcl_DeleteFileHandlerProc) (int fd); -typedef void (Tcl_AlertNotifierProc) (ClientData clientData); +typedef void (Tcl_AlertNotifierProc) (void *clientData); typedef void (Tcl_ServiceModeHookProc) (int mode); -typedef ClientData (Tcl_InitNotifierProc) (void); -typedef void (Tcl_FinalizeNotifierProc) (ClientData clientData); +typedef void *(Tcl_InitNotifierProc) (void); +typedef void (Tcl_FinalizeNotifierProc) (void *clientData); typedef void (Tcl_MainLoopProc) (void); #ifndef TCL_NO_DEPRECATED @@ -786,9 +781,11 @@ typedef union Tcl_ObjInternalRep { /* The internal representation: */ * An object stores a value as either a string, some internal representation, * or both. */ +#define Tcl_Size int + typedef struct Tcl_Obj { - int refCount; /* When 0 the object will be freed. */ + Tcl_Size refCount; /* When 0 the object will be freed. */ char *bytes; /* This points to the first byte of the * object's string representation. The array * must be followed by a null byte (i.e., at @@ -800,7 +797,7 @@ typedef struct Tcl_Obj { * should use Tcl_GetStringFromObj or * Tcl_GetString to get a pointer to the byte * array as a readonly value. */ - int length; /* The number of bytes at *bytes, not + Tcl_Size length; /* The number of bytes at *bytes, not * including the terminating null. */ const Tcl_ObjType *typePtr; /* Denotes the object's type. Always * corresponds to the type of the object's @@ -843,7 +840,7 @@ typedef struct Tcl_Namespace { * is an synonym. */ char *fullName; /* The namespace's fully qualified name. This * starts with ::. */ - ClientData clientData; /* Arbitrary value associated with this + void *clientData; /* Arbitrary value associated with this * namespace. */ Tcl_NamespaceDeleteProc *deleteProc; /* Function invoked when deleting the @@ -880,14 +877,14 @@ typedef struct Tcl_Namespace { typedef struct Tcl_CallFrame { Tcl_Namespace *nsPtr; int dummy1; - int dummy2; + Tcl_Size dummy2; void *dummy3; void *dummy4; void *dummy5; - int dummy6; + Tcl_Size dummy6; void *dummy7; void *dummy8; - int dummy9; + Tcl_Size dummy9; void *dummy10; void *dummy11; void *dummy12; @@ -943,9 +940,9 @@ typedef struct Tcl_CmdInfo { typedef struct Tcl_DString { char *string; /* Points to beginning of string: either * staticSpace below or a malloced array. */ - int length; /* Number of non-NULL characters in the + Tcl_Size length; /* Number of non-NULL characters in the * string. */ - int spaceAvl; /* Total number of bytes available for the + Tcl_Size spaceAvl; /* Total number of bytes available for the * string and its terminating NULL char. */ char staticSpace[TCL_DSTRING_STATIC_SIZE]; /* Space to use in common case where string is @@ -1175,7 +1172,7 @@ struct Tcl_HashEntry { void *hash; /* Hash value, stored as pointer to ensure * that the offsets of the fields in this * structure are not changed. */ - ClientData clientData; /* Application stores something here with + void *clientData; /* Application stores something here with * Tcl_SetHashValue. */ union { /* Key has one of these forms: */ char *oneWordValue; /* One-word value for key. */ @@ -1263,11 +1260,11 @@ struct Tcl_HashTable { Tcl_HashEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; /* Bucket array used for small tables (to * avoid mallocs and frees). */ - int numBuckets; /* Total number of buckets allocated at + Tcl_Size numBuckets; /* Total number of buckets allocated at * **bucketPtr. */ - int numEntries; /* Total number of entries present in + Tcl_Size numEntries; /* Total number of entries present in * table. */ - int rebuildSize; /* Enlarge table when numEntries gets to be + Tcl_Size rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ int downShift; /* Shift count used in hashing function. * Designed to use high-order bits of @@ -1293,7 +1290,7 @@ struct Tcl_HashTable { typedef struct Tcl_HashSearch { Tcl_HashTable *tablePtr; /* Table being searched. */ - int nextIndex; /* Index of next bucket to be enumerated after + Tcl_Size nextIndex; /* Index of next bucket to be enumerated after * present one. */ Tcl_HashEntry *nextEntryPtr;/* Next entry to be enumerated in the current * bucket. */ @@ -1401,8 +1398,8 @@ typedef int (Tcl_WaitForEventProc) (CONST86 Tcl_Time *timePtr); * TIP #233 (Virtualized Time) */ -typedef void (Tcl_GetTimeProc) (Tcl_Time *timebuf, ClientData clientData); -typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, ClientData clientData); +typedef void (Tcl_GetTimeProc) (Tcl_Time *timebuf, void *clientData); +typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, void *clientData); /* *---------------------------------------------------------------------------- @@ -1463,35 +1460,35 @@ typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, ClientData clientData); * Typedefs for the various operations in a channel type: */ -typedef int (Tcl_DriverBlockModeProc) (ClientData instanceData, int mode); -typedef int (Tcl_DriverCloseProc) (ClientData instanceData, +typedef int (Tcl_DriverBlockModeProc) (void *instanceData, int mode); +typedef int (Tcl_DriverCloseProc) (void *instanceData, Tcl_Interp *interp); -typedef int (Tcl_DriverClose2Proc) (ClientData instanceData, +typedef int (Tcl_DriverClose2Proc) (void *instanceData, Tcl_Interp *interp, int flags); -typedef int (Tcl_DriverInputProc) (ClientData instanceData, char *buf, +typedef int (Tcl_DriverInputProc) (void *instanceData, char *buf, int toRead, int *errorCodePtr); -typedef int (Tcl_DriverOutputProc) (ClientData instanceData, +typedef int (Tcl_DriverOutputProc) (void *instanceData, const char *buf, int toWrite, int *errorCodePtr); -typedef int (Tcl_DriverSeekProc) (ClientData instanceData, long offset, +typedef int (Tcl_DriverSeekProc) (void *instanceData, long offset, int mode, int *errorCodePtr); -typedef int (Tcl_DriverSetOptionProc) (ClientData instanceData, +typedef int (Tcl_DriverSetOptionProc) (void *instanceData, Tcl_Interp *interp, const char *optionName, const char *value); -typedef int (Tcl_DriverGetOptionProc) (ClientData instanceData, +typedef int (Tcl_DriverGetOptionProc) (void *instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); -typedef void (Tcl_DriverWatchProc) (ClientData instanceData, int mask); -typedef int (Tcl_DriverGetHandleProc) (ClientData instanceData, - int direction, ClientData *handlePtr); -typedef int (Tcl_DriverFlushProc) (ClientData instanceData); -typedef int (Tcl_DriverHandlerProc) (ClientData instanceData, +typedef void (Tcl_DriverWatchProc) (void *instanceData, int mask); +typedef int (Tcl_DriverGetHandleProc) (void *instanceData, + int direction, void **handlePtr); +typedef int (Tcl_DriverFlushProc) (void *instanceData); +typedef int (Tcl_DriverHandlerProc) (void *instanceData, int interestMask); -typedef long long (Tcl_DriverWideSeekProc) (ClientData instanceData, +typedef long long (Tcl_DriverWideSeekProc) (void *instanceData, long long offset, int mode, int *errorCodePtr); /* * TIP #218, Channel Thread Actions */ -typedef void (Tcl_DriverThreadActionProc) (ClientData instanceData, +typedef void (Tcl_DriverThreadActionProc) (void *instanceData, int action); /* * TIP #208, File Truncation (etc.) @@ -1678,13 +1675,13 @@ typedef Tcl_Obj * (Tcl_FSLinkProc) (Tcl_Obj *pathPtr, Tcl_Obj *toPtr, typedef int (Tcl_FSLoadFileProc) (Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr); typedef int (Tcl_FSPathInFilesystemProc) (Tcl_Obj *pathPtr, - ClientData *clientDataPtr); + void **clientDataPtr); typedef Tcl_Obj * (Tcl_FSFilesystemPathTypeProc) (Tcl_Obj *pathPtr); typedef Tcl_Obj * (Tcl_FSFilesystemSeparatorProc) (Tcl_Obj *pathPtr); -typedef void (Tcl_FSFreeInternalRepProc) (ClientData clientData); -typedef ClientData (Tcl_FSDupInternalRepProc) (ClientData clientData); -typedef Tcl_Obj * (Tcl_FSInternalToNormalizedProc) (ClientData clientData); -typedef ClientData (Tcl_FSCreateInternalRepProc) (Tcl_Obj *pathPtr); +typedef void (Tcl_FSFreeInternalRepProc) (void *clientData); +typedef void *(Tcl_FSDupInternalRepProc) (void *clientData); +typedef Tcl_Obj * (Tcl_FSInternalToNormalizedProc) (void *clientData); +typedef void *(Tcl_FSCreateInternalRepProc) (Tcl_Obj *pathPtr); typedef struct Tcl_FSVersion_ *Tcl_FSVersion; @@ -1714,7 +1711,7 @@ typedef struct Tcl_FSVersion_ *Tcl_FSVersion; typedef struct Tcl_Filesystem { const char *typeName; /* The name of the filesystem. */ - int structureLength; /* Length of this structure, so future binary + Tcl_Size structureLength; /* Length of this structure, so future binary * compatibility can be assured. */ Tcl_FSVersion version; /* Version of the filesystem type. */ Tcl_FSPathInFilesystemProc *pathInFilesystemProc; @@ -1876,8 +1873,8 @@ typedef struct Tcl_Token { int type; /* Type of token, such as TCL_TOKEN_WORD; see * below for valid types. */ const char *start; /* First character in token. */ - int size; /* Number of bytes in token. */ - int numComponents; /* If this token is composed of other tokens, + Tcl_Size size; /* Number of bytes in token. */ + Tcl_Size numComponents; /* If this token is composed of other tokens, * this field tells how many of them there are * (including components of components, etc.). * The component tokens immediately follow @@ -1991,25 +1988,25 @@ typedef struct Tcl_Token { typedef struct Tcl_Parse { const char *commentStart; /* Pointer to # that begins the first of one * or more comments preceding the command. */ - int commentSize; /* Number of bytes in comments (up through + Tcl_Size commentSize; /* Number of bytes in comments (up through * newline character that terminates the last * comment). If there were no comments, this * field is 0. */ const char *commandStart; /* First character in first word of * command. */ - int commandSize; /* Number of bytes in command, including first + Tcl_Size commandSize; /* Number of bytes in command, including first * character of first word, up through the * terminating newline, close bracket, or * semicolon. */ - int numWords; /* Total number of words in command. May be + Tcl_Size numWords; /* Total number of words in command. May be * 0. */ Tcl_Token *tokenPtr; /* Pointer to first token representing the * words of the command. Initially points to * staticTokens, but may change to point to * malloc-ed space if command exceeds space in * staticTokens. */ - int numTokens; /* Total number of tokens in command. */ - int tokensAvailable; /* Total number of tokens available at + Tcl_Size numTokens; /* Total number of tokens in command. */ + Tcl_Size tokensAvailable; /* Total number of tokens available at * *tokenPtr. */ int errorType; /* One of the parsing error types defined * above. */ @@ -2062,7 +2059,7 @@ typedef struct Tcl_EncodingType { Tcl_EncodingFreeProc *freeProc; /* If non-NULL, function to call when this * encoding is deleted. */ - ClientData clientData; /* Arbitrary value associated with encoding + void *clientData; /* Arbitrary value associated with encoding * type. Passed to conversion functions. */ int nullSize; /* Number of zero bytes that signify * end-of-string in this encoding. This number @@ -2229,8 +2226,8 @@ typedef struct Tcl_Config { * command- or time-limit is exceeded by an interpreter. */ -typedef void (Tcl_LimitHandlerProc) (ClientData clientData, Tcl_Interp *interp); -typedef void (Tcl_LimitHandlerDeleteProc) (ClientData clientData); +typedef void (Tcl_LimitHandlerProc) (void *clientData, Tcl_Interp *interp); +typedef void (Tcl_LimitHandlerDeleteProc) (void *clientData); #if 0 /* @@ -2268,7 +2265,7 @@ typedef struct { * depends on type.*/ const char *helpStr; /* Documentation message describing this * option. */ - ClientData clientData; /* Word to pass to function callbacks. */ + void *clientData; /* Word to pass to function callbacks. */ } Tcl_ArgvInfo; /* @@ -2291,9 +2288,9 @@ typedef struct { * argument types: */ -typedef int (Tcl_ArgvFuncProc)(ClientData clientData, Tcl_Obj *objPtr, +typedef int (Tcl_ArgvFuncProc)(void *clientData, Tcl_Obj *objPtr, void *dstPtr); -typedef int (Tcl_ArgvGenFuncProc)(ClientData clientData, Tcl_Interp *interp, +typedef int (Tcl_ArgvGenFuncProc)(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, void *dstPtr); /* @@ -2366,19 +2363,19 @@ typedef int (Tcl_ArgvGenFuncProc)(ClientData clientData, Tcl_Interp *interp, #define TCL_TCPSERVER_REUSEPORT (1<<1) /* - * Constants for special int-typed values, see TIP #494 + * Constants for special Tcl_Size-typed values, see TIP #494 */ -#define TCL_IO_FAILURE (-1) -#define TCL_AUTO_LENGTH (-1) -#define TCL_INDEX_NONE (-1) +#define TCL_IO_FAILURE ((Tcl_Size)-1) +#define TCL_AUTO_LENGTH ((Tcl_Size)-1) +#define TCL_INDEX_NONE ((Tcl_Size)-1) /* *---------------------------------------------------------------------------- * Single public declaration for NRE. */ -typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp, +typedef int (Tcl_NRPostProc) (void *data[], Tcl_Interp *interp, int result); /* @@ -2437,7 +2434,7 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp, #define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \ ((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp)())) -EXTERN void Tcl_MainEx(int argc, char **argv, +EXTERN void Tcl_MainEx(Tcl_Size argc, char **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version, int exact); diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index b6f33a8..c3c44f3 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -820,7 +820,7 @@ TclArithSeriesGetElements( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *objPtr, /* AbstractList object for which an element * array is to be returned. */ - ListSizeT *objcPtr, /* Where to store the count of objects + Tcl_Size *objcPtr, /* Where to store the count of objects * referenced by objv. */ Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of * pointers to the list's objects. */ diff --git a/generic/tclCompile.h b/generic/tclCompile.h index b3f1c78..7e062f0 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -87,22 +87,22 @@ typedef enum { * to a catch PC offset. */ } ExceptionRangeType; -typedef struct ExceptionRange { +typedef struct { ExceptionRangeType type; /* The kind of ExceptionRange. */ - int nestingLevel; /* Static depth of the exception range. Used + Tcl_Size nestingLevel; /* Static depth of the exception range. Used * to find the most deeply-nested range * surrounding a PC at runtime. */ - int codeOffset; /* Offset of the first instruction byte of the + Tcl_Size codeOffset; /* Offset of the first instruction byte of the * code range. */ - int numCodeBytes; /* Number of bytes in the code range. */ - int breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC + Tcl_Size numCodeBytes; /* Number of bytes in the code range. */ + Tcl_Size breakOffset; /* If LOOP_EXCEPTION_RANGE, the target PC * offset for a break command in the range. */ - int continueOffset; /* If LOOP_EXCEPTION_RANGE and not TCL_INDEX_NONE, the + Tcl_Size continueOffset; /* If LOOP_EXCEPTION_RANGE and not TCL_INDEX_NONE, the * target PC offset for a continue command in * the code range. Otherwise, ignore this * range when processing a continue * command. */ - int catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC + Tcl_Size catchOffset; /* If a CATCH_EXCEPTION_RANGE, the target PC * offset for any "exception" in range. */ } ExceptionRange; @@ -118,21 +118,21 @@ typedef struct ExceptionAux { * one (see [for] next-clause) then we must * not pick up the range when scanning for a * target to continue to. */ - int stackDepth; /* The stack depth at the point where the + Tcl_Size stackDepth; /* The stack depth at the point where the * exception range was created. This is used * to calculate the number of POPs required to * restore the stack to its prior state. */ - int expandTarget; /* The number of expansions expected on the + Tcl_Size expandTarget; /* The number of expansions expected on the * auxData stack at the time the loop starts; * we can't currently discard them except by * doing INST_INVOKE_EXPANDED; this is a known * problem. */ - int expandTargetDepth; /* The stack depth expected at the outermost + Tcl_Size expandTargetDepth; /* The stack depth expected at the outermost * expansion within the loop. Not meaningful * if there are no open expansions between the * looping level and the point of jump * issue. */ - int numBreakTargets; /* The number of [break]s that want to be + Tcl_Size numBreakTargets; /* The number of [break]s that want to be * targeted to the place where this loop * exception will be bound to. */ TCL_HASH_TYPE *breakTargets; /* The offsets of the INST_JUMP4 instructions @@ -141,8 +141,8 @@ typedef struct ExceptionAux { * TclFixupForwardJump) can cause the contents * of this array to be updated. When * numBreakTargets==0, this is NULL. */ - int allocBreakTargets; /* The size of the breakTargets array. */ - int numContinueTargets; /* The number of [continue]s that want to be + Tcl_Size allocBreakTargets; /* The size of the breakTargets array. */ + Tcl_Size numContinueTargets; /* The number of [continue]s that want to be * targeted to the place where this loop * exception will be bound to. */ TCL_HASH_TYPE *continueTargets; /* The offsets of the INST_JUMP4 instructions @@ -151,7 +151,7 @@ typedef struct ExceptionAux { * TclFixupForwardJump) can cause the contents * of this array to be updated. When * numContinueTargets==0, this is NULL. */ - int allocContinueTargets; /* The size of the continueTargets array. */ + Tcl_Size allocContinueTargets; /* The size of the continueTargets array. */ } ExceptionAux; /* @@ -162,11 +162,11 @@ typedef struct ExceptionAux { * source offset is not monotonic. */ -typedef struct CmdLocation { - int codeOffset; /* Offset of first byte of command code. */ - int numCodeBytes; /* Number of bytes for command's code. */ - int srcOffset; /* Offset of first char of the command. */ - int numSrcBytes; /* Number of command source chars. */ +typedef struct { + Tcl_Size codeOffset; /* Offset of first byte of command code. */ + Tcl_Size numCodeBytes; /* Number of bytes for command's code. */ + Tcl_Size srcOffset; /* Offset of first char of the command. */ + Tcl_Size numSrcBytes; /* Number of command source chars. */ } CmdLocation; /* @@ -180,9 +180,9 @@ typedef struct CmdLocation { * frame and associated information, like the path of a sourced file. */ -typedef struct ECL { - int srcOffset; /* Command location to find the entry. */ - int nline; /* Number of words in the command */ +typedef struct { + Tcl_Size srcOffset; /* Command location to find the entry. */ + Tcl_Size nline; /* Number of words in the command */ int *line; /* Line information for all words in the * command. */ int **next; /* Transient information used by the compiler @@ -190,7 +190,7 @@ typedef struct ECL { * lines. */ } ECL; -typedef struct ExtCmdLoc { +typedef struct { int type; /* Context type. */ int start; /* Starting line for compiled script. Needed * for the extended recompile check in @@ -198,8 +198,8 @@ typedef struct ExtCmdLoc { Tcl_Obj *path; /* Path of the sourced file the command is * in. */ ECL *loc; /* Command word locations (lines). */ - int nloc; /* Number of allocated entries in 'loc'. */ - int nuloc; /* Number of used entries in 'loc'. */ + Tcl_Size nloc; /* Number of allocated entries in 'loc'. */ + Tcl_Size nuloc; /* Number of used entries in 'loc'. */ } ExtCmdLoc; /* @@ -290,21 +290,21 @@ typedef struct CompileEnv { * SetByteCodeFromAny. This pointer is not * owned by the CompileEnv and must not be * freed or changed by it. */ - int numSrcBytes; /* Number of bytes in source. */ + Tcl_Size numSrcBytes; /* Number of bytes in source. */ Proc *procPtr; /* If a procedure is being compiled, a pointer * to its Proc structure; otherwise NULL. Used * to compile local variables. Set from * information provided by ObjInterpProc in * tclProc.c. */ - int numCommands; /* Number of commands compiled. */ - int exceptDepth; /* Current exception range nesting level; TCL_INDEX_NONE + Tcl_Size numCommands; /* Number of commands compiled. */ + Tcl_Size exceptDepth; /* Current exception range nesting level; TCL_INDEX_NONE * if not in any range currently. */ - int maxExceptDepth; /* Max nesting level of exception ranges; TCL_INDEX_NONE + Tcl_Size maxExceptDepth; /* Max nesting level of exception ranges; TCL_INDEX_NONE * if no ranges have been compiled. */ - int maxStackDepth; /* Maximum number of stack elements needed to + Tcl_Size maxStackDepth; /* Maximum number of stack elements needed to * execute the code. Set by compilation * procedures before returning. */ - int currStackDepth; /* Current stack depth. */ + Tcl_Size currStackDepth; /* Current stack depth. */ LiteralTable localLitTable; /* Contains LiteralEntry's describing all Tcl * objects referenced by this compiled code. * Indexed by the string representations of @@ -318,18 +318,18 @@ typedef struct CompileEnv { * codeStart points into the heap.*/ LiteralEntry *literalArrayPtr; /* Points to start of LiteralEntry array. */ - int literalArrayNext; /* Index of next free object array entry. */ - int literalArrayEnd; /* Index just after last obj array entry. */ + Tcl_Size literalArrayNext; /* Index of next free object array entry. */ + Tcl_Size literalArrayEnd; /* Index just after last obj array entry. */ int mallocedLiteralArray; /* 1 if object array was expanded and objArray * points into the heap, else 0. */ ExceptionRange *exceptArrayPtr; /* Points to start of the ExceptionRange * array. */ - int exceptArrayNext; /* Next free ExceptionRange array index. + Tcl_Size exceptArrayNext; /* Next free ExceptionRange array index. * exceptArrayNext is the number of ranges and * (exceptArrayNext-1) is the index of the * current range's array entry. */ - int exceptArrayEnd; /* Index after the last ExceptionRange array + Tcl_Size exceptArrayEnd; /* Index after the last ExceptionRange array * entry. */ int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and * exceptArrayPtr points in heap, else 0. */ @@ -342,15 +342,15 @@ typedef struct CompileEnv { * numCommands is the index of the next entry * to use; (numCommands-1) is the entry index * for the last command. */ - int cmdMapEnd; /* Index after last CmdLocation entry. */ + Tcl_Size cmdMapEnd; /* Index after last CmdLocation entry. */ int mallocedCmdMap; /* 1 if command map array was expanded and * cmdMapPtr points in the heap, else 0. */ AuxData *auxDataArrayPtr; /* Points to auxiliary data array start. */ - int auxDataArrayNext; /* Next free compile aux data array index. + Tcl_Size auxDataArrayNext; /* Next free compile aux data array index. * auxDataArrayNext is the number of aux data * items and (auxDataArrayNext-1) is index of * current aux data array entry. */ - int auxDataArrayEnd; /* Index after last aux data array entry. */ + Tcl_Size auxDataArrayEnd; /* Index after last aux data array entry. */ int mallocedAuxDataArray; /* 1 if aux data array was expanded and * auxDataArrayPtr points in heap else 0. */ unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES]; @@ -369,7 +369,7 @@ typedef struct CompileEnv { /* TIP #280 */ ExtCmdLoc *extCmdMapPtr; /* Extended command location information for * 'info frame'. */ - int line; /* First line of the script, based on the + Tcl_Size line; /* First line of the script, based on the * invoking context, then the line of the * command currently compiled. */ int atCmdStart; /* Flag to say whether an INST_START_CMD @@ -378,7 +378,7 @@ typedef struct CompileEnv { * inefficient. If set to 2, that instruction * should not be issued at all (by the generic * part of the command compiler). */ - int expandCount; /* Number of INST_EXPAND_START instructions + Tcl_Size expandCount; /* Number of INST_EXPAND_START instructions * encountered that have not yet been paired * with a corresponding * INST_INVOKE_EXPANDED. */ @@ -417,7 +417,7 @@ typedef struct ByteCode { * procs are specific to an interpreter so the * code emitted will depend on the * interpreter. */ - int compileEpoch; /* Value of iPtr->compileEpoch when this + Tcl_Size compileEpoch; /* Value of iPtr->compileEpoch when this * ByteCode was compiled. Used to invalidate * code when, e.g., commands with compile * procs are redefined. */ @@ -425,11 +425,11 @@ typedef struct ByteCode { * compiled. If the code is executed if a * different namespace, it must be * recompiled. */ - int nsEpoch; /* Value of nsPtr->resolverEpoch when this + Tcl_Size nsEpoch; /* Value of nsPtr->resolverEpoch when this * ByteCode was compiled. Used to invalidate * code when new namespace resolution rules * are put into effect. */ - int refCount; /* Reference count: set 1 when created plus 1 + Tcl_Size refCount; /* Reference count: set 1 when created plus 1 * for each execution of the code currently * active. This structure can be freed when * refCount becomes zero. */ @@ -449,17 +449,17 @@ typedef struct ByteCode { * itself. Does not include heap space for * literal Tcl objects or storage referenced * by AuxData entries. */ - int numCommands; /* Number of commands compiled. */ - int numSrcBytes; /* Number of source bytes compiled. */ - int numCodeBytes; /* Number of code bytes. */ - int numLitObjects; /* Number of objects in literal array. */ - int numExceptRanges; /* Number of ExceptionRange array elems. */ - int numAuxDataItems; /* Number of AuxData items. */ - int numCmdLocBytes; /* Number of bytes needed for encoded command + Tcl_Size numCommands; /* Number of commands compiled. */ + Tcl_Size numSrcBytes; /* Number of source bytes compiled. */ + Tcl_Size numCodeBytes; /* Number of code bytes. */ + Tcl_Size numLitObjects; /* Number of objects in literal array. */ + Tcl_Size numExceptRanges; /* Number of ExceptionRange array elems. */ + Tcl_Size numAuxDataItems; /* Number of AuxData items. */ + Tcl_Size numCmdLocBytes; /* Number of bytes needed for encoded command * location information. */ - int maxExceptDepth; /* Maximum nesting level of ExceptionRanges; + Tcl_Size maxExceptDepth; /* Maximum nesting level of ExceptionRanges; * TCL_INDEX_NONE if no ranges were compiled. */ - int maxStackDepth; /* Maximum number of stack elements needed to + Tcl_Size maxStackDepth; /* Maximum number of stack elements needed to * execute the code. */ unsigned char *codeStart; /* Points to the first byte of the code. This * is just after the final ByteCode member @@ -536,7 +536,7 @@ typedef struct ByteCode { * Opcodes for the Tcl bytecode instructions. These must correspond to the * entries in the table of instruction descriptions, tclInstructionTable, in * tclCompile.c. Also, the order and number of the expression opcodes (e.g., - * INST_LOR) must match the entries in the array operatorStrings in + * INST_BITOR) must match the entries in the array operatorStrings in * tclExecute.c. */ @@ -887,7 +887,7 @@ typedef enum InstOperandType { typedef struct InstructionDesc { const char *name; /* Name of instruction. */ - int numBytes; /* Total number of bytes for instruction. */ + Tcl_Size numBytes; /* Total number of bytes for instruction. */ int stackEffect; /* The worst-case balance stack effect of the * instruction, used for stack requirements * computations. The value INT_MIN signals @@ -975,8 +975,8 @@ typedef struct JumpFixup { typedef struct JumpFixupArray { JumpFixup *fixup; /* Points to start of jump fixup array. */ - int next; /* Index of next free array entry. */ - int end; /* Index of last usable entry in array. */ + Tcl_Size next; /* Index of next free array entry. */ + Tcl_Size end; /* Index of last usable entry in array. */ int mallocedArray; /* 1 if array was expanded and fixups points * into the heap, else 0. */ JumpFixup staticFixupSpace[JUMPFIXUP_INIT_ENTRIES]; @@ -991,8 +991,8 @@ typedef struct JumpFixupArray { */ typedef struct ForeachVarList { - int numVars; /* The number of variables in the list. */ - int varIndexes[TCLFLEXARRAY];/* An array of the indexes ("slot numbers") + Tcl_Size numVars; /* The number of variables in the list. */ + Tcl_Size varIndexes[TCLFLEXARRAY];/* An array of the indexes ("slot numbers") * for each variable in the procedure's array * of local variables. Only scalar variables * are supported. The actual size of this @@ -1008,11 +1008,11 @@ typedef struct ForeachVarList { */ typedef struct ForeachInfo { - int numLists; /* The number of both the variable and value + Tcl_Size numLists; /* The number of both the variable and value * lists of the foreach command. */ - int firstValueTemp; /* Index of the first temp var in a proc frame + Tcl_Size firstValueTemp; /* Index of the first temp var in a proc frame * used to point to a value list. */ - int loopCtTemp; /* Index of temp var in a proc frame holding + Tcl_Size loopCtTemp; /* Index of temp var in a proc frame holding * the loop's iteration count. Used to * determine next value list element to assign * each loop var. */ @@ -1046,8 +1046,8 @@ MODULE_SCOPE const AuxDataType tclJumptableInfoType; */ typedef struct { - int length; /* Size of array */ - int varIndices[TCLFLEXARRAY]; /* Array of variable indices to manage when + Tcl_Size length; /* Size of array */ + Tcl_Size varIndices[TCLFLEXARRAY]; /* Array of variable indices to manage when * processing the start and end of a [dict * update]. There is really more than one * entry, and the structure is allocated to @@ -1093,38 +1093,38 @@ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr, */ MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, - Tcl_Parse *parsePtr, int depth, Command *cmdPtr, + Tcl_Parse *parsePtr, Tcl_Size depth, Command *cmdPtr, CompileEnv *envPtr); MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, ExceptionAux *auxPtr); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, - Tcl_Token *tokenPtr, int count, + Tcl_Token *tokenPtr, Tcl_Size count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script, - int numBytes, CompileEnv *envPtr, int optimize); + Tcl_Size numBytes, CompileEnv *envPtr, int optimize); MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp, - Tcl_Token *tokenPtr, int numWords, + Tcl_Token *tokenPtr, Tcl_Size numWords, CompileEnv *envPtr); MODULE_SCOPE void TclCompileInvocation(Tcl_Interp *interp, - Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords, + Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, Tcl_Size numWords, CompileEnv *envPtr); MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp, - const char *script, int numBytes, + const char *script, Tcl_Size numBytes, CompileEnv *envPtr); MODULE_SCOPE void TclCompileSyntaxError(Tcl_Interp *interp, CompileEnv *envPtr); MODULE_SCOPE void TclCompileTokens(Tcl_Interp *interp, - Tcl_Token *tokenPtr, int count, + Tcl_Token *tokenPtr, Tcl_Size count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp, Tcl_Token *tokenPtr, CompileEnv *envPtr); -MODULE_SCOPE int TclCreateAuxData(void *clientData, +MODULE_SCOPE Tcl_Size TclCreateAuxData(void *clientData, const AuxDataType *typePtr, CompileEnv *envPtr); -MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type, +MODULE_SCOPE Tcl_Size TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); -MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size); +MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, Tcl_Size size); MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes, - int length, TCL_HASH_TYPE hash, int *newPtr, + Tcl_Size length, TCL_HASH_TYPE hash, int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr); MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr); @@ -1139,7 +1139,7 @@ MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, ByteCode *codePtr); MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, TCL_HASH_TYPE index); -MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars, +MODULE_SCOPE Tcl_Size TclFindCompiledLocal(const char *name, Tcl_Size nameChars, int create, CompileEnv *envPtr); MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, JumpFixup *jumpFixupPtr, int jumpDist, @@ -1147,13 +1147,13 @@ MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr, - int before, int after, int *indexPtr); + Tcl_Size before, Tcl_Size after, int *indexPtr); MODULE_SCOPE ByteCode * TclInitByteCode(CompileEnv *envPtr); MODULE_SCOPE ByteCode * TclInitByteCodeObj(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, CompileEnv *envPtr); MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr, const char *string, - int numBytes, const CmdFrame *invoker, int word); + Tcl_Size numBytes, const CmdFrame *invoker, int word); MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr); MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr, @@ -1168,9 +1168,9 @@ MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr, MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); MODULE_SCOPE int TclLog2(int value); #endif -MODULE_SCOPE int TclLocalScalar(const char *bytes, int numBytes, +MODULE_SCOPE Tcl_Size TclLocalScalar(const char *bytes, Tcl_Size numBytes, CompileEnv *envPtr); -MODULE_SCOPE int TclLocalScalarFromToken(Tcl_Token *tokenPtr, +MODULE_SCOPE Tcl_Size TclLocalScalarFromToken(Tcl_Token *tokenPtr, CompileEnv *envPtr); MODULE_SCOPE void TclOptimizeBytecode(void *envPtr); #ifdef TCL_COMPILE_DEBUG @@ -1180,9 +1180,9 @@ MODULE_SCOPE void TclPrintByteCodeObj(Tcl_Interp *interp, MODULE_SCOPE int TclPrintInstruction(ByteCode *codePtr, const unsigned char *pc); MODULE_SCOPE void TclPrintObject(FILE *outFile, - Tcl_Obj *objPtr, int maxChars); + Tcl_Obj *objPtr, Tcl_Size maxChars); MODULE_SCOPE void TclPrintSource(FILE *outFile, - const char *string, int maxChars); + const char *string, Tcl_Size maxChars); MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, @@ -1204,13 +1204,13 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr, Tcl_Obj *valuePtr); MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp, const char *script, const char *command, - int length, const unsigned char *pc, + Tcl_Size length, const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); MODULE_SCOPE int TclPushProcCallFrame(void *clientData, - Tcl_Interp *interp, int objc, + Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int isLambda); @@ -1505,7 +1505,7 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, (*((p)+3)))) /* - * Macros used to compute the minimum and maximum of two integers. The ANSI C + * Macros used to compute the minimum and maximum of two values. The ANSI C * "prototypes" for these macros are: * * int TclMin(int i, int j); @@ -1543,7 +1543,7 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, * these macros are: * * static void PushLiteral(CompileEnv *envPtr, - * const char *string, int length); + * const char *string, Tcl_Size length); * static void PushStringLiteral(CompileEnv *envPtr, * const char *string); */ @@ -1551,7 +1551,7 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, #define PushLiteral(envPtr, string, length) \ TclEmitPush(TclRegisterLiteral((envPtr), (string), (length), 0), (envPtr)) #define PushStringLiteral(envPtr, string) \ - PushLiteral((envPtr), (string), (int) (sizeof(string "") - 1)) + PushLiteral((envPtr), (string), sizeof(string "") - 1) /* * Macro to advance to the next token; it is more mnemonic than the address @@ -1567,7 +1567,7 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, * Macro to get the offset to the next instruction to be issued. The ANSI C * "prototype" for this macro is: * - * static int CurrentOffset(CompileEnv *envPtr); + * static ptrdiff_t CurrentOffset(CompileEnv *envPtr); */ #define CurrentOffset(envPtr) \ @@ -1580,9 +1580,9 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, * of LOOP ranges is an interesting datum for debugging purposes, and that is * what we compute now. * - * static int ExceptionRangeStarts(CompileEnv *envPtr, int index); - * static void ExceptionRangeEnds(CompileEnv *envPtr, int index); - * static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL); + * static int ExceptionRangeStarts(CompileEnv *envPtr, Tcl_Size index); + * static void ExceptionRangeEnds(CompileEnv *envPtr, Tcl_Size index); + * static void ExceptionRangeTarget(CompileEnv *envPtr, Tcl_Size index, LABEL); */ #define ExceptionRangeStarts(envPtr, index) \ @@ -1641,7 +1641,7 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, #define DefineLineInformation \ ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ - int eclIndex = mapPtr->nuloc - 1 + Tcl_Size eclIndex = mapPtr->nuloc - 1 #define SetLineInformation(word) \ envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ @@ -1819,8 +1819,8 @@ MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, int *argsi); FILE *tclDTraceDebugLog = NULL; \ void TclDTraceOpenDebugLog(void) { \ char n[35]; \ - sprintf(n, "/tmp/tclDTraceDebug-%lu.log", \ - (unsigned long) getpid()); \ + sprintf(n, "/tmp/tclDTraceDebug-%" TCL_Z_MODIFIER "u.log", \ + (size_t) getpid()); \ tclDTraceDebugLog = fopen(n, "a"); \ } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index e54ea2c..ef1904f 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -109,9 +109,9 @@ EXTERN int Tcl_AppendAllObjTypes(Tcl_Interp *interp, EXTERN void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...); /* 16 */ EXTERN void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, - int length); + Tcl_Size length); /* 17 */ -EXTERN Tcl_Obj * Tcl_ConcatObj(int objc, Tcl_Obj *const objv[]); +EXTERN Tcl_Obj * Tcl_ConcatObj(Tcl_Size objc, Tcl_Obj *const objv[]); /* 18 */ EXTERN int Tcl_ConvertToType(Tcl_Interp *interp, Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); @@ -130,12 +130,13 @@ Tcl_Obj * Tcl_DbNewBooleanObj(int intValue, const char *file, int line); /* 23 */ EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes, - int numBytes, const char *file, int line); + Tcl_Size numBytes, const char *file, + int line); /* 24 */ EXTERN Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, const char *file, int line); /* 25 */ -EXTERN Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv, +EXTERN Tcl_Obj * Tcl_DbNewListObj(Tcl_Size objc, Tcl_Obj *const *objv, const char *file, int line); /* 26 */ TCL_DEPRECATED("No longer in use, changed to macro") @@ -144,8 +145,8 @@ Tcl_Obj * Tcl_DbNewLongObj(long longValue, const char *file, /* 27 */ EXTERN Tcl_Obj * Tcl_DbNewObj(const char *file, int line); /* 28 */ -EXTERN Tcl_Obj * Tcl_DbNewStringObj(const char *bytes, int length, - const char *file, int line); +EXTERN Tcl_Obj * Tcl_DbNewStringObj(const char *bytes, + Tcl_Size length, const char *file, int line); /* 29 */ EXTERN Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr); /* 30 */ @@ -197,59 +198,62 @@ EXTERN int Tcl_ListObjGetElements(Tcl_Interp *interp, Tcl_Obj ***objvPtr); /* 46 */ EXTERN int Tcl_ListObjIndex(Tcl_Interp *interp, - Tcl_Obj *listPtr, int index, + Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj **objPtrPtr); /* 47 */ EXTERN int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 48 */ EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp, - Tcl_Obj *listPtr, int first, int count, - int objc, Tcl_Obj *const objv[]); + Tcl_Obj *listPtr, Tcl_Size first, + Tcl_Size count, Tcl_Size objc, + Tcl_Obj *const objv[]); /* 49 */ TCL_DEPRECATED("No longer in use, changed to macro") Tcl_Obj * Tcl_NewBooleanObj(int intValue); /* 50 */ EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes, - int numBytes); + Tcl_Size numBytes); /* 51 */ EXTERN Tcl_Obj * Tcl_NewDoubleObj(double doubleValue); /* 52 */ TCL_DEPRECATED("No longer in use, changed to macro") Tcl_Obj * Tcl_NewIntObj(int intValue); /* 53 */ -EXTERN Tcl_Obj * Tcl_NewListObj(int objc, Tcl_Obj *const objv[]); +EXTERN Tcl_Obj * Tcl_NewListObj(Tcl_Size objc, Tcl_Obj *const objv[]); /* 54 */ TCL_DEPRECATED("No longer in use, changed to macro") Tcl_Obj * Tcl_NewLongObj(long longValue); /* 55 */ EXTERN Tcl_Obj * Tcl_NewObj(void); /* 56 */ -EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, int length); +EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, Tcl_Size length); /* 57 */ TCL_DEPRECATED("No longer in use, changed to macro") void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int intValue); /* 58 */ -EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int numBytes); +EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, + Tcl_Size numBytes); /* 59 */ EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, - const unsigned char *bytes, int numBytes); + const unsigned char *bytes, + Tcl_Size numBytes); /* 60 */ EXTERN void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue); /* 61 */ TCL_DEPRECATED("No longer in use, changed to macro") void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue); /* 62 */ -EXTERN void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, +EXTERN void Tcl_SetListObj(Tcl_Obj *objPtr, Tcl_Size objc, Tcl_Obj *const objv[]); /* 63 */ TCL_DEPRECATED("No longer in use, changed to macro") void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue); /* 64 */ -EXTERN void Tcl_SetObjLength(Tcl_Obj *objPtr, int length); +EXTERN void Tcl_SetObjLength(Tcl_Obj *objPtr, Tcl_Size length); /* 65 */ EXTERN void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, - int length); + Tcl_Size length); /* 66 */ TCL_DEPRECATED("No longer in use, changed to macro") void Tcl_AddErrorInfo(Tcl_Interp *interp, @@ -297,22 +301,22 @@ EXTERN int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan); /* 82 */ EXTERN int Tcl_CommandComplete(const char *cmd); /* 83 */ -EXTERN char * Tcl_Concat(int argc, const char *const *argv); +EXTERN char * Tcl_Concat(Tcl_Size argc, const char *const *argv); /* 84 */ -EXTERN int Tcl_ConvertElement(const char *src, char *dst, +EXTERN Tcl_Size Tcl_ConvertElement(const char *src, char *dst, int flags); /* 85 */ -EXTERN int Tcl_ConvertCountedElement(const char *src, - int length, char *dst, int flags); +EXTERN Tcl_Size Tcl_ConvertCountedElement(const char *src, + Tcl_Size length, char *dst, int flags); /* 86 */ EXTERN int Tcl_CreateAlias(Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, - const char *targetCmd, int argc, + const char *targetCmd, Tcl_Size argc, const char *const *argv); /* 87 */ EXTERN int Tcl_CreateAliasObj(Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, - const char *targetCmd, int objc, + const char *targetCmd, Tcl_Size objc, Tcl_Obj *const objv[]); /* 88 */ EXTERN Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr, @@ -390,7 +394,7 @@ EXTERN void Tcl_DeleteHashTable(Tcl_HashTable *tablePtr); /* 110 */ EXTERN void Tcl_DeleteInterp(Tcl_Interp *interp); /* 111 */ -EXTERN void Tcl_DetachPids(int numPids, Tcl_Pid *pidPtr); +EXTERN void Tcl_DetachPids(Tcl_Size numPids, Tcl_Pid *pidPtr); /* 112 */ EXTERN void Tcl_DeleteTimerHandler(Tcl_TimerToken token); /* 113 */ @@ -404,7 +408,7 @@ EXTERN int Tcl_DoOneEvent(int flags); EXTERN void Tcl_DoWhenIdle(Tcl_IdleProc *proc, void *clientData); /* 117 */ EXTERN char * Tcl_DStringAppend(Tcl_DString *dsPtr, - const char *bytes, int length); + const char *bytes, Tcl_Size length); /* 118 */ EXTERN char * Tcl_DStringAppendElement(Tcl_DString *dsPtr, const char *element); @@ -421,7 +425,8 @@ EXTERN void Tcl_DStringInit(Tcl_DString *dsPtr); EXTERN void Tcl_DStringResult(Tcl_Interp *interp, Tcl_DString *dsPtr); /* 124 */ -EXTERN void Tcl_DStringSetLength(Tcl_DString *dsPtr, int length); +EXTERN void Tcl_DStringSetLength(Tcl_DString *dsPtr, + Tcl_Size length); /* 125 */ EXTERN void Tcl_DStringStartSublist(Tcl_DString *dsPtr); /* 126 */ @@ -502,7 +507,7 @@ EXTERN void * Tcl_GetAssocData(Tcl_Interp *interp, EXTERN Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, const char *chanName, int *modePtr); /* 152 */ -EXTERN int Tcl_GetChannelBufferSize(Tcl_Channel chan); +EXTERN Tcl_Size Tcl_GetChannelBufferSize(Tcl_Channel chan); /* 153 */ EXTERN int Tcl_GetChannelHandle(Tcl_Channel chan, int direction, void **handlePtr); @@ -552,9 +557,9 @@ EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp, /* 168 */ EXTERN Tcl_PathType Tcl_GetPathType(const char *path); /* 169 */ -EXTERN int Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr); +EXTERN Tcl_Size Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr); /* 170 */ -EXTERN int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr); +EXTERN Tcl_Size Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 171 */ EXTERN int Tcl_GetServiceMode(void); /* 172 */ @@ -595,7 +600,7 @@ EXTERN int Tcl_InterpDeleted(Tcl_Interp *interp); /* 185 */ EXTERN int Tcl_IsSafe(Tcl_Interp *interp); /* 186 */ -EXTERN char * Tcl_JoinPath(int argc, const char *const *argv, +EXTERN char * Tcl_JoinPath(Tcl_Size argc, const char *const *argv, Tcl_DString *resultPtr); /* 187 */ EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, @@ -609,7 +614,7 @@ int Tcl_MakeSafe(Tcl_Interp *interp); /* 191 */ EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket); /* 192 */ -EXTERN char * Tcl_Merge(int argc, const char *const *argv); +EXTERN char * Tcl_Merge(Tcl_Size argc, const char *const *argv); /* 193 */ EXTERN Tcl_HashEntry * Tcl_NextHashEntry(Tcl_HashSearch *searchPtr); /* 194 */ @@ -622,8 +627,8 @@ EXTERN Tcl_Obj * Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 197 */ -EXTERN Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc, - const char **argv, int flags); +EXTERN Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, + Tcl_Size argc, const char **argv, int flags); /* 198 */ EXTERN Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, const char *fileName, const char *modeString, @@ -649,7 +654,8 @@ EXTERN const char * Tcl_PosixError(Tcl_Interp *interp); /* 205 */ EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr, int position); /* 206 */ -EXTERN int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead); +EXTERN Tcl_Size Tcl_Read(Tcl_Channel chan, char *bufPtr, + Tcl_Size toRead); /* 207 */ EXTERN void Tcl_ReapDetachedProcs(void); /* 208 */ @@ -673,17 +679,17 @@ EXTERN int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp, EXTERN int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text, const char *pattern); /* 215 */ -EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, int index, +EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, Tcl_Size index, const char **startPtr, const char **endPtr); /* 216 */ EXTERN void Tcl_Release(void *clientData); /* 217 */ EXTERN void Tcl_ResetResult(Tcl_Interp *interp); /* 218 */ -EXTERN int Tcl_ScanElement(const char *src, int *flagPtr); +EXTERN Tcl_Size Tcl_ScanElement(const char *src, int *flagPtr); /* 219 */ -EXTERN int Tcl_ScanCountedElement(const char *src, int length, - int *flagPtr); +EXTERN Tcl_Size Tcl_ScanCountedElement(const char *src, + Tcl_Size length, int *flagPtr); /* 220 */ TCL_DEPRECATED("") int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode); @@ -696,7 +702,8 @@ EXTERN void Tcl_SetAssocData(Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, void *clientData); /* 224 */ -EXTERN void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz); +EXTERN void Tcl_SetChannelBufferSize(Tcl_Channel chan, + Tcl_Size sz); /* 225 */ EXTERN int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, @@ -715,7 +722,8 @@ EXTERN void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr); EXTERN const char * Tcl_SetPanicProc( TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 231 */ -EXTERN int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth); +EXTERN Tcl_Size Tcl_SetRecursionLimit(Tcl_Interp *interp, + Tcl_Size depth); /* 232 */ EXTERN void Tcl_SetResult(Tcl_Interp *interp, char *result, Tcl_FreeProc *freeProc); @@ -774,8 +782,8 @@ EXTERN int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, EXTERN char * Tcl_TranslateFileName(Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 250 */ -EXTERN int Tcl_Ungets(Tcl_Channel chan, const char *str, - int len, int atHead); +EXTERN Tcl_Size Tcl_Ungets(Tcl_Channel chan, const char *str, + Tcl_Size len, int atHead); /* 251 */ EXTERN void Tcl_UnlinkVar(Tcl_Interp *interp, const char *varName); @@ -825,9 +833,10 @@ EXTERN void * Tcl_VarTraceInfo2(Tcl_Interp *interp, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 263 */ -EXTERN int Tcl_Write(Tcl_Channel chan, const char *s, int slen); +EXTERN Tcl_Size Tcl_Write(Tcl_Channel chan, const char *s, + Tcl_Size slen); /* 264 */ -EXTERN void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc, +EXTERN void Tcl_WrongNumArgs(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], const char *message); /* 265 */ EXTERN int Tcl_DumpActiveMemory(const char *fileName); @@ -908,9 +917,9 @@ TCL_DEPRECATED("Use Tcl_DiscardInterpState") void Tcl_DiscardResult(Tcl_SavedResult *statePtr); /* 291 */ EXTERN int Tcl_EvalEx(Tcl_Interp *interp, const char *script, - int numBytes, int flags); + Tcl_Size numBytes, int flags); /* 292 */ -EXTERN int Tcl_EvalObjv(Tcl_Interp *interp, int objc, +EXTERN int Tcl_EvalObjv(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags); /* 293 */ EXTERN int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -920,13 +929,13 @@ EXTERN TCL_NORETURN void Tcl_ExitThread(int status); /* 295 */ EXTERN int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, - int srcLen, int flags, + Tcl_Size srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, - int dstLen, int *srcReadPtr, + Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 296 */ EXTERN char * Tcl_ExternalToUtfDString(Tcl_Encoding encoding, - const char *src, int srcLen, + const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr); /* 297 */ EXTERN void Tcl_FinalizeThread(void); @@ -945,11 +954,11 @@ EXTERN void Tcl_GetEncodingNames(Tcl_Interp *interp); /* 304 */ EXTERN int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, - int offset, const char *msg, int flags, + Tcl_Size offset, const char *msg, int flags, void *indexPtr); /* 305 */ EXTERN void * Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, - int size); + Tcl_Size size); /* 306 */ EXTERN Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, const char *part1, const char *part2, int flags); @@ -965,10 +974,10 @@ EXTERN void Tcl_ConditionNotify(Tcl_Condition *condPtr); EXTERN void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 312 */ -EXTERN int Tcl_NumUtfChars(const char *src, int length); +EXTERN Tcl_Size Tcl_NumUtfChars(const char *src, Tcl_Size length); /* 313 */ -EXTERN int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, - int charsToRead, int appendFlag); +EXTERN Tcl_Size Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, + Tcl_Size charsToRead, int appendFlag); /* 314 */ TCL_DEPRECATED("Use Tcl_RestoreInterpState") void Tcl_RestoreResult(Tcl_Interp *interp, @@ -990,7 +999,7 @@ EXTERN void Tcl_ThreadAlert(Tcl_ThreadId threadId); EXTERN void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr, int position); /* 320 */ -EXTERN int Tcl_UniCharAtIndex(const char *src, int index); +EXTERN int Tcl_UniCharAtIndex(const char *src, Tcl_Size index); /* 321 */ EXTERN int Tcl_UniCharToLower(int ch); /* 322 */ @@ -1000,11 +1009,11 @@ EXTERN int Tcl_UniCharToUpper(int ch); /* 324 */ EXTERN int Tcl_UniCharToUtf(int ch, char *buf); /* 325 */ -EXTERN const char * Tcl_UtfAtIndex(const char *src, int index); +EXTERN const char * Tcl_UtfAtIndex(const char *src, Tcl_Size index); /* 326 */ -EXTERN int TclUtfCharComplete(const char *src, int length); +EXTERN int TclUtfCharComplete(const char *src, Tcl_Size length); /* 327 */ -EXTERN int Tcl_UtfBackslash(const char *src, int *readPtr, +EXTERN Tcl_Size Tcl_UtfBackslash(const char *src, int *readPtr, char *dst); /* 328 */ EXTERN const char * Tcl_UtfFindFirst(const char *src, int ch); @@ -1017,13 +1026,13 @@ EXTERN const char * TclUtfPrev(const char *src, const char *start); /* 332 */ EXTERN int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, - int srcLen, int flags, + Tcl_Size srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, - int dstLen, int *srcReadPtr, + Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 333 */ EXTERN char * Tcl_UtfToExternalDString(Tcl_Encoding encoding, - const char *src, int srcLen, + const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr); /* 334 */ EXTERN int Tcl_UtfToLower(char *src); @@ -1035,10 +1044,10 @@ EXTERN int Tcl_UtfToChar16(const char *src, /* 337 */ EXTERN int Tcl_UtfToUpper(char *src); /* 338 */ -EXTERN int Tcl_WriteChars(Tcl_Channel chan, const char *src, - int srcLen); +EXTERN Tcl_Size Tcl_WriteChars(Tcl_Channel chan, const char *src, + Tcl_Size srcLen); /* 339 */ -EXTERN int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr); +EXTERN Tcl_Size Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 340 */ EXTERN char * Tcl_GetString(Tcl_Obj *objPtr); /* 341 */ @@ -1066,7 +1075,7 @@ EXTERN int Tcl_UniCharIsUpper(int ch); /* 351 */ EXTERN int Tcl_UniCharIsWordChar(int ch); /* 352 */ -EXTERN int Tcl_Char16Len(const unsigned short *uniStr); +EXTERN Tcl_Size Tcl_Char16Len(const unsigned short *uniStr); /* 353 */ TCL_DEPRECATED("Use Tcl_UtfNcmp") int Tcl_UniCharNcmp(const unsigned short *ucs, @@ -1074,10 +1083,10 @@ int Tcl_UniCharNcmp(const unsigned short *ucs, unsigned long numChars); /* 354 */ EXTERN char * Tcl_Char16ToUtfDString(const unsigned short *uniStr, - int uniLength, Tcl_DString *dsPtr); + Tcl_Size uniLength, Tcl_DString *dsPtr); /* 355 */ -EXTERN unsigned short * Tcl_UtfToChar16DString(const char *src, int length, - Tcl_DString *dsPtr); +EXTERN unsigned short * Tcl_UtfToChar16DString(const char *src, + Tcl_Size length, Tcl_DString *dsPtr); /* 356 */ EXTERN Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags); @@ -1090,27 +1099,27 @@ EXTERN void Tcl_FreeParse(Tcl_Parse *parsePtr); /* 359 */ EXTERN void Tcl_LogCommandInfo(Tcl_Interp *interp, const char *script, const char *command, - int length); + Tcl_Size length); /* 360 */ EXTERN int Tcl_ParseBraces(Tcl_Interp *interp, - const char *start, int numBytes, + const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 361 */ EXTERN int Tcl_ParseCommand(Tcl_Interp *interp, - const char *start, int numBytes, int nested, - Tcl_Parse *parsePtr); + const char *start, Tcl_Size numBytes, + int nested, Tcl_Parse *parsePtr); /* 362 */ EXTERN int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, - int numBytes, Tcl_Parse *parsePtr); + Tcl_Size numBytes, Tcl_Parse *parsePtr); /* 363 */ EXTERN int Tcl_ParseQuotedString(Tcl_Interp *interp, - const char *start, int numBytes, + const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 364 */ EXTERN int Tcl_ParseVarName(Tcl_Interp *interp, - const char *start, int numBytes, + const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr, int append); /* 365 */ EXTERN char * Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr); @@ -1140,28 +1149,32 @@ EXTERN int Tcl_UniCharIsPunct(int ch); /* 376 */ EXTERN int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, - int offset, int nmatches, int flags); + Tcl_Size offset, Tcl_Size nmatches, + int flags); /* 377 */ EXTERN void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 378 */ EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const unsigned short *unicode, - int numChars); + Tcl_Size numChars); /* 379 */ EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, - const unsigned short *unicode, int numChars); + const unsigned short *unicode, + Tcl_Size numChars); /* 380 */ -EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr); +EXTERN Tcl_Size Tcl_GetCharLength(Tcl_Obj *objPtr); /* 381 */ -EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, int index); +EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, Tcl_Size index); /* 382 */ TCL_DEPRECATED("No longer in use, changed to macro") unsigned short * Tcl_GetUnicode(Tcl_Obj *objPtr); /* 383 */ -EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last); +EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, Tcl_Size first, + Tcl_Size last); /* 384 */ EXTERN void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, - const unsigned short *unicode, int length); + const unsigned short *unicode, + Tcl_Size length); /* 385 */ EXTERN int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); @@ -1177,7 +1190,7 @@ EXTERN int Tcl_GetChannelNamesEx(Tcl_Interp *interp, const char *pattern); /* 390 */ EXTERN int Tcl_ProcObjCmd(void *clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); + Tcl_Size objc, Tcl_Obj *const objv[]); /* 391 */ EXTERN void Tcl_ConditionFinalize(Tcl_Condition *condPtr); /* 392 */ @@ -1185,13 +1198,13 @@ EXTERN void Tcl_MutexFinalize(Tcl_Mutex *mutex); /* 393 */ EXTERN int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, - int stackSize, int flags); + Tcl_Size stackSize, int flags); /* 394 */ -EXTERN int Tcl_ReadRaw(Tcl_Channel chan, char *dst, - int bytesToRead); +EXTERN Tcl_Size Tcl_ReadRaw(Tcl_Channel chan, char *dst, + Tcl_Size bytesToRead); /* 395 */ -EXTERN int Tcl_WriteRaw(Tcl_Channel chan, const char *src, - int srcLen); +EXTERN Tcl_Size Tcl_WriteRaw(Tcl_Channel chan, const char *src, + Tcl_Size srcLen); /* 396 */ EXTERN Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan); /* 397 */ @@ -1298,7 +1311,8 @@ EXTERN char * Tcl_AttemptRealloc(char *ptr, TCL_HASH_TYPE size); EXTERN char * Tcl_AttemptDbCkrealloc(char *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 432 */ -EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length); +EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, + Tcl_Size length); /* 433 */ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel); /* 434 */ @@ -1381,7 +1395,7 @@ EXTERN int Tcl_FSChdir(Tcl_Obj *pathPtr); EXTERN int Tcl_FSConvertToPathType(Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 460 */ -EXTERN Tcl_Obj * Tcl_FSJoinPath(Tcl_Obj *listObj, int elements); +EXTERN Tcl_Obj * Tcl_FSJoinPath(Tcl_Obj *listObj, Tcl_Size elements); /* 461 */ EXTERN Tcl_Obj * Tcl_FSSplitPath(Tcl_Obj *pathPtr, int *lenPtr); /* 462 */ @@ -1391,7 +1405,7 @@ EXTERN int Tcl_FSEqualPaths(Tcl_Obj *firstPtr, EXTERN Tcl_Obj * Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 464 */ -EXTERN Tcl_Obj * Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc, +EXTERN Tcl_Obj * Tcl_FSJoinToPath(Tcl_Obj *pathPtr, Tcl_Size objc, Tcl_Obj *const objv[]); /* 465 */ EXTERN void * Tcl_FSGetInternalRep(Tcl_Obj *pathPtr, @@ -1433,7 +1447,7 @@ EXTERN int Tcl_OutputBuffered(Tcl_Channel chan); EXTERN void Tcl_FSMountsChanged(const Tcl_Filesystem *fsPtr); /* 481 */ EXTERN int Tcl_EvalTokensStandard(Tcl_Interp *interp, - Tcl_Token *tokenPtr, int count); + Tcl_Token *tokenPtr, Tcl_Size count); /* 482 */ EXTERN void Tcl_GetTime(Tcl_Time *timeBuf); /* 483 */ @@ -1493,11 +1507,11 @@ EXTERN void Tcl_DictObjNext(Tcl_DictSearch *searchPtr, EXTERN void Tcl_DictObjDone(Tcl_DictSearch *searchPtr); /* 501 */ EXTERN int Tcl_DictObjPutKeyList(Tcl_Interp *interp, - Tcl_Obj *dictPtr, int keyc, + Tcl_Obj *dictPtr, Tcl_Size keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr); /* 502 */ EXTERN int Tcl_DictObjRemoveKeyList(Tcl_Interp *interp, - Tcl_Obj *dictPtr, int keyc, + Tcl_Obj *dictPtr, Tcl_Size keyc, Tcl_Obj *const *keyv); /* 503 */ EXTERN Tcl_Obj * Tcl_NewDictObj(void); @@ -1565,7 +1579,7 @@ EXTERN int Tcl_LimitCheck(Tcl_Interp *interp); EXTERN int Tcl_LimitExceeded(Tcl_Interp *interp); /* 525 */ EXTERN void Tcl_LimitSetCommands(Tcl_Interp *interp, - int commandLimit); + Tcl_Size commandLimit); /* 526 */ EXTERN void Tcl_LimitSetTime(Tcl_Interp *interp, Tcl_Time *timeLimitPtr); @@ -1697,22 +1711,22 @@ EXTERN const char * Tcl_GetEncodingNameFromEnvironment( Tcl_DString *bufPtr); /* 573 */ EXTERN int Tcl_PkgRequireProc(Tcl_Interp *interp, - const char *name, int objc, + const char *name, Tcl_Size objc, Tcl_Obj *const objv[], void *clientDataPtr); /* 574 */ EXTERN void Tcl_AppendObjToErrorInfo(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 575 */ EXTERN void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, - const char *bytes, int length, int limit, - const char *ellipsis); + const char *bytes, Tcl_Size length, + Tcl_Size limit, const char *ellipsis); /* 576 */ EXTERN Tcl_Obj * Tcl_Format(Tcl_Interp *interp, const char *format, - int objc, Tcl_Obj *const objv[]); + Tcl_Size objc, Tcl_Obj *const objv[]); /* 577 */ EXTERN int Tcl_AppendFormatToObj(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, - int objc, Tcl_Obj *const objv[]); + Tcl_Size objc, Tcl_Obj *const objv[]); /* 578 */ EXTERN Tcl_Obj * Tcl_ObjPrintf(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 579 */ @@ -1737,11 +1751,12 @@ EXTERN Tcl_Command Tcl_NRCreateCommand(Tcl_Interp *interp, EXTERN int Tcl_NREvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 585 */ -EXTERN int Tcl_NREvalObjv(Tcl_Interp *interp, int objc, +EXTERN int Tcl_NREvalObjv(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags); /* 586 */ EXTERN int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, - int objc, Tcl_Obj *const objv[], int flags); + Tcl_Size objc, Tcl_Obj *const objv[], + int flags); /* 587 */ EXTERN void Tcl_NRAddCallback(Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr, void *data0, @@ -1749,7 +1764,7 @@ EXTERN void Tcl_NRAddCallback(Tcl_Interp *interp, /* 588 */ EXTERN int Tcl_NRCallObjProc(Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, void *clientData, - int objc, Tcl_Obj *const objv[]); + Tcl_Size objc, Tcl_Obj *const objv[]); /* 589 */ EXTERN unsigned Tcl_GetFSDeviceFromStat(const Tcl_StatBuf *statPtr); /* 590 */ @@ -1804,14 +1819,14 @@ EXTERN int Tcl_ZlibDeflate(Tcl_Interp *interp, int format, Tcl_Obj *gzipHeaderDictObj); /* 611 */ EXTERN int Tcl_ZlibInflate(Tcl_Interp *interp, int format, - Tcl_Obj *data, int buffersize, + Tcl_Obj *data, Tcl_Size buffersize, Tcl_Obj *gzipHeaderDictObj); /* 612 */ EXTERN unsigned int Tcl_ZlibCRC32(unsigned int crc, - const unsigned char *buf, int len); + const unsigned char *buf, Tcl_Size len); /* 613 */ EXTERN unsigned int Tcl_ZlibAdler32(unsigned int adler, - const unsigned char *buf, int len); + const unsigned char *buf, Tcl_Size len); /* 614 */ EXTERN int Tcl_ZlibStreamInit(Tcl_Interp *interp, int mode, int format, int level, Tcl_Obj *dictObj, @@ -1827,7 +1842,7 @@ EXTERN int Tcl_ZlibStreamPut(Tcl_ZlibStream zshandle, Tcl_Obj *data, int flush); /* 619 */ EXTERN int Tcl_ZlibStreamGet(Tcl_ZlibStream zshandle, - Tcl_Obj *data, int count); + Tcl_Obj *data, Tcl_Size count); /* 620 */ EXTERN int Tcl_ZlibStreamClose(Tcl_ZlibStream zshandle); /* 621 */ @@ -1902,18 +1917,19 @@ EXTERN int Tcl_IsShared(Tcl_Obj *objPtr); /* 644 */ EXTERN int Tcl_LinkArray(Tcl_Interp *interp, const char *varName, void *addr, int type, - int size); + Tcl_Size size); /* 645 */ EXTERN int Tcl_GetIntForIndex(Tcl_Interp *interp, - Tcl_Obj *objPtr, int endValue, int *indexPtr); + Tcl_Obj *objPtr, Tcl_Size endValue, + Tcl_Size *indexPtr); /* 646 */ EXTERN int Tcl_UtfToUniChar(const char *src, int *chPtr); /* 647 */ EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr, - int uniLength, Tcl_DString *dsPtr); + Tcl_Size uniLength, Tcl_DString *dsPtr); /* 648 */ -EXTERN int * Tcl_UtfToUniCharDString(const char *src, int length, - Tcl_DString *dsPtr); +EXTERN int * Tcl_UtfToUniCharDString(const char *src, + Tcl_Size length, Tcl_DString *dsPtr); /* 649 */ EXTERN unsigned char * TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *numBytesPtr); @@ -1930,7 +1946,7 @@ EXTERN unsigned short * TclGetUnicodeFromObj(Tcl_Obj *objPtr, EXTERN unsigned char * TclGetByteArrayFromObj(Tcl_Obj *objPtr, size_t *numBytesPtr); /* 654 */ -EXTERN int Tcl_UtfCharComplete(const char *src, int length); +EXTERN int Tcl_UtfCharComplete(const char *src, Tcl_Size length); /* 655 */ EXTERN const char * Tcl_UtfNext(const char *src); /* 656 */ @@ -1938,12 +1954,12 @@ EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); /* 657 */ EXTERN int Tcl_UniCharIsUnicode(int ch); /* 658 */ -EXTERN int Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, - const char *src, int srcLen, int flags, +EXTERN Tcl_Size Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, + const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr); /* 659 */ -EXTERN int Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, - const char *src, int srcLen, int flags, +EXTERN Tcl_Size Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, + const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr); /* 660 */ EXTERN int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, @@ -1972,17 +1988,18 @@ EXTERN int TclParseArgsObjv(Tcl_Interp *interp, size_t *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 668 */ -EXTERN int Tcl_UniCharLen(const int *uniStr); +EXTERN Tcl_Size Tcl_UniCharLen(const int *uniStr); /* 669 */ -EXTERN int TclNumUtfChars(const char *src, int length); +EXTERN Tcl_Size TclNumUtfChars(const char *src, Tcl_Size length); /* 670 */ -EXTERN int TclGetCharLength(Tcl_Obj *objPtr); +EXTERN Tcl_Size TclGetCharLength(Tcl_Obj *objPtr); /* 671 */ -EXTERN const char * TclUtfAtIndex(const char *src, int index); +EXTERN const char * TclUtfAtIndex(const char *src, Tcl_Size index); /* 672 */ -EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, int first, int last); +EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, Tcl_Size first, + Tcl_Size last); /* 673 */ -EXTERN int TclGetUniChar(Tcl_Obj *objPtr, int index); +EXTERN int TclGetUniChar(Tcl_Obj *objPtr, Tcl_Size index); /* 674 */ EXTERN int Tcl_GetBool(Tcl_Interp *interp, const char *src, int flags, char *charPtr); @@ -2062,19 +2079,19 @@ typedef struct TclStubs { int (*tcl_WaitForEvent) (const Tcl_Time *timePtr); /* 13 */ int (*tcl_AppendAllObjTypes) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 14 */ void (*tcl_AppendStringsToObj) (Tcl_Obj *objPtr, ...); /* 15 */ - void (*tcl_AppendToObj) (Tcl_Obj *objPtr, const char *bytes, int length); /* 16 */ - Tcl_Obj * (*tcl_ConcatObj) (int objc, Tcl_Obj *const objv[]); /* 17 */ + void (*tcl_AppendToObj) (Tcl_Obj *objPtr, const char *bytes, Tcl_Size length); /* 16 */ + Tcl_Obj * (*tcl_ConcatObj) (Tcl_Size objc, Tcl_Obj *const objv[]); /* 17 */ int (*tcl_ConvertToType) (Tcl_Interp *interp, Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 18 */ void (*tcl_DbDecrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 19 */ void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 20 */ int (*tcl_DbIsShared) (Tcl_Obj *objPtr, const char *file, int line); /* 21 */ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewBooleanObj) (int intValue, const char *file, int line); /* 22 */ - Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, int numBytes, const char *file, int line); /* 23 */ + Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, Tcl_Size numBytes, const char *file, int line); /* 23 */ Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */ - Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */ + Tcl_Obj * (*tcl_DbNewListObj) (Tcl_Size objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewLongObj) (long longValue, const char *file, int line); /* 26 */ Tcl_Obj * (*tcl_DbNewObj) (const char *file, int line); /* 27 */ - Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, int length, const char *file, int line); /* 28 */ + Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, Tcl_Size length, const char *file, int line); /* 28 */ Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */ void (*tclFreeObj) (Tcl_Obj *objPtr); /* 30 */ int (*tcl_GetBoolean) (Tcl_Interp *interp, const char *src, int *intPtr); /* 31 */ @@ -2092,26 +2109,26 @@ typedef struct TclStubs { int (*tcl_ListObjAppendList) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *elemListPtr); /* 43 */ int (*tcl_ListObjAppendElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *objPtr); /* 44 */ int (*tcl_ListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 45 */ - int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj **objPtrPtr); /* 46 */ + int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj **objPtrPtr); /* 46 */ int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */ - int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 48 */ + int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size first, Tcl_Size count, Tcl_Size objc, Tcl_Obj *const objv[]); /* 48 */ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewBooleanObj) (int intValue); /* 49 */ - Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, int numBytes); /* 50 */ + Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, Tcl_Size numBytes); /* 50 */ Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */ - Tcl_Obj * (*tcl_NewListObj) (int objc, Tcl_Obj *const objv[]); /* 53 */ + Tcl_Obj * (*tcl_NewListObj) (Tcl_Size objc, Tcl_Obj *const objv[]); /* 53 */ TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */ Tcl_Obj * (*tcl_NewObj) (void); /* 55 */ - Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, int length); /* 56 */ + Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, Tcl_Size length); /* 56 */ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int intValue); /* 57 */ - unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, int numBytes); /* 58 */ - void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, int numBytes); /* 59 */ + unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, Tcl_Size numBytes); /* 58 */ + void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, Tcl_Size numBytes); /* 59 */ void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */ - void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 62 */ + void (*tcl_SetListObj) (Tcl_Obj *objPtr, Tcl_Size objc, Tcl_Obj *const objv[]); /* 62 */ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */ - void (*tcl_SetObjLength) (Tcl_Obj *objPtr, int length); /* 64 */ - void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, int length); /* 65 */ + void (*tcl_SetObjLength) (Tcl_Obj *objPtr, Tcl_Size length); /* 64 */ + void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, Tcl_Size length); /* 65 */ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_AddErrorInfo) (Tcl_Interp *interp, const char *message); /* 66 */ TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_AddObjErrorInfo) (Tcl_Interp *interp, const char *message, int length); /* 67 */ void (*tcl_AllowExceptions) (Tcl_Interp *interp); /* 68 */ @@ -2129,11 +2146,11 @@ typedef struct TclStubs { void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, void *clientData); /* 80 */ int (*tcl_Close) (Tcl_Interp *interp, Tcl_Channel chan); /* 81 */ int (*tcl_CommandComplete) (const char *cmd); /* 82 */ - char * (*tcl_Concat) (int argc, const char *const *argv); /* 83 */ - int (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */ - int (*tcl_ConvertCountedElement) (const char *src, int length, char *dst, int flags); /* 85 */ - int (*tcl_CreateAlias) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 86 */ - int (*tcl_CreateAliasObj) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */ + char * (*tcl_Concat) (Tcl_Size argc, const char *const *argv); /* 83 */ + Tcl_Size (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */ + Tcl_Size (*tcl_ConvertCountedElement) (const char *src, Tcl_Size length, char *dst, int flags); /* 85 */ + int (*tcl_CreateAlias) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, Tcl_Size argc, const char *const *argv); /* 86 */ + int (*tcl_CreateAliasObj) (Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, Tcl_Size objc, Tcl_Obj *const objv[]); /* 87 */ Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, void *instanceData, int mask); /* 88 */ void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, void *clientData); /* 89 */ void (*tcl_CreateCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, void *clientData); /* 90 */ @@ -2157,20 +2174,20 @@ typedef struct TclStubs { void (*tcl_DeleteHashEntry) (Tcl_HashEntry *entryPtr); /* 108 */ void (*tcl_DeleteHashTable) (Tcl_HashTable *tablePtr); /* 109 */ void (*tcl_DeleteInterp) (Tcl_Interp *interp); /* 110 */ - void (*tcl_DetachPids) (int numPids, Tcl_Pid *pidPtr); /* 111 */ + void (*tcl_DetachPids) (Tcl_Size numPids, Tcl_Pid *pidPtr); /* 111 */ void (*tcl_DeleteTimerHandler) (Tcl_TimerToken token); /* 112 */ void (*tcl_DeleteTrace) (Tcl_Interp *interp, Tcl_Trace trace); /* 113 */ void (*tcl_DontCallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, void *clientData); /* 114 */ int (*tcl_DoOneEvent) (int flags); /* 115 */ void (*tcl_DoWhenIdle) (Tcl_IdleProc *proc, void *clientData); /* 116 */ - char * (*tcl_DStringAppend) (Tcl_DString *dsPtr, const char *bytes, int length); /* 117 */ + char * (*tcl_DStringAppend) (Tcl_DString *dsPtr, const char *bytes, Tcl_Size length); /* 117 */ char * (*tcl_DStringAppendElement) (Tcl_DString *dsPtr, const char *element); /* 118 */ void (*tcl_DStringEndSublist) (Tcl_DString *dsPtr); /* 119 */ void (*tcl_DStringFree) (Tcl_DString *dsPtr); /* 120 */ void (*tcl_DStringGetResult) (Tcl_Interp *interp, Tcl_DString *dsPtr); /* 121 */ void (*tcl_DStringInit) (Tcl_DString *dsPtr); /* 122 */ void (*tcl_DStringResult) (Tcl_Interp *interp, Tcl_DString *dsPtr); /* 123 */ - void (*tcl_DStringSetLength) (Tcl_DString *dsPtr, int length); /* 124 */ + void (*tcl_DStringSetLength) (Tcl_DString *dsPtr, Tcl_Size length); /* 124 */ void (*tcl_DStringStartSublist) (Tcl_DString *dsPtr); /* 125 */ int (*tcl_Eof) (Tcl_Channel chan); /* 126 */ const char * (*tcl_ErrnoId) (void); /* 127 */ @@ -2198,7 +2215,7 @@ typedef struct TclStubs { int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ void * (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */ Tcl_Channel (*tcl_GetChannel) (Tcl_Interp *interp, const char *chanName, int *modePtr); /* 151 */ - int (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */ + Tcl_Size (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */ int (*tcl_GetChannelHandle) (Tcl_Channel chan, int direction, void **handlePtr); /* 153 */ void * (*tcl_GetChannelInstanceData) (Tcl_Channel chan); /* 154 */ int (*tcl_GetChannelMode) (Tcl_Channel chan); /* 155 */ @@ -2223,8 +2240,8 @@ typedef struct TclStubs { int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr); /* 167 */ #endif /* MACOSX */ Tcl_PathType (*tcl_GetPathType) (const char *path); /* 168 */ - int (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */ - int (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */ + Tcl_Size (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */ + Tcl_Size (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */ int (*tcl_GetServiceMode) (void); /* 171 */ Tcl_Interp * (*tcl_GetChild) (Tcl_Interp *interp, const char *name); /* 172 */ Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */ @@ -2240,18 +2257,18 @@ typedef struct TclStubs { int (*tcl_InputBuffered) (Tcl_Channel chan); /* 183 */ int (*tcl_InterpDeleted) (Tcl_Interp *interp); /* 184 */ int (*tcl_IsSafe) (Tcl_Interp *interp); /* 185 */ - char * (*tcl_JoinPath) (int argc, const char *const *argv, Tcl_DString *resultPtr); /* 186 */ + char * (*tcl_JoinPath) (Tcl_Size argc, const char *const *argv, Tcl_DString *resultPtr); /* 186 */ int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, void *addr, int type); /* 187 */ void (*reserved188)(void); Tcl_Channel (*tcl_MakeFileChannel) (void *handle, int mode); /* 189 */ TCL_DEPRECATED_API("") int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */ Tcl_Channel (*tcl_MakeTcpClientChannel) (void *tcpSocket); /* 191 */ - char * (*tcl_Merge) (int argc, const char *const *argv); /* 192 */ + char * (*tcl_Merge) (Tcl_Size argc, const char *const *argv); /* 192 */ Tcl_HashEntry * (*tcl_NextHashEntry) (Tcl_HashSearch *searchPtr); /* 193 */ void (*tcl_NotifyChannel) (Tcl_Channel channel, int mask); /* 194 */ Tcl_Obj * (*tcl_ObjGetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 195 */ Tcl_Obj * (*tcl_ObjSetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 196 */ - Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, int argc, const char **argv, int flags); /* 197 */ + Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, Tcl_Size argc, const char **argv, int flags); /* 197 */ Tcl_Channel (*tcl_OpenFileChannel) (Tcl_Interp *interp, const char *fileName, const char *modeString, int permissions); /* 198 */ Tcl_Channel (*tcl_OpenTcpClient) (Tcl_Interp *interp, int port, const char *address, const char *myaddr, int myport, int async); /* 199 */ Tcl_Channel (*tcl_OpenTcpServer) (Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, void *callbackData); /* 200 */ @@ -2260,7 +2277,7 @@ typedef struct TclStubs { int (*tcl_PutEnv) (const char *assignment); /* 203 */ const char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */ void (*tcl_QueueEvent) (Tcl_Event *evPtr, int position); /* 205 */ - int (*tcl_Read) (Tcl_Channel chan, char *bufPtr, int toRead); /* 206 */ + Tcl_Size (*tcl_Read) (Tcl_Channel chan, char *bufPtr, Tcl_Size toRead); /* 206 */ void (*tcl_ReapDetachedProcs) (void); /* 207 */ int (*tcl_RecordAndEval) (Tcl_Interp *interp, const char *cmd, int flags); /* 208 */ int (*tcl_RecordAndEvalObj) (Tcl_Interp *interp, Tcl_Obj *cmdPtr, int flags); /* 209 */ @@ -2269,23 +2286,23 @@ typedef struct TclStubs { Tcl_RegExp (*tcl_RegExpCompile) (Tcl_Interp *interp, const char *pattern); /* 212 */ int (*tcl_RegExpExec) (Tcl_Interp *interp, Tcl_RegExp regexp, const char *text, const char *start); /* 213 */ int (*tcl_RegExpMatch) (Tcl_Interp *interp, const char *text, const char *pattern); /* 214 */ - void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, const char **startPtr, const char **endPtr); /* 215 */ + void (*tcl_RegExpRange) (Tcl_RegExp regexp, Tcl_Size index, const char **startPtr, const char **endPtr); /* 215 */ void (*tcl_Release) (void *clientData); /* 216 */ void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */ - int (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */ - int (*tcl_ScanCountedElement) (const char *src, int length, int *flagPtr); /* 219 */ + Tcl_Size (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */ + Tcl_Size (*tcl_ScanCountedElement) (const char *src, Tcl_Size length, int *flagPtr); /* 219 */ TCL_DEPRECATED_API("") int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */ int (*tcl_ServiceAll) (void); /* 221 */ int (*tcl_ServiceEvent) (int flags); /* 222 */ void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, void *clientData); /* 223 */ - void (*tcl_SetChannelBufferSize) (Tcl_Channel chan, int sz); /* 224 */ + void (*tcl_SetChannelBufferSize) (Tcl_Channel chan, Tcl_Size sz); /* 224 */ int (*tcl_SetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, const char *newValue); /* 225 */ int (*tcl_SetCommandInfo) (Tcl_Interp *interp, const char *cmdName, const Tcl_CmdInfo *infoPtr); /* 226 */ void (*tcl_SetErrno) (int err); /* 227 */ void (*tcl_SetErrorCode) (Tcl_Interp *interp, ...); /* 228 */ void (*tcl_SetMaxBlockTime) (const Tcl_Time *timePtr); /* 229 */ TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") const char * (*tcl_SetPanicProc) (TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 230 */ - int (*tcl_SetRecursionLimit) (Tcl_Interp *interp, int depth); /* 231 */ + Tcl_Size (*tcl_SetRecursionLimit) (Tcl_Interp *interp, Tcl_Size depth); /* 231 */ void (*tcl_SetResult) (Tcl_Interp *interp, char *result, Tcl_FreeProc *freeProc); /* 232 */ int (*tcl_SetServiceMode) (int mode); /* 233 */ void (*tcl_SetObjErrorCode) (Tcl_Interp *interp, Tcl_Obj *errorObjPtr); /* 234 */ @@ -2304,7 +2321,7 @@ typedef struct TclStubs { TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 247 */ int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 248 */ char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */ - int (*tcl_Ungets) (Tcl_Channel chan, const char *str, int len, int atHead); /* 250 */ + Tcl_Size (*tcl_Ungets) (Tcl_Channel chan, const char *str, Tcl_Size len, int atHead); /* 250 */ void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */ int (*tcl_UnregisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 252 */ TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */ @@ -2317,8 +2334,8 @@ typedef struct TclStubs { int (*tcl_VarEval) (Tcl_Interp *interp, ...); /* 260 */ TCL_DEPRECATED_API("No longer in use, changed to macro") void * (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 261 */ void * (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 262 */ - int (*tcl_Write) (Tcl_Channel chan, const char *s, int slen); /* 263 */ - void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */ + Tcl_Size (*tcl_Write) (Tcl_Channel chan, const char *s, Tcl_Size slen); /* 263 */ + void (*tcl_WrongNumArgs) (Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], const char *message); /* 264 */ int (*tcl_DumpActiveMemory) (const char *fileName); /* 265 */ void (*tcl_ValidateAllMemory) (const char *file, int line); /* 266 */ TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */ @@ -2345,12 +2362,12 @@ typedef struct TclStubs { void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 288 */ void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 289 */ TCL_DEPRECATED_API("Use Tcl_DiscardInterpState") void (*tcl_DiscardResult) (Tcl_SavedResult *statePtr); /* 290 */ - int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, int numBytes, int flags); /* 291 */ - int (*tcl_EvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 292 */ + int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, Tcl_Size numBytes, int flags); /* 291 */ + int (*tcl_EvalObjv) (Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags); /* 292 */ int (*tcl_EvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 293 */ TCL_NORETURN1 void (*tcl_ExitThread) (int status); /* 294 */ - int (*tcl_ExternalToUtf) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */ - char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 296 */ + int (*tcl_ExternalToUtf) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */ + char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr); /* 296 */ void (*tcl_FinalizeThread) (void); /* 297 */ void (*tcl_FinalizeNotifier) (void *clientData); /* 298 */ void (*tcl_FreeEncoding) (Tcl_Encoding encoding); /* 299 */ @@ -2358,42 +2375,42 @@ typedef struct TclStubs { Tcl_Encoding (*tcl_GetEncoding) (Tcl_Interp *interp, const char *name); /* 301 */ const char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */ void (*tcl_GetEncodingNames) (Tcl_Interp *interp); /* 303 */ - int (*tcl_GetIndexFromObjStruct) (Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, int offset, const char *msg, int flags, void *indexPtr); /* 304 */ - void * (*tcl_GetThreadData) (Tcl_ThreadDataKey *keyPtr, int size); /* 305 */ + int (*tcl_GetIndexFromObjStruct) (Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, Tcl_Size offset, const char *msg, int flags, void *indexPtr); /* 304 */ + void * (*tcl_GetThreadData) (Tcl_ThreadDataKey *keyPtr, Tcl_Size size); /* 305 */ Tcl_Obj * (*tcl_GetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 306 */ void * (*tcl_InitNotifier) (void); /* 307 */ void (*tcl_MutexLock) (Tcl_Mutex *mutexPtr); /* 308 */ void (*tcl_MutexUnlock) (Tcl_Mutex *mutexPtr); /* 309 */ void (*tcl_ConditionNotify) (Tcl_Condition *condPtr); /* 310 */ void (*tcl_ConditionWait) (Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 311 */ - int (*tcl_NumUtfChars) (const char *src, int length); /* 312 */ - int (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, int appendFlag); /* 313 */ + Tcl_Size (*tcl_NumUtfChars) (const char *src, Tcl_Size length); /* 312 */ + Tcl_Size (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, Tcl_Size charsToRead, int appendFlag); /* 313 */ TCL_DEPRECATED_API("Use Tcl_RestoreInterpState") void (*tcl_RestoreResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 314 */ TCL_DEPRECATED_API("Use Tcl_SaveInterpState") void (*tcl_SaveResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 315 */ int (*tcl_SetSystemEncoding) (Tcl_Interp *interp, const char *name); /* 316 */ Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */ void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */ void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, int position); /* 319 */ - int (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */ + int (*tcl_UniCharAtIndex) (const char *src, Tcl_Size index); /* 320 */ int (*tcl_UniCharToLower) (int ch); /* 321 */ int (*tcl_UniCharToTitle) (int ch); /* 322 */ int (*tcl_UniCharToUpper) (int ch); /* 323 */ int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */ - const char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */ - int (*tclUtfCharComplete) (const char *src, int length); /* 326 */ - int (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */ + const char * (*tcl_UtfAtIndex) (const char *src, Tcl_Size index); /* 325 */ + int (*tclUtfCharComplete) (const char *src, Tcl_Size length); /* 326 */ + Tcl_Size (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */ const char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */ const char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */ const char * (*tclUtfNext) (const char *src); /* 330 */ const char * (*tclUtfPrev) (const char *src, const char *start); /* 331 */ - int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */ - char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 333 */ + int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */ + char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr); /* 333 */ int (*tcl_UtfToLower) (char *src); /* 334 */ int (*tcl_UtfToTitle) (char *src); /* 335 */ int (*tcl_UtfToChar16) (const char *src, unsigned short *chPtr); /* 336 */ int (*tcl_UtfToUpper) (char *src); /* 337 */ - int (*tcl_WriteChars) (Tcl_Channel chan, const char *src, int srcLen); /* 338 */ - int (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */ + Tcl_Size (*tcl_WriteChars) (Tcl_Channel chan, const char *src, Tcl_Size srcLen); /* 338 */ + Tcl_Size (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */ char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */ TCL_DEPRECATED_API("Use Tcl_GetEncodingSearchPath") const char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */ TCL_DEPRECATED_API("Use Tcl_SetEncodingSearchPath") void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */ @@ -2406,19 +2423,19 @@ typedef struct TclStubs { int (*tcl_UniCharIsSpace) (int ch); /* 349 */ int (*tcl_UniCharIsUpper) (int ch); /* 350 */ int (*tcl_UniCharIsWordChar) (int ch); /* 351 */ - int (*tcl_Char16Len) (const unsigned short *uniStr); /* 352 */ + Tcl_Size (*tcl_Char16Len) (const unsigned short *uniStr); /* 352 */ TCL_DEPRECATED_API("Use Tcl_UtfNcmp") int (*tcl_UniCharNcmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 353 */ - char * (*tcl_Char16ToUtfDString) (const unsigned short *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */ - unsigned short * (*tcl_UtfToChar16DString) (const char *src, int length, Tcl_DString *dsPtr); /* 355 */ + char * (*tcl_Char16ToUtfDString) (const unsigned short *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr); /* 354 */ + unsigned short * (*tcl_UtfToChar16DString) (const char *src, Tcl_Size length, Tcl_DString *dsPtr); /* 355 */ Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */ TCL_DEPRECATED_API("Use Tcl_EvalTokensStandard") Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 357 */ void (*tcl_FreeParse) (Tcl_Parse *parsePtr); /* 358 */ - void (*tcl_LogCommandInfo) (Tcl_Interp *interp, const char *script, const char *command, int length); /* 359 */ - int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 360 */ - int (*tcl_ParseCommand) (Tcl_Interp *interp, const char *start, int numBytes, int nested, Tcl_Parse *parsePtr); /* 361 */ - int (*tcl_ParseExpr) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr); /* 362 */ - int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 363 */ - int (*tcl_ParseVarName) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append); /* 364 */ + void (*tcl_LogCommandInfo) (Tcl_Interp *interp, const char *script, const char *command, Tcl_Size length); /* 359 */ + int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 360 */ + int (*tcl_ParseCommand) (Tcl_Interp *interp, const char *start, Tcl_Size numBytes, int nested, Tcl_Parse *parsePtr); /* 361 */ + int (*tcl_ParseExpr) (Tcl_Interp *interp, const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr); /* 362 */ + int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 363 */ + int (*tcl_ParseVarName) (Tcl_Interp *interp, const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr, int append); /* 364 */ char * (*tcl_GetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 365 */ int (*tcl_Chdir) (const char *dirName); /* 366 */ int (*tcl_Access) (const char *path, int mode); /* 367 */ @@ -2430,26 +2447,26 @@ typedef struct TclStubs { int (*tcl_UniCharIsGraph) (int ch); /* 373 */ int (*tcl_UniCharIsPrint) (int ch); /* 374 */ int (*tcl_UniCharIsPunct) (int ch); /* 375 */ - int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, int offset, int nmatches, int flags); /* 376 */ + int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, Tcl_Size offset, Tcl_Size nmatches, int flags); /* 376 */ void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */ - Tcl_Obj * (*tcl_NewUnicodeObj) (const unsigned short *unicode, int numChars); /* 378 */ - void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const unsigned short *unicode, int numChars); /* 379 */ - int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ - int (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */ + Tcl_Obj * (*tcl_NewUnicodeObj) (const unsigned short *unicode, Tcl_Size numChars); /* 378 */ + void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const unsigned short *unicode, Tcl_Size numChars); /* 379 */ + Tcl_Size (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ + int (*tcl_GetUniChar) (Tcl_Obj *objPtr, Tcl_Size index); /* 381 */ TCL_DEPRECATED_API("No longer in use, changed to macro") unsigned short * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ - Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */ - void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const unsigned short *unicode, int length); /* 384 */ + Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 383 */ + void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const unsigned short *unicode, Tcl_Size length); /* 384 */ int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ void (*tcl_SetNotifier) (const Tcl_NotifierProcs *notifierProcPtr); /* 386 */ Tcl_Mutex * (*tcl_GetAllocMutex) (void); /* 387 */ int (*tcl_GetChannelNames) (Tcl_Interp *interp); /* 388 */ int (*tcl_GetChannelNamesEx) (Tcl_Interp *interp, const char *pattern); /* 389 */ - int (*tcl_ProcObjCmd) (void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 390 */ + int (*tcl_ProcObjCmd) (void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]); /* 390 */ void (*tcl_ConditionFinalize) (Tcl_Condition *condPtr); /* 391 */ void (*tcl_MutexFinalize) (Tcl_Mutex *mutex); /* 392 */ - int (*tcl_CreateThread) (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, int stackSize, int flags); /* 393 */ - int (*tcl_ReadRaw) (Tcl_Channel chan, char *dst, int bytesToRead); /* 394 */ - int (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, int srcLen); /* 395 */ + int (*tcl_CreateThread) (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, Tcl_Size stackSize, int flags); /* 393 */ + Tcl_Size (*tcl_ReadRaw) (Tcl_Channel chan, char *dst, Tcl_Size bytesToRead); /* 394 */ + Tcl_Size (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, Tcl_Size srcLen); /* 395 */ Tcl_Channel (*tcl_GetTopChannel) (Tcl_Channel chan); /* 396 */ int (*tcl_ChannelBuffered) (Tcl_Channel chan); /* 397 */ const char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */ @@ -2486,7 +2503,7 @@ typedef struct TclStubs { char * (*tcl_AttemptDbCkalloc) (TCL_HASH_TYPE size, const char *file, int line); /* 429 */ char * (*tcl_AttemptRealloc) (char *ptr, TCL_HASH_TYPE size); /* 430 */ char * (*tcl_AttemptDbCkrealloc) (char *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 431 */ - int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, int length); /* 432 */ + int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, Tcl_Size length); /* 432 */ Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */ unsigned short * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */ TCL_DEPRECATED_API("") int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, void **clientDataPtr); /* 435 */ @@ -2514,11 +2531,11 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_FSGetCwd) (Tcl_Interp *interp); /* 457 */ int (*tcl_FSChdir) (Tcl_Obj *pathPtr); /* 458 */ int (*tcl_FSConvertToPathType) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 459 */ - Tcl_Obj * (*tcl_FSJoinPath) (Tcl_Obj *listObj, int elements); /* 460 */ + Tcl_Obj * (*tcl_FSJoinPath) (Tcl_Obj *listObj, Tcl_Size elements); /* 460 */ Tcl_Obj * (*tcl_FSSplitPath) (Tcl_Obj *pathPtr, int *lenPtr); /* 461 */ int (*tcl_FSEqualPaths) (Tcl_Obj *firstPtr, Tcl_Obj *secondPtr); /* 462 */ Tcl_Obj * (*tcl_FSGetNormalizedPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 463 */ - Tcl_Obj * (*tcl_FSJoinToPath) (Tcl_Obj *pathPtr, int objc, Tcl_Obj *const objv[]); /* 464 */ + Tcl_Obj * (*tcl_FSJoinToPath) (Tcl_Obj *pathPtr, Tcl_Size objc, Tcl_Obj *const objv[]); /* 464 */ void * (*tcl_FSGetInternalRep) (Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr); /* 465 */ Tcl_Obj * (*tcl_FSGetTranslatedPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 466 */ int (*tcl_FSEvalFile) (Tcl_Interp *interp, Tcl_Obj *fileName); /* 467 */ @@ -2535,7 +2552,7 @@ typedef struct TclStubs { Tcl_PathType (*tcl_FSGetPathType) (Tcl_Obj *pathPtr); /* 478 */ int (*tcl_OutputBuffered) (Tcl_Channel chan); /* 479 */ void (*tcl_FSMountsChanged) (const Tcl_Filesystem *fsPtr); /* 480 */ - int (*tcl_EvalTokensStandard) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 481 */ + int (*tcl_EvalTokensStandard) (Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Size count); /* 481 */ void (*tcl_GetTime) (Tcl_Time *timeBuf); /* 482 */ Tcl_Trace (*tcl_CreateObjTrace) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 483 */ int (*tcl_GetCommandInfoFromToken) (Tcl_Command token, Tcl_CmdInfo *infoPtr); /* 484 */ @@ -2555,8 +2572,8 @@ typedef struct TclStubs { int (*tcl_DictObjFirst) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); /* 498 */ void (*tcl_DictObjNext) (Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); /* 499 */ void (*tcl_DictObjDone) (Tcl_DictSearch *searchPtr); /* 500 */ - int (*tcl_DictObjPutKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr); /* 501 */ - int (*tcl_DictObjRemoveKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, Tcl_Obj *const *keyv); /* 502 */ + int (*tcl_DictObjPutKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Size keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr); /* 501 */ + int (*tcl_DictObjRemoveKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Size keyc, Tcl_Obj *const *keyv); /* 502 */ Tcl_Obj * (*tcl_NewDictObj) (void); /* 503 */ Tcl_Obj * (*tcl_DbNewDictObj) (const char *file, int line); /* 504 */ void (*tcl_RegisterConfig) (Tcl_Interp *interp, const char *pkgName, const Tcl_Config *configuration, const char *valEncoding); /* 505 */ @@ -2579,7 +2596,7 @@ typedef struct TclStubs { int (*tcl_LimitReady) (Tcl_Interp *interp); /* 522 */ int (*tcl_LimitCheck) (Tcl_Interp *interp); /* 523 */ int (*tcl_LimitExceeded) (Tcl_Interp *interp); /* 524 */ - void (*tcl_LimitSetCommands) (Tcl_Interp *interp, int commandLimit); /* 525 */ + void (*tcl_LimitSetCommands) (Tcl_Interp *interp, Tcl_Size commandLimit); /* 525 */ void (*tcl_LimitSetTime) (Tcl_Interp *interp, Tcl_Time *timeLimitPtr); /* 526 */ void (*tcl_LimitSetGranularity) (Tcl_Interp *interp, int type, int granularity); /* 527 */ int (*tcl_LimitTypeEnabled) (Tcl_Interp *interp, int type); /* 528 */ @@ -2627,11 +2644,11 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_GetEncodingSearchPath) (void); /* 570 */ int (*tcl_SetEncodingSearchPath) (Tcl_Obj *searchPath); /* 571 */ const char * (*tcl_GetEncodingNameFromEnvironment) (Tcl_DString *bufPtr); /* 572 */ - int (*tcl_PkgRequireProc) (Tcl_Interp *interp, const char *name, int objc, Tcl_Obj *const objv[], void *clientDataPtr); /* 573 */ + int (*tcl_PkgRequireProc) (Tcl_Interp *interp, const char *name, Tcl_Size objc, Tcl_Obj *const objv[], void *clientDataPtr); /* 573 */ void (*tcl_AppendObjToErrorInfo) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 574 */ - void (*tcl_AppendLimitedToObj) (Tcl_Obj *objPtr, const char *bytes, int length, int limit, const char *ellipsis); /* 575 */ - Tcl_Obj * (*tcl_Format) (Tcl_Interp *interp, const char *format, int objc, Tcl_Obj *const objv[]); /* 576 */ - int (*tcl_AppendFormatToObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, int objc, Tcl_Obj *const objv[]); /* 577 */ + void (*tcl_AppendLimitedToObj) (Tcl_Obj *objPtr, const char *bytes, Tcl_Size length, Tcl_Size limit, const char *ellipsis); /* 575 */ + Tcl_Obj * (*tcl_Format) (Tcl_Interp *interp, const char *format, Tcl_Size objc, Tcl_Obj *const objv[]); /* 576 */ + int (*tcl_AppendFormatToObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, Tcl_Size objc, Tcl_Obj *const objv[]); /* 577 */ Tcl_Obj * (*tcl_ObjPrintf) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 578 */ void (*tcl_AppendPrintfToObj) (Tcl_Obj *objPtr, const char *format, ...) TCL_FORMAT_PRINTF(2, 3); /* 579 */ int (*tcl_CancelEval) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr, void *clientData, int flags); /* 580 */ @@ -2639,10 +2656,10 @@ typedef struct TclStubs { int (*tcl_CreatePipe) (Tcl_Interp *interp, Tcl_Channel *rchan, Tcl_Channel *wchan, int flags); /* 582 */ Tcl_Command (*tcl_NRCreateCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 583 */ int (*tcl_NREvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 584 */ - int (*tcl_NREvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 585 */ - int (*tcl_NRCmdSwap) (Tcl_Interp *interp, Tcl_Command cmd, int objc, Tcl_Obj *const objv[], int flags); /* 586 */ + int (*tcl_NREvalObjv) (Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags); /* 585 */ + int (*tcl_NRCmdSwap) (Tcl_Interp *interp, Tcl_Command cmd, Tcl_Size objc, Tcl_Obj *const objv[], int flags); /* 586 */ void (*tcl_NRAddCallback) (Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr, void *data0, void *data1, void *data2, void *data3); /* 587 */ - int (*tcl_NRCallObjProc) (Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, void *clientData, int objc, Tcl_Obj *const objv[]); /* 588 */ + int (*tcl_NRCallObjProc) (Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, void *clientData, Tcl_Size objc, Tcl_Obj *const objv[]); /* 588 */ unsigned (*tcl_GetFSDeviceFromStat) (const Tcl_StatBuf *statPtr); /* 589 */ unsigned (*tcl_GetFSInodeFromStat) (const Tcl_StatBuf *statPtr); /* 590 */ unsigned (*tcl_GetModeFromStat) (const Tcl_StatBuf *statPtr); /* 591 */ @@ -2665,15 +2682,15 @@ typedef struct TclStubs { int (*tcl_InterpActive) (Tcl_Interp *interp); /* 608 */ void (*tcl_BackgroundException) (Tcl_Interp *interp, int code); /* 609 */ int (*tcl_ZlibDeflate) (Tcl_Interp *interp, int format, Tcl_Obj *data, int level, Tcl_Obj *gzipHeaderDictObj); /* 610 */ - int (*tcl_ZlibInflate) (Tcl_Interp *interp, int format, Tcl_Obj *data, int buffersize, Tcl_Obj *gzipHeaderDictObj); /* 611 */ - unsigned int (*tcl_ZlibCRC32) (unsigned int crc, const unsigned char *buf, int len); /* 612 */ - unsigned int (*tcl_ZlibAdler32) (unsigned int adler, const unsigned char *buf, int len); /* 613 */ + int (*tcl_ZlibInflate) (Tcl_Interp *interp, int format, Tcl_Obj *data, Tcl_Size buffersize, Tcl_Obj *gzipHeaderDictObj); /* 611 */ + unsigned int (*tcl_ZlibCRC32) (unsigned int crc, const unsigned char *buf, Tcl_Size len); /* 612 */ + unsigned int (*tcl_ZlibAdler32) (unsigned int adler, const unsigned char *buf, Tcl_Size len); /* 613 */ int (*tcl_ZlibStreamInit) (Tcl_Interp *interp, int mode, int format, int level, Tcl_Obj *dictObj, Tcl_ZlibStream *zshandle); /* 614 */ Tcl_Obj * (*tcl_ZlibStreamGetCommandName) (Tcl_ZlibStream zshandle); /* 615 */ int (*tcl_ZlibStreamEof) (Tcl_ZlibStream zshandle); /* 616 */ int (*tcl_ZlibStreamChecksum) (Tcl_ZlibStream zshandle); /* 617 */ int (*tcl_ZlibStreamPut) (Tcl_ZlibStream zshandle, Tcl_Obj *data, int flush); /* 618 */ - int (*tcl_ZlibStreamGet) (Tcl_ZlibStream zshandle, Tcl_Obj *data, int count); /* 619 */ + int (*tcl_ZlibStreamGet) (Tcl_ZlibStream zshandle, Tcl_Obj *data, Tcl_Size count); /* 619 */ int (*tcl_ZlibStreamClose) (Tcl_ZlibStream zshandle); /* 620 */ int (*tcl_ZlibStreamReset) (Tcl_ZlibStream zshandle); /* 621 */ void (*tcl_SetStartupScript) (Tcl_Obj *path, const char *encoding); /* 622 */ @@ -2698,22 +2715,22 @@ typedef struct TclStubs { void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */ void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */ int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */ - int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, int size); /* 644 */ - int (*tcl_GetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr); /* 645 */ + int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, Tcl_Size size); /* 644 */ + int (*tcl_GetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size endValue, Tcl_Size *indexPtr); /* 645 */ int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */ - char * (*tcl_UniCharToUtfDString) (const int *uniStr, int uniLength, Tcl_DString *dsPtr); /* 647 */ - int * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 648 */ + char * (*tcl_UniCharToUtfDString) (const int *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr); /* 647 */ + int * (*tcl_UtfToUniCharDString) (const char *src, Tcl_Size length, Tcl_DString *dsPtr); /* 648 */ unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *numBytesPtr); /* 649 */ unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, size_t *numBytesPtr); /* 650 */ char * (*tclGetStringFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 651 */ unsigned short * (*tclGetUnicodeFromObj) (Tcl_Obj *objPtr, size_t *lengthPtr); /* 652 */ unsigned char * (*tclGetByteArrayFromObj) (Tcl_Obj *objPtr, size_t *numBytesPtr); /* 653 */ - int (*tcl_UtfCharComplete) (const char *src, int length); /* 654 */ + int (*tcl_UtfCharComplete) (const char *src, Tcl_Size length); /* 654 */ const char * (*tcl_UtfNext) (const char *src); /* 655 */ const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */ int (*tcl_UniCharIsUnicode) (int ch); /* 657 */ - int (*tcl_ExternalToUtfDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 658 */ - int (*tcl_UtfToExternalDStringEx) (Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr); /* 659 */ + Tcl_Size (*tcl_ExternalToUtfDStringEx) (Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr); /* 658 */ + Tcl_Size (*tcl_UtfToExternalDStringEx) (Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr); /* 659 */ int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */ int (*tclListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *objcPtr, Tcl_Obj ***objvPtr); /* 661 */ int (*tclListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *lengthPtr); /* 662 */ @@ -2722,12 +2739,12 @@ typedef struct TclStubs { void (*tclSplitPath) (const char *path, size_t *argcPtr, const char ***argvPtr); /* 665 */ Tcl_Obj * (*tclFSSplitPath) (Tcl_Obj *pathPtr, size_t *lenPtr); /* 666 */ int (*tclParseArgsObjv) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, size_t *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 667 */ - int (*tcl_UniCharLen) (const int *uniStr); /* 668 */ - int (*tclNumUtfChars) (const char *src, int length); /* 669 */ - int (*tclGetCharLength) (Tcl_Obj *objPtr); /* 670 */ - const char * (*tclUtfAtIndex) (const char *src, int index); /* 671 */ - Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, int first, int last); /* 672 */ - int (*tclGetUniChar) (Tcl_Obj *objPtr, int index); /* 673 */ + Tcl_Size (*tcl_UniCharLen) (const int *uniStr); /* 668 */ + Tcl_Size (*tclNumUtfChars) (const char *src, Tcl_Size length); /* 669 */ + Tcl_Size (*tclGetCharLength) (Tcl_Obj *objPtr); /* 670 */ + const char * (*tclUtfAtIndex) (const char *src, Tcl_Size index); /* 671 */ + Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 672 */ + int (*tclGetUniChar) (Tcl_Obj *objPtr, Tcl_Size index); /* 673 */ int (*tcl_GetBool) (Tcl_Interp *interp, const char *src, int flags, char *charPtr); /* 674 */ int (*tcl_GetBoolFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, char *charPtr); /* 675 */ Tcl_Command (*tcl_CreateObjCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 676 */ diff --git a/generic/tclIO.h b/generic/tclIO.h index e8d2736..1da8478 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -36,12 +36,12 @@ */ typedef struct ChannelBuffer { - int refCount; /* Current uses count */ - int nextAdded; /* The next position into which a character + Tcl_Size refCount; /* Current uses count */ + Tcl_Size nextAdded; /* The next position into which a character * will be put in the buffer. */ - int nextRemoved; /* Position of next byte to be removed from + Tcl_Size nextRemoved; /* Position of next byte to be removed from * the buffer. */ - int bufLength; /* How big is the buffer? */ + Tcl_Size bufLength; /* How big is the buffer? */ struct ChannelBuffer *nextPtr; /* Next buffer in chain. */ char buf[TCLFLEXARRAY]; /* Placeholder for real buffer. The real @@ -113,7 +113,7 @@ typedef struct Channel { ChannelBuffer *inQueueHead; /* Points at first buffer in input queue. */ ChannelBuffer *inQueueTail; /* Points at last buffer in input queue. */ - int refCount; + Tcl_Size refCount; } Channel; /* @@ -163,7 +163,7 @@ typedef struct ChannelState { int unreportedError; /* Non-zero if an error report was deferred * because it happened in the background. The * value is the POSIX error code. */ - int refCount; /* How many interpreters hold references to + Tcl_Size refCount; /* How many interpreters hold references to * this IO channel? */ struct CloseCallback *closeCbPtr; /* Callbacks registered to be called when the @@ -186,7 +186,7 @@ typedef struct ChannelState { EventScriptRecord *scriptRecordPtr; /* Chain of all scripts registered for event * handlers ("fileevent") on this channel. */ - int bufSize; /* What size buffers to allocate? */ + Tcl_Size bufSize; /* What size buffers to allocate? */ Tcl_TimerToken timer; /* Handle to wakeup timer for this channel. */ struct CopyState *csPtrR; /* State of background copy for which channel * is input, or NULL. */ @@ -274,7 +274,7 @@ typedef struct ChannelState { #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ #define CHANNEL_ENCODING_NOCOMPLAIN (1<<17) /* set if option - * -nocomplaincoding is set to 1 */ + * -nocomplainencoding is set to 1 */ #define CHANNEL_ENCODING_STRICT (1<<18) /* set if option * -strictencoding is set to 1 */ #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. diff --git a/generic/tclInt.h b/generic/tclInt.h index 0092322..45a41ab 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -184,7 +184,7 @@ typedef struct Tcl_ResolvedVarInfo { } Tcl_ResolvedVarInfo; typedef int (Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp, - const char *name, int length, Tcl_Namespace *context, + const char *name, Tcl_Size length, Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr); typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, const char *name, @@ -294,11 +294,11 @@ typedef struct Namespace { * namespace. */ int flags; /* OR-ed combination of the namespace status * flags NS_DYING and NS_DEAD listed below. */ - int activationCount; /* Number of "activations" or active call + Tcl_Size activationCount; /* Number of "activations" or active call * frames for this namespace that are on the * Tcl call stack. The namespace won't be * freed until activationCount becomes zero. */ - int refCount; /* Count of references by namespaceName + Tcl_Size refCount; /* Count of references by namespaceName * objects. The namespace can't be freed until * refCount becomes zero. */ Tcl_HashTable cmdTable; /* Contains all the commands currently @@ -319,16 +319,16 @@ typedef struct Namespace { * commands; however, no namespace qualifiers * are allowed. NULL if no export patterns are * registered. */ - int numExportPatterns; /* Number of export patterns currently + Tcl_Size numExportPatterns; /* Number of export patterns currently * registered using "namespace export". */ - int maxExportPatterns; /* Mumber of export patterns for which space + Tcl_Size maxExportPatterns; /* Number of export patterns for which space * is currently allocated. */ - int cmdRefEpoch; /* Incremented if a newly added command + Tcl_Size cmdRefEpoch; /* Incremented if a newly added command * shadows a command for which this namespace * has already cached a Command* pointer; this * causes all its cached Command* pointers to * be invalidated. */ - int resolverEpoch; /* Incremented whenever (a) the name + Tcl_Size resolverEpoch; /* Incremented whenever (a) the name * resolution rules change for this namespace * or (b) a newly added command shadows a * command that is compiled to bytecodes. This @@ -355,7 +355,7 @@ typedef struct Namespace { * LookupCompiledLocal to resolve variable * references within the namespace at compile * time. */ - int exportLookupEpoch; /* Incremented whenever a command is added to + Tcl_Size exportLookupEpoch; /* Incremented whenever a command is added to * a namespace, removed from a namespace or * the exports of a namespace are changed. * Allows TIP#112-driven command lists to be @@ -366,7 +366,7 @@ typedef struct Namespace { Tcl_Obj *unknownHandlerPtr; /* A script fragment to be used when command * resolution in this namespace fails. TIP * 181. */ - int commandPathLength; /* The length of the explicit path. */ + Tcl_Size commandPathLength; /* The length of the explicit path. */ NamespacePathEntry *commandPathArray; /* The explicit path of the namespace as an * array. */ @@ -455,7 +455,7 @@ typedef struct EnsembleConfig { * if the command has been deleted (or never * existed; the global namespace never has an * ensemble command.) */ - int epoch; /* The epoch at which this ensemble's table of + Tcl_Size epoch; /* The epoch at which this ensemble's table of * exported commands is valid. */ char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all * consistent points, this will have the same @@ -512,7 +512,7 @@ typedef struct EnsembleConfig { * core, presumably because the ensemble * itself has been updated. */ Tcl_Obj *parameterList; /* List of ensemble parameter names. */ - int numParameters; /* Cached number of parameters. This is either + Tcl_Size numParameters; /* Cached number of parameters. This is either * 0 (if the parameterList field is NULL) or * the length of the list in the parameterList * field. */ @@ -568,7 +568,7 @@ typedef struct CommandTrace { struct CommandTrace *nextPtr; /* Next in list of traces associated with a * particular command. */ - int refCount; /* Used to ensure this structure is not + Tcl_Size refCount; /* Used to ensure this structure is not * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ @@ -641,7 +641,7 @@ typedef struct Var { typedef struct VarInHash { Var var; - int refCount; /* Counts number of active uses of this + Tcl_Size refCount; /* Counts number of active uses of this * variable: 1 for the entry in the hash * table, 1 for each additional variable whose * linkPtr points here, 1 for each nested @@ -946,9 +946,9 @@ typedef struct CompiledLocal { /* Next compiler-recognized local variable for * this procedure, or NULL if this is the last * local. */ - int nameLength; /* The number of bytes in local variable's name. + Tcl_Size nameLength; /* The number of bytes in local variable's name. * Among others used to speed up var lookups. */ - int frameIndex; /* Index in the array of compiler-assigned + Tcl_Size frameIndex; /* Index in the array of compiler-assigned * variables in the procedure call frame. */ int flags; /* Flag bits for the local variable. Same as * the flags for the Var structure above, @@ -980,7 +980,7 @@ typedef struct CompiledLocal { typedef struct Proc { struct Interp *iPtr; /* Interpreter for which this command is * defined. */ - int refCount; /* Reference count: 1 if still present in + Tcl_Size refCount; /* Reference count: 1 if still present in * command table plus 1 for each call to the * procedure that is currently active. This * structure can be freed when refCount @@ -991,8 +991,8 @@ typedef struct Proc { * procedure. */ Tcl_Obj *bodyPtr; /* Points to the ByteCode object for * procedure's body command. */ - int numArgs; /* Number of formal parameters. */ - int numCompiledLocals; /* Count of local variables recognized by the + Tcl_Size numArgs; /* Number of formal parameters. */ + Tcl_Size numCompiledLocals; /* Count of local variables recognized by the * compiler including arguments and * temporaries. */ CompiledLocal *firstLocalPtr; @@ -1097,8 +1097,8 @@ typedef struct AssocData { */ typedef struct LocalCache { - int refCount; - int numVars; + Tcl_Size refCount; + Tcl_Size numVars; Tcl_Obj *varName0; } LocalCache; @@ -1118,7 +1118,7 @@ typedef struct CallFrame { * If FRAME_IS_PROC is set, the frame was * pushed to execute a Tcl procedure and may * have local vars. */ - int objc; /* This and objv below describe the arguments + Tcl_Size objc; /* This and objv below describe the arguments * for this procedure call. */ Tcl_Obj *const *objv; /* Array of argument objects. */ struct CallFrame *callerPtr; @@ -1132,7 +1132,7 @@ typedef struct CallFrame { * callerPtr unless an "uplevel" command or * something equivalent was active in the * caller). */ - int level; /* Level of this procedure, for "uplevel" + Tcl_Size level; /* Level of this procedure, for "uplevel" * purposes (i.e. corresponds to nesting of * callerVarPtr's, not callerPtr's). 1 for * outermost procedure, 0 for top-level. */ @@ -1146,8 +1146,8 @@ typedef struct CallFrame { * recognized by the compiler, or created at * execution time through, e.g., upvar. * Initially NULL and created if needed. */ - int numCompiledLocals; /* Count of local variables recognized by the - * compiler including arguments. */ + Tcl_Size numCompiledLocals; /* Count of local variables recognized + * by the compiler including arguments. */ Var *compiledLocals; /* Points to the array of local variables * recognized by the compiler. The compiler * emits code that refers to these variables @@ -1208,7 +1208,7 @@ typedef struct CmdFrame { int level; /* Number of frames in stack, prevent O(n) * scan of list. */ int *line; /* Lines the words of the command start on. */ - int nline; + Tcl_Size nline; CallFrame *framePtr; /* Procedure activation record, may be * NULL. */ struct CmdFrame *nextPtr; /* Link to calling frame. */ @@ -1252,7 +1252,7 @@ typedef struct CmdFrame { } data; Tcl_Obj *cmdObj; const char *cmd; /* The executed command, if possible... */ - int len; /* ... and its length. */ + Tcl_Size len; /* ... and its length. */ const struct CFWordBC *litarg; /* Link to set of literal arguments which have * ben pushed on the lineLABCPtr stack by @@ -1262,16 +1262,16 @@ typedef struct CmdFrame { typedef struct CFWord { CmdFrame *framePtr; /* CmdFrame to access. */ - int word; /* Index of the word in the command. */ - int refCount; /* Number of times the word is on the + Tcl_Size word; /* Index of the word in the command. */ + Tcl_Size refCount; /* Number of times the word is on the * stack. */ } CFWord; typedef struct CFWordBC { CmdFrame *framePtr; /* CmdFrame to access. */ - int pc; /* Instruction pointer of a command in + Tcl_Size pc; /* Instruction pointer of a command in * ExtCmdLoc.loc[.] */ - int word; /* Index of word in + Tcl_Size word; /* Index of word in * ExtCmdLoc.loc[cmd]->line[.] */ struct CFWordBC *prevPtr; /* Previous entry in stack for same Tcl_Obj. */ struct CFWordBC *nextPtr; /* Next entry for same command call. See @@ -1300,7 +1300,7 @@ typedef struct CFWordBC { #define CLL_END (-1) typedef struct ContLineLoc { - int num; /* Number of entries in loc, not counting the + Tcl_Size num; /* Number of entries in loc, not counting the * final -1 marker entry. */ int loc[TCLFLEXARRAY];/* Table of locations, as character offsets. * The table is allocated as part of the @@ -1350,7 +1350,7 @@ typedef struct { * proc field is NULL. */ } ExtraFrameInfoField; typedef struct { - int length; /* Length of array. */ + Tcl_Size length; /* Length of array. */ ExtraFrameInfoField fields[2]; /* Really as long as necessary, but this is * long enough for nearly anything. */ @@ -1481,7 +1481,7 @@ typedef struct CoroutineData { CorContext running; Tcl_HashTable *lineLABCPtr; /* See Interp.lineLABCPtr */ void *stackLevel; - int auxNumLevels; /* While the coroutine is running the + Tcl_Size auxNumLevels; /* While the coroutine is running the * numLevels of the create/resume command is * stored here; for suspended coroutines it * holds the nesting numLevels at yield. */ @@ -1531,7 +1531,7 @@ typedef struct LiteralEntry { * NULL if end of chain. */ Tcl_Obj *objPtr; /* Points to Tcl object that holds the * literal's bytes and length. */ - int refCount; /* If in an interpreter's global literal + Tcl_Size refCount; /* If in an interpreter's global literal * table, the number of ByteCode structures * that share the literal object; the literal * entry can be freed when refCount drops to @@ -1673,12 +1673,12 @@ typedef struct Command { * recreated). */ Namespace *nsPtr; /* Points to the namespace containing this * command. */ - int refCount; /* 1 if in command hashtable plus 1 for each + Tcl_Size refCount; /* 1 if in command hashtable plus 1 for each * reference from a CmdName Tcl object * representing a command's name in a ByteCode * instruction sequence. This structure can be * freed when refCount becomes zero. */ - int cmdEpoch; /* Incremented to invalidate any references + Tcl_Size cmdEpoch; /* Incremented to invalidate any references * that point to this command when it is * renamed, deleted, hidden, or exposed. */ CompileProc *compileProc; /* Procedure called to compile command. NULL @@ -1730,7 +1730,9 @@ typedef struct Command { */ #define CMD_DYING 0x01 -#define CMD_IS_DELETED 0x01 /* Same as CMD_DYING (Deprecated) */ +#ifndef TCL_NO_DEPRECATED +# define CMD_IS_DELETED 0x01 /* Same as CMD_DYING */ +#endif #define CMD_TRACE_ACTIVE 0x02 #define CMD_HAS_EXEC_TRACES 0x04 #define CMD_COMPILES_EXPANDED 0x08 @@ -1875,12 +1877,12 @@ typedef struct Interp { * tclVar.c for usage. */ - int numLevels; /* Keeps track of how many nested calls to + Tcl_Size numLevels; /* Keeps track of how many nested calls to * Tcl_Eval are in progress for this * interpreter. It's used to delay deletion of * the table until all Tcl_Eval invocations * are completed. */ - int maxNestingDepth; /* If numLevels exceeds this value then Tcl + Tcl_Size maxNestingDepth; /* If numLevels exceeds this value then Tcl * assumes that infinite recursion has * occurred and it generates an error. */ CallFrame *framePtr; /* Points to top-most in stack of all nested @@ -1933,7 +1935,7 @@ typedef struct Interp { * Miscellaneous information: */ - int cmdCount; /* Total number of times a command procedure + Tcl_Size cmdCount; /* Total number of times a command procedure * has been called for this interpreter. */ int evalFlags; /* Flags to control next call to Tcl_Eval. * Normally zero, but may be set before @@ -1945,7 +1947,7 @@ typedef struct Interp { * compiled by the interpreter. Indexed by the * string representations of literals. Used to * avoid creating duplicate objects. */ - int compileEpoch; /* Holds the current "compilation epoch" for + Tcl_Size compileEpoch; /* Holds the current "compilation epoch" for * this interpreter. This is incremented to * invalidate existing ByteCodes when, e.g., a * command with a compile procedure is @@ -1995,7 +1997,7 @@ typedef struct Interp { /* First in list of active traces for interp, * or NULL if no active traces. */ - int tracesForbiddingInline; /* Count of traces (in the list headed by + Tcl_Size tracesForbiddingInline; /* Count of traces (in the list headed by * tracePtr) that forbid inline bytecode * compilation. */ @@ -2025,7 +2027,7 @@ typedef struct Interp { * as flag values the same as the 'active' * field. */ - int cmdCount; /* Limit for how many commands to execute in + Tcl_Size cmdCount; /* Limit for how many commands to execute in * the interpreter. */ LimitHandler *cmdHandlers; /* Handlers to execute when the limit is @@ -2061,9 +2063,9 @@ typedef struct Interp { * *root* ensemble command? (Nested ensembles * don't rewrite this.) NULL if we're not * processing an ensemble. */ - int numRemovedObjs; /* How many arguments have been stripped off + Tcl_Size numRemovedObjs; /* How many arguments have been stripped off * because of ensemble processing. */ - int numInsertedObjs; /* How many of the current arguments were + Tcl_Size numInsertedObjs; /* How many of the current arguments were * inserted by an ensemble. */ } ensembleRewrite; @@ -2392,7 +2394,7 @@ struct TclMaxAlignment { */ #define TclOOM(ptr, size) \ - ((size) && ((ptr)||(Tcl_Panic("unable to alloc %u bytes", (size)),1))) + ((size) && ((ptr)||(Tcl_Panic("unable to alloc %" TCL_Z_MODIFIER "u bytes", (size_t)(size)),1))) /* * The following enum values are used to specify the runtime platform setting @@ -2436,23 +2438,16 @@ typedef enum TclEolTranslation { #define TCL_INVOKE_NO_UNKNOWN (1<<1) #define TCL_INVOKE_NO_TRACEBACK (1<<2) -/* - * ListSizeT is the type for holding list element counts. It's defined - * simplify sharing source between Tcl8 and Tcl9. - */ #if TCL_MAJOR_VERSION > 8 -typedef size_t ListSizeT; - /* * SSIZE_MAX, NOT SIZE_MAX as negative differences need to be expressed - * between values of the ListSizeT type so limit the range to signed + * between values of the Tcl_Size type so limit the range to signed */ -#define ListSizeT_MAX ((ListSizeT)PTRDIFF_MAX) +#define ListSizeT_MAX ((Tcl_Size)PTRDIFF_MAX) #else -typedef int ListSizeT; #define ListSizeT_MAX INT_MAX #endif @@ -2483,9 +2478,9 @@ typedef int ListSizeT; * */ typedef struct ListStore { - ListSizeT firstUsed; /* Index of first slot in use within slots[] */ - ListSizeT numUsed; /* Number of slots in use (starting firstUsed) */ - ListSizeT numAllocated; /* Total number of slots[] array slots. */ + Tcl_Size firstUsed; /* Index of first slot in use within slots[] */ + Tcl_Size numUsed; /* Number of slots in use (starting firstUsed) */ + Tcl_Size numAllocated; /* Total number of slots[] array slots. */ size_t refCount; /* Number of references to this instance */ int flags; /* LISTSTORE_* flags */ Tcl_Obj *slots[TCLFLEXARRAY]; /* Variable size array. Grown as needed */ @@ -2497,7 +2492,7 @@ typedef struct ListStore { /* Max number of elements that can be contained in a list */ #define LIST_MAX \ - ((ListSizeT)(((size_t)ListSizeT_MAX - offsetof(ListStore, slots)) \ + ((Tcl_Size)(((size_t)ListSizeT_MAX - offsetof(ListStore, slots)) \ / sizeof(Tcl_Obj *))) /* Memory size needed for a ListStore to hold numSlots_ elements */ #define LIST_SIZE(numSlots_) \ @@ -2508,8 +2503,8 @@ typedef struct ListStore { * See comments above for ListStore */ typedef struct ListSpan { - ListSizeT spanStart; /* Starting index of the span */ - ListSizeT spanLength; /* Number of elements in the span */ + Tcl_Size spanStart; /* Starting index of the span */ + Tcl_Size spanLength; /* Number of elements in the span */ size_t refCount; /* Count of references to this span record */ } ListSpan; #ifndef LIST_SPAN_THRESHOLD /* May be set on build line */ @@ -2835,7 +2830,7 @@ typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, TCL_HASH_TYPE *len */ typedef struct ProcessGlobalValue { - int epoch; /* Epoch counter to detect changes in the + Tcl_Size epoch; /* Epoch counter to detect changes in the * global value. */ TCL_HASH_TYPE numBytes; /* Length of the global string. */ char *value; /* The global string value. */ @@ -3009,7 +3004,7 @@ typedef struct ForIterData { Tcl_Obj *body; /* Loop body. */ Tcl_Obj *next; /* Loop step script, NULL for 'while'. */ const char *msg; /* Error message part. */ - int word; /* Index of the body script in the command */ + Tcl_Size word; /* Index of the body script in the command */ } ForIterData; /* TIP #357 - Structure doing the bookkeeping of handles for Tcl_LoadFile @@ -3054,12 +3049,12 @@ struct Tcl_LoadHandle_ { */ MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, - const unsigned char *bytes, int len); + const unsigned char *bytes, Tcl_Size len); MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); -MODULE_SCOPE void TclAdvanceContinuations(int *line, int **next, +MODULE_SCOPE void TclAdvanceContinuations(Tcl_Size *line, int **next, int loc); -MODULE_SCOPE void TclAdvanceLines(int *line, const char *start, +MODULE_SCOPE void TclAdvanceLines(Tcl_Size *line, const char *start, const char *end); MODULE_SCOPE void TclArgumentEnter(Tcl_Interp *interp, Tcl_Obj *objv[], int objc, CmdFrame *cf); @@ -3067,7 +3062,7 @@ MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp, Tcl_Obj *objv[], int objc); MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp, Tcl_Obj *objv[], int objc, - void *codePtr, CmdFrame *cfPtr, int cmd, int pc); + void *codePtr, CmdFrame *cfPtr, int cmd, Tcl_Size pc); MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, CmdFrame *cfPtr); MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, @@ -3077,8 +3072,8 @@ MODULE_SCOPE int TclAsyncNotifier(int sigNumber, Tcl_ThreadId threadId, MODULE_SCOPE void TclAsyncMarkFromNotifier(void); MODULE_SCOPE double TclBignumToDouble(const void *bignum); MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, - int strLen, const unsigned char *pattern, - int ptnLen, int flags); + Tcl_Size strLen, const unsigned char *pattern, + Tcl_Size ptnLen, int flags); MODULE_SCOPE double TclCeil(const void *a); MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan); MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan); @@ -3093,14 +3088,14 @@ MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); -MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num, +MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, Tcl_Size num, int *loc); MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, int start, int *clNext); MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr); MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr, Tcl_Obj *originObjPtr); -MODULE_SCOPE int TclConvertElement(const char *src, int length, +MODULE_SCOPE Tcl_Size TclConvertElement(const char *src, Tcl_Size length, char *dst, int flags); MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs(Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *nsPtr, @@ -3112,12 +3107,12 @@ MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp, MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE void TclDeleteNamespaceChildren(Namespace *nsPtr); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, - const char *dict, int dictLength, + const char *dict, Tcl_Size dictLength, const char **elementPtr, const char **nextPtr, - int *sizePtr, int *literalPtr); + Tcl_Size *sizePtr, int *literalPtr); /* TIP #280 - Modified token based evaluation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, - int numBytes, int flags, int line, + Tcl_Size numBytes, int flags, Tcl_Size line, int *clNextOuter, const char *outerScript); MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd; @@ -3140,7 +3135,7 @@ MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, Tcl_DString *toAppendPtr); MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp, - Tcl_Obj *const *objv, int objc, int *objcPtr); + Tcl_Obj *const *objv, Tcl_Size objc, Tcl_Size *objcPtr); MODULE_SCOPE Tcl_Obj *const *TclEnsembleGetRewriteValues(Tcl_Interp *interp); MODULE_SCOPE Tcl_Namespace *TclEnsureNamespace(Tcl_Interp *interp, Tcl_Namespace *namespacePtr); @@ -3224,39 +3219,38 @@ MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); MODULE_SCOPE int TclIsDigitProc(int byte); MODULE_SCOPE int TclIsBareword(int byte); -MODULE_SCOPE Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[], +MODULE_SCOPE Tcl_Obj * TclJoinPath(Tcl_Size elements, Tcl_Obj * const objv[], int forceRelative); MODULE_SCOPE int MakeTildeRelativePath(Tcl_Interp *interp, const char *user, const char *subPath, Tcl_DString *dsPtr); MODULE_SCOPE Tcl_Obj * TclGetHomeDirObj(Tcl_Interp *interp, const char *user); MODULE_SCOPE Tcl_Obj * TclResolveTildePath(Tcl_Interp *interp, - Tcl_Obj *pathObj); + Tcl_Obj *pathObj); MODULE_SCOPE Tcl_Obj * TclResolveTildePathList(Tcl_Obj *pathsObj); MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *argPtr); MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, - int indexCount, Tcl_Obj *const indexArray[]); + Tcl_Size indexCount, Tcl_Obj *const indexArray[]); /* TIP #280 */ -MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, int line, int n, +MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, Tcl_Size line, int n, int *lines, Tcl_Obj *const *elems); MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); -MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Obj *listPtr, int fromIdx, - int toIdx); MODULE_SCOPE int TclListObjAppendElements(Tcl_Interp *interp, - Tcl_Obj *toObj, int elemCount, + Tcl_Obj *toObj, Tcl_Size elemCount, Tcl_Obj *const elemObjv[]); +MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Obj *listPtr, Tcl_Size fromIdx, + Tcl_Size toIdx); MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *indexPtr, Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, - int indexCount, Tcl_Obj *const indexArray[], + Tcl_Size indexCount, Tcl_Obj *const indexArray[], Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name, const EnsembleImplMap map[]); MODULE_SCOPE int TclMakeSafe(Tcl_Interp *interp); - -MODULE_SCOPE int TclMaxListLength(const char *bytes, int numBytes, +MODULE_SCOPE int TclMaxListLength(const char *bytes, Tcl_Size numBytes, const char **endPtr); MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, @@ -3274,15 +3268,15 @@ MODULE_SCOPE int TclObjInvokeNamespace(Tcl_Interp *interp, MODULE_SCOPE int TclObjUnsetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); MODULE_SCOPE int TclParseBackslash(const char *src, - int numBytes, int *readPtr, char *dst); -MODULE_SCOPE int TclParseHex(const char *src, int numBytes, + Tcl_Size numBytes, Tcl_Size *readPtr, char *dst); +MODULE_SCOPE int TclParseHex(const char *src, Tcl_Size numBytes, int *resultPtr); MODULE_SCOPE int TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *expected, const char *bytes, - int numBytes, const char **endPtrPtr, int flags); + Tcl_Size numBytes, const char **endPtrPtr, int flags); MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string, - int numBytes, Tcl_Parse *parsePtr); -MODULE_SCOPE int TclParseAllWhiteSpace(const char *src, int numBytes); + Tcl_Size numBytes, Tcl_Parse *parsePtr); +MODULE_SCOPE Tcl_Size TclParseAllWhiteSpace(const char *src, Tcl_Size numBytes); MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); @@ -3290,7 +3284,7 @@ MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, - int len); + Tcl_Size len); MODULE_SCOPE void TclpAlertNotifier(void *clientData); MODULE_SCOPE void *TclpNotifierData(void); MODULE_SCOPE void TclpServiceModeHook(int mode); @@ -3311,8 +3305,8 @@ MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, const char **errorMsgPtr); MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, - int stackSize, int flags); -MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr); + Tcl_Size stackSize, int flags); +MODULE_SCOPE Tcl_Size TclpFindVariable(const char *name, Tcl_Size *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); @@ -3327,9 +3321,9 @@ MODULE_SCOPE int TclpMatchFiles(Tcl_Interp *interp, char *separators, MODULE_SCOPE int TclpObjNormalizePath(Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint); MODULE_SCOPE void TclpNativeJoinPath(Tcl_Obj *prefix, const char *joining); -MODULE_SCOPE Tcl_Obj * TclpNativeSplitPath(Tcl_Obj *pathPtr, int *lenPtr); +MODULE_SCOPE Tcl_Obj * TclpNativeSplitPath(Tcl_Obj *pathPtr, Tcl_Size *lenPtr); MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr, - int *driveNameLengthPtr, Tcl_Obj **driveNameRef); + Tcl_Size *driveNameLengthPtr, Tcl_Obj **driveNameRef); MODULE_SCOPE int TclCrossFilesystemCopy(Tcl_Interp *interp, Tcl_Obj *source, Tcl_Obj *target); MODULE_SCOPE int TclpMatchInDirectory(Tcl_Interp *interp, @@ -3360,9 +3354,9 @@ MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id); MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex); MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, - int reStrLen, Tcl_DString *dsPtr, int *flagsPtr, + Tcl_Size reStrLen, Tcl_DString *dsPtr, int *flagsPtr, int *quantifiersFoundPtr); -MODULE_SCOPE TCL_HASH_TYPE TclScanElement(const char *string, int length, +MODULE_SCOPE TCL_HASH_TYPE TclScanElement(const char *string, Tcl_Size length, char *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); @@ -3377,44 +3371,44 @@ MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue, Tcl_Encoding encoding); MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, - Tcl_Obj *const *objv, int objc, int subIdx, + Tcl_Obj *const *objv, Tcl_Size objc, Tcl_Size subIdx, Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, - int numBytes); + Tcl_Size numBytes); typedef int (*memCmpFn_t)(const void*, const void*, size_t); MODULE_SCOPE int TclStringCmp(Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr, - int checkEq, int nocase, int reqlength); + int checkEq, int nocase, Tcl_Size reqlength); MODULE_SCOPE int TclStringCmpOpts(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int *nocase, int *reqlength); -MODULE_SCOPE int TclStringMatch(const char *str, int strLen, +MODULE_SCOPE int TclStringMatch(const char *str, Tcl_Size strLen, const char *pattern, int ptnLen, int flags); MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, Tcl_Obj *patternObj, int flags); MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes, - int numBytes, int flags, int line, + Tcl_Size numBytes, int flags, Tcl_Size line, struct CompileEnv *envPtr); -MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, int numOpts, +MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, Tcl_Size numOpts, Tcl_Obj *const opts[], int *flagPtr); MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes, - int numBytes, int flags, Tcl_Parse *parsePtr, + Tcl_Size numBytes, int flags, Tcl_Parse *parsePtr, Tcl_InterpState *statePtr); MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, - int count, int *tokensLeftPtr, int line, + Tcl_Size count, int *tokensLeftPtr, Tcl_Size line, int *clNextOuter, const char *outerScript); -MODULE_SCOPE int TclTrim(const char *bytes, int numBytes, - const char *trim, int numTrim, int *trimRight); -MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes, - const char *trim, int numTrim); -MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, - const char *trim, int numTrim); +MODULE_SCOPE Tcl_Size TclTrim(const char *bytes, Tcl_Size numBytes, + const char *trim, Tcl_Size numTrim, Tcl_Size *trimRight); +MODULE_SCOPE Tcl_Size TclTrimLeft(const char *bytes, Tcl_Size numBytes, + const char *trim, Tcl_Size numTrim); +MODULE_SCOPE Tcl_Size TclTrimRight(const char *bytes, Tcl_Size numBytes, + const char *trim, Tcl_Size numTrim); MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command); MODULE_SCOPE void TclRegisterCommandTypeName( Tcl_ObjCmdProc *implementationProc, const char *nameStr); MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); -MODULE_SCOPE int TclUtfCount(int ch); +MODULE_SCOPE Tcl_Size TclUtfCount(int ch); #if TCL_UTF_MAX > 3 # define TclUtfToUCS4 Tcl_UtfToUniChar # define TclUniCharToUCS4(src, ptr) (*ptr = *(src),1) @@ -3461,7 +3455,7 @@ MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); MODULE_SCOPE void TclpThreadSetGlobalTSD(void *tsdKeyPtr, void *ptr); MODULE_SCOPE void * TclpThreadGetGlobalTSD(void *tsdKeyPtr); MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, - const char *msg, int length); + const char *msg, Tcl_Size length); /* Tip 430 */ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); @@ -3551,7 +3545,7 @@ MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, Tcl_Obj *part2Ptr, int index, int pathc, Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, - int pathc, Tcl_Obj *const pathv[]); + Tcl_Size pathc, Tcl_Obj *const pathv[]); MODULE_SCOPE Tcl_ObjCmdProc Tcl_DisassembleObjCmd; /* Assemble command function */ @@ -4077,13 +4071,13 @@ MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, MODULE_SCOPE Tcl_Obj * TclStringCat(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); MODULE_SCOPE Tcl_Obj * TclStringFirst(Tcl_Obj *needle, Tcl_Obj *haystack, - int start); + Tcl_Size start); MODULE_SCOPE Tcl_Obj * TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack, - int last); + Tcl_Size last); MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr, - int count, int flags); + Tcl_Size count, int flags); MODULE_SCOPE Tcl_Obj * TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr, - int first, int count, Tcl_Obj *insertPtr, + Tcl_Size first, Tcl_Size count, Tcl_Obj *insertPtr, int flags); MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr, int flags); @@ -4197,12 +4191,12 @@ MODULE_SCOPE Tcl_Obj * TclGetArrayDefault(Var *arrayPtr); */ MODULE_SCOPE int TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr, - int before, int after, int *indexPtr); -MODULE_SCOPE int TclIndexDecode(int encoded, int endValue); + Tcl_Size before, Tcl_Size after, int *indexPtr); +MODULE_SCOPE Tcl_Size TclIndexDecode(int encoded, Tcl_Size endValue); /* Constants used in index value encoding routines. */ -#define TCL_INDEX_END (-2) -#define TCL_INDEX_START (0) +#define TCL_INDEX_END ((Tcl_Size)-2) +#define TCL_INDEX_START ((Tcl_Size)0) /* *---------------------------------------------------------------------- @@ -4474,7 +4468,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, * * The ANSI C "prototype" for this macro is: * - * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, int len); + * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, size_t len); * *---------------------------------------------------------------- */ @@ -4840,7 +4834,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; * * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d); - * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, int len); + * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, Tcl_Size len); * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral); * *---------------------------------------------------------------- @@ -5186,8 +5180,8 @@ typedef struct NRE_callback { * Other externals. */ -MODULE_SCOPE size_t TclEnvEpoch; /* Epoch of the tcl environment - * (if changed with tcl-env). */ +MODULE_SCOPE size_t TclEnvEpoch; /* Epoch of the tcl environment + * (if changed with tcl-env). */ #endif /* _TCLINT */ diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 78eb8a7..a1d080c 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -48,13 +48,13 @@ */ #define LIST_INDEX_ASSERT(idxarg_) \ do { \ - ListSizeT idx_ = (idxarg_); /* To guard against ++ etc. */ \ + Tcl_Size idx_ = (idxarg_); /* To guard against ++ etc. */ \ LIST_ASSERT(idx_ >= 0 && idx_ < LIST_MAX); \ } while (0) /* Ditto for counts except upper limit is different */ #define LIST_COUNT_ASSERT(countarg_) \ do { \ - ListSizeT count_ = (countarg_); /* To guard against ++ etc. */ \ + Tcl_Size count_ = (countarg_); /* To guard against ++ etc. */ \ LIST_ASSERT(count_ >= 0 && count_ <= LIST_MAX); \ } while (0) @@ -121,21 +121,21 @@ */ static int MemoryAllocationError(Tcl_Interp *, size_t size); static int ListLimitExceededError(Tcl_Interp *); -static ListStore *ListStoreNew(ListSizeT objc, Tcl_Obj *const objv[], int flags); -static int ListRepInit(ListSizeT objc, Tcl_Obj *const objv[], int flags, ListRep *); +static ListStore *ListStoreNew(Tcl_Size objc, Tcl_Obj *const objv[], int flags); +static int ListRepInit(Tcl_Size objc, Tcl_Obj *const objv[], int flags, ListRep *); static int ListRepInitAttempt(Tcl_Interp *, - ListSizeT objc, + Tcl_Size objc, Tcl_Obj *const objv[], ListRep *); static void ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags); static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr); static int TclListObjGetRep(Tcl_Interp *, Tcl_Obj *listPtr, ListRep *repPtr); static void ListRepRange(ListRep *srcRepPtr, - ListSizeT rangeStart, - ListSizeT rangeEnd, + Tcl_Size rangeStart, + Tcl_Size rangeEnd, int preserveSrcRep, ListRep *rangeRepPtr); -static ListStore *ListStoreReallocate(ListStore *storePtr, ListSizeT numSlots); +static ListStore *ListStoreReallocate(ListStore *storePtr, Tcl_Size numSlots); static void ListRepValidate(const ListRep *repPtr, const char *file, int lineNum); static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); @@ -237,8 +237,8 @@ const Tcl_ObjType tclListType = { */ static inline ListSpan * ListSpanNew( - ListSizeT firstSlot, /* Starting slot index of the span */ - ListSizeT numSlots) /* Number of slots covered by the span */ + Tcl_Size firstSlot, /* Starting slot index of the span */ + Tcl_Size numSlots) /* Number of slots covered by the span */ { ListSpan *spanPtr = (ListSpan *) ckalloc(sizeof(*spanPtr)); spanPtr->refCount = 0; @@ -295,9 +295,9 @@ ListSpanDecrRefs(ListSpan *spanPtr) */ static inline int ListSpanMerited( - ListSizeT length, /* Length of the proposed span */ - ListSizeT usedStorageLength, /* Number of slots currently in used */ - ListSizeT allocatedStorageLength) /* Length of the currently allocation */ + Tcl_Size length, /* Length of the proposed span */ + Tcl_Size usedStorageLength, /* Number of slots currently in used */ + Tcl_Size allocatedStorageLength) /* Length of the currently allocation */ { /* TODO @@ -338,8 +338,8 @@ ListSpanMerited( * *------------------------------------------------------------------------ */ -static inline ListSizeT -ListStoreUpSize(ListSizeT numSlotsRequested) { +static inline Tcl_Size +ListStoreUpSize(Tcl_Size numSlotsRequested) { /* TODO -how much extra? May be double only for smaller requests? */ return numSlotsRequested < (LIST_MAX / 2) ? 2 * numSlotsRequested : LIST_MAX; @@ -391,8 +391,8 @@ ListRepFreeUnreferenced(const ListRep *repPtr) static inline void ObjArrayIncrRefs( Tcl_Obj * const *objv, /* Pointer to the array */ - ListSizeT startIdx, /* Starting index of subarray within objv */ - ListSizeT count) /* Number of elements in the subarray */ + Tcl_Size startIdx, /* Starting index of subarray within objv */ + Tcl_Size count) /* Number of elements in the subarray */ { Tcl_Obj * const *end; LIST_INDEX_ASSERT(startIdx); @@ -423,8 +423,8 @@ ObjArrayIncrRefs( static inline void ObjArrayDecrRefs( Tcl_Obj * const *objv, /* Pointer to the array */ - ListSizeT startIdx, /* Starting index of subarray within objv */ - ListSizeT count) /* Number of elements in the subarray */ + Tcl_Size startIdx, /* Starting index of subarray within objv */ + Tcl_Size count) /* Number of elements in the subarray */ { Tcl_Obj * const *end; LIST_INDEX_ASSERT(startIdx); @@ -455,7 +455,7 @@ ObjArrayDecrRefs( static inline void ObjArrayCopy( Tcl_Obj **to, /* Destination */ - ListSizeT count, /* Number of pointers to copy */ + Tcl_Size count, /* Number of pointers to copy */ Tcl_Obj *const from[]) /* Source array of Tcl_Obj* */ { Tcl_Obj **end; @@ -547,7 +547,7 @@ ListLimitExceededError(Tcl_Interp *interp) *------------------------------------------------------------------------ */ static inline void -ListRepUnsharedShiftDown(ListRep *repPtr, ListSizeT shiftCount) +ListRepUnsharedShiftDown(ListRep *repPtr, Tcl_Size shiftCount) { ListStore *storePtr; @@ -602,7 +602,7 @@ ListRepUnsharedShiftDown(ListRep *repPtr, ListSizeT shiftCount) */ #if 0 static inline void -ListRepUnsharedShiftUp(ListRep *repPtr, ListSizeT shiftCount) +ListRepUnsharedShiftUp(ListRep *repPtr, Tcl_Size shiftCount) { ListStore *storePtr; @@ -750,12 +750,12 @@ TclListObjValidate(Tcl_Interp *interp, Tcl_Obj *listObj) */ static ListStore * ListStoreNew( - ListSizeT objc, + Tcl_Size objc, Tcl_Obj *const objv[], int flags) { ListStore *storePtr; - ListSizeT capacity; + Tcl_Size capacity; /* * First check to see if we'd overflow and try to allocate an object @@ -793,7 +793,7 @@ ListStoreNew( if (capacity == objc) { storePtr->firstUsed = 0; } else { - ListSizeT extra = capacity - objc; + Tcl_Size extra = capacity - objc; int spaceFlags = flags & LISTREP_SPACE_FLAGS; if (spaceFlags == LISTREP_SPACE_ONLY_BACK) { storePtr->firstUsed = 0; @@ -840,9 +840,9 @@ ListStoreNew( *------------------------------------------------------------------------ */ ListStore * -ListStoreReallocate (ListStore *storePtr, ListSizeT numSlots) +ListStoreReallocate (ListStore *storePtr, Tcl_Size numSlots) { - ListSizeT newCapacity; + Tcl_Size newCapacity; ListStore *newStorePtr; newCapacity = ListStoreUpSize(numSlots); @@ -893,7 +893,7 @@ ListStoreReallocate (ListStore *storePtr, ListSizeT numSlots) */ static int ListRepInit( - ListSizeT objc, + Tcl_Size objc, Tcl_Obj *const objv[], int flags, ListRep *repPtr @@ -949,7 +949,7 @@ ListRepInit( static int ListRepInitAttempt( Tcl_Interp *interp, - ListSizeT objc, + Tcl_Size objc, Tcl_Obj *const objv[], ListRep *repPtr) { @@ -990,7 +990,7 @@ static void ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags) { Tcl_Obj **fromObjs; - ListSizeT numFrom; + Tcl_Size numFrom; ListRepElements(fromRepPtr, numFrom, fromObjs); ListRepInit(numFrom, fromObjs, flags | LISTREP_PANIC_ON_FAIL, toRepPtr); @@ -1018,7 +1018,7 @@ ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags) */ static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr) { - ListSizeT count; + Tcl_Size count; ListStore *storePtr; ListSpan *spanPtr; @@ -1091,7 +1091,7 @@ static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr) Tcl_Obj * Tcl_NewListObj( - ListSizeT objc, /* Count of objects referenced by objv. */ + Tcl_Size objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ { return Tcl_DbNewListObj(objc, objv, "unknown", 0); @@ -1101,7 +1101,7 @@ Tcl_NewListObj( Tcl_Obj * Tcl_NewListObj( - ListSizeT objc, /* Count of objects referenced by objv. */ + Tcl_Size objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ { ListRep listRep; @@ -1153,7 +1153,7 @@ Tcl_NewListObj( Tcl_Obj * Tcl_DbNewListObj( - ListSizeT objc, /* Count of objects referenced by objv. */ + Tcl_Size objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[], /* An array of pointers to Tcl objects. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ @@ -1179,7 +1179,7 @@ Tcl_DbNewListObj( Tcl_Obj * Tcl_DbNewListObj( - ListSizeT objc, /* Count of objects referenced by objv. */ + Tcl_Size objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[], /* An array of pointers to Tcl objects. */ TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) @@ -1209,15 +1209,15 @@ Tcl_DbNewListObj( */ Tcl_Obj * TclNewListObj2( - ListSizeT objc1, /* Count of objects referenced by objv1. */ + Tcl_Size objc1, /* Count of objects referenced by objv1. */ Tcl_Obj *const objv1[], /* First array of pointers to Tcl objects. */ - ListSizeT objc2, /* Count of objects referenced by objv2. */ + Tcl_Size objc2, /* Count of objects referenced by objv2. */ Tcl_Obj *const objv2[] /* Second array of pointers to Tcl objects. */ ) { Tcl_Obj *listObj; ListStore *storePtr; - ListSizeT objc = objc1 + objc2; + Tcl_Size objc = objc1 + objc2; listObj = Tcl_NewListObj(objc, NULL); if (objc == 0) { @@ -1313,7 +1313,7 @@ TclListObjGetRep( void Tcl_SetListObj( Tcl_Obj *objPtr, /* Object whose internal rep to init. */ - ListSizeT objc, /* Count of objects referenced by objv. */ + Tcl_Size objc, /* Count of objects referenced by objv. */ Tcl_Obj *const objv[]) /* An array of pointers to Tcl objects. */ { if (Tcl_IsShared(objPtr)) { @@ -1413,17 +1413,17 @@ TclListObjCopy( static void ListRepRange( ListRep *srcRepPtr, /* Contains source of the range */ - ListSizeT rangeStart, /* Index of first element to include */ - ListSizeT rangeEnd, /* Index of last element to include */ + Tcl_Size rangeStart, /* Index of first element to include */ + Tcl_Size rangeEnd, /* Index of last element to include */ int preserveSrcRep, /* If true, srcRepPtr contents must not be modified (generally because a shared Tcl_Obj references it) */ ListRep *rangeRepPtr) /* Output. Must NOT be == srcRepPtr */ { Tcl_Obj **srcElems; - ListSizeT numSrcElems = ListRepLength(srcRepPtr); - ListSizeT rangeLen; - ListSizeT numAfterRangeEnd; + Tcl_Size numSrcElems = ListRepLength(srcRepPtr); + Tcl_Size rangeLen; + Tcl_Size numAfterRangeEnd; LISTREP_CHECK(srcRepPtr); @@ -1490,7 +1490,7 @@ ListRepRange( srcRepPtr->storePtr->numUsed, srcRepPtr->storePtr->numAllocated)) { /* Option 2 - because span would be most efficient */ - ListSizeT spanStart = ListRepStart(srcRepPtr) + rangeStart; + Tcl_Size spanStart = ListRepStart(srcRepPtr) + rangeStart; if (!preserveSrcRep && srcRepPtr->spanPtr && srcRepPtr->spanPtr->refCount <= 1) { /* If span is not shared reuse it */ @@ -1602,8 +1602,8 @@ ListRepRange( Tcl_Obj * TclListObjRange( Tcl_Obj *listObj, /* List object to take a range from. */ - ListSizeT rangeStart, /* Index of first element to include. */ - ListSizeT rangeEnd) /* Index of last element to include. */ + Tcl_Size rangeStart, /* Index of first element to include. */ + Tcl_Size rangeEnd) /* Index of last element to include. */ { ListRep listRep; ListRep resultRep; @@ -1660,7 +1660,7 @@ Tcl_ListObjGetElements( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *objPtr, /* List object for which an element array is * to be returned. */ - ListSizeT *objcPtr, /* Where to store the count of objects + Tcl_Size *objcPtr, /* Where to store the count of objects * referenced by objv. */ Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of * pointers to the list's objects. */ @@ -1705,7 +1705,7 @@ Tcl_ListObjAppendList( Tcl_Obj *toObj, /* List object to append elements to. */ Tcl_Obj *fromObj) /* List obj with elements to append. */ { - ListSizeT objc; + Tcl_Size objc; Tcl_Obj **objv; if (Tcl_IsShared(toObj)) { @@ -1749,13 +1749,13 @@ Tcl_ListObjAppendList( int TclListObjAppendElements ( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *toObj, /* List object to append */ - ListSizeT elemCount, /* Number of elements in elemObjs[] */ + Tcl_Size elemCount, /* Number of elements in elemObjs[] */ Tcl_Obj * const elemObjv[]) /* Objects to append to toObj's list. */ { ListRep listRep; Tcl_Obj **toObjv; - ListSizeT toLen; - ListSizeT finalLen; + Tcl_Size toLen; + Tcl_Size finalLen; if (Tcl_IsShared(toObj)) { Tcl_Panic("%s called with shared object", "TclListObjAppendElements"); @@ -1780,7 +1780,7 @@ Tcl_ListObjAppendList( * reference counts on the elements which is a substantial cost * if the list is not small. */ - ListSizeT numTailFree; + Tcl_Size numTailFree; ListRepFreeUnreferenced(&listRep); /* Collect garbage before checking room */ @@ -1812,7 +1812,7 @@ Tcl_ListObjAppendList( if (numTailFree < elemCount) { /* Not enough room at back. Move some to front */ /* T:listrep-3.5 */ - ListSizeT shiftCount = elemCount - numTailFree; + Tcl_Size shiftCount = elemCount - numTailFree; /* Divide remaining space between front and back */ shiftCount += (listRep.storePtr->numAllocated - finalLen) / 2; LIST_ASSERT(shiftCount <= listRep.storePtr->firstUsed); @@ -1940,11 +1940,11 @@ int Tcl_ListObjIndex( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *listObj, /* List object to index into. */ - ListSizeT index, /* Index of element to return. */ + Tcl_Size index, /* Index of element to return. */ Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */ { Tcl_Obj **elemObjs; - ListSizeT numElems; + Tcl_Size numElems; /* * TODO @@ -1993,7 +1993,7 @@ int Tcl_ListObjLength( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *listObj, /* List object whose #elements to return. */ - ListSizeT *lenPtr) /* The resulting int is stored here. */ + Tcl_Size *lenPtr) /* The resulting int is stored here. */ { ListRep listRep; @@ -2057,17 +2057,17 @@ int Tcl_ListObjReplace( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *listObj, /* List object whose elements to replace. */ - ListSizeT first, /* Index of first element to replace. */ - ListSizeT numToDelete, /* Number of elements to replace. */ - ListSizeT numToInsert, /* Number of objects to insert. */ + Tcl_Size first, /* Index of first element to replace. */ + Tcl_Size numToDelete, /* Number of elements to replace. */ + Tcl_Size numToInsert, /* Number of objects to insert. */ Tcl_Obj *const insertObjs[])/* Tcl objects to insert */ { ListRep listRep; - ListSizeT origListLen; + Tcl_Size origListLen; int lenChange; int leadSegmentLen; int tailSegmentLen; - ListSizeT numFreeSlots; + Tcl_Size numFreeSlots; int leadShift; int tailShift; Tcl_Obj **listObjs; @@ -2186,7 +2186,7 @@ Tcl_ListObjReplace( ListRepStart(&listRep) == listRep.storePtr->firstUsed && /* (ii) */ numToInsert <= listRep.storePtr->firstUsed /* (iii) */ ) { - ListSizeT newLen; + Tcl_Size newLen; LIST_ASSERT(numToInsert); /* Else would have returned above */ listRep.storePtr->firstUsed -= numToInsert; ObjArrayCopy(&listRep.storePtr->slots[listRep.storePtr->firstUsed], @@ -2393,7 +2393,7 @@ Tcl_ListObjReplace( if (finalFreeSpace > 1 && (tailSpace == 0 || tailSegmentLen == 0)) { int postShiftLeadSpace = leadSpace - lenChange; if (postShiftLeadSpace > (finalFreeSpace/2)) { - ListSizeT extraShift = postShiftLeadSpace - (finalFreeSpace / 2); + Tcl_Size extraShift = postShiftLeadSpace - (finalFreeSpace / 2); leadShift -= extraShift; tailShift = -extraShift; /* Move tail to the front as well */ } @@ -2411,7 +2411,7 @@ Tcl_ListObjReplace( int postShiftTailSpace = tailSpace - lenChange; if (postShiftTailSpace > (finalFreeSpace/2)) { /* T:listrep-1.{1,3,14,18,21},3.{2,3,26,27} */ - ListSizeT extraShift = postShiftTailSpace - (finalFreeSpace / 2); + Tcl_Size extraShift = postShiftTailSpace - (finalFreeSpace / 2); tailShift += extraShift; leadShift = extraShift; /* Move head to the back as well */ } @@ -2456,7 +2456,7 @@ Tcl_ListObjReplace( /* Will happen when we have to make room at bottom */ if (tailShift != 0 && tailSegmentLen != 0) { /* T:listrep-1.{1,3,14,18},3.{2,3,26,27} */ - ListSizeT tailStart = leadSegmentLen + numToDelete; + Tcl_Size tailStart = leadSegmentLen + numToDelete; memmove(&listObjs[tailStart + tailShift], &listObjs[tailStart], tailSegmentLen * sizeof(Tcl_Obj *)); @@ -2476,7 +2476,7 @@ Tcl_ListObjReplace( } if (tailShift != 0 && tailSegmentLen != 0) { /* T:listrep-1.{7,17},3.{8:11,13,14,21,22,35,37,39:41} */ - ListSizeT tailStart = leadSegmentLen + numToDelete; + Tcl_Size tailStart = leadSegmentLen + numToDelete; memmove(&listObjs[tailStart + tailShift], &listObjs[tailStart], tailSegmentLen * sizeof(Tcl_Obj *)); @@ -2546,10 +2546,10 @@ TclLindexList( Tcl_Obj *listObj, /* List being unpacked. */ Tcl_Obj *argObj) /* Index or index list. */ { - ListSizeT index; /* Index into the list. */ + Tcl_Size index; /* Index into the list. */ Tcl_Obj *indexListCopy; Tcl_Obj **indexObjs; - ListSizeT numIndexObjs; + Tcl_Size numIndexObjs; /* * Determine whether argPtr designates a list or a single index. We have @@ -2623,16 +2623,16 @@ Tcl_Obj * TclLindexFlat( Tcl_Interp *interp, /* Tcl interpreter. */ Tcl_Obj *listObj, /* Tcl object representing the list. */ - ListSizeT indexCount, /* Count of indices. */ + Tcl_Size indexCount, /* Count of indices. */ Tcl_Obj *const indexArray[])/* Array of pointers to Tcl objects that * represent the indices in the list. */ { - ListSizeT i; + Tcl_Size i; /* Handle ArithSeries as special case */ if (TclHasInternalRep(listObj,&tclArithSeriesType)) { Tcl_WideInt listLen = TclArithSeriesObjLength(listObj); - ListSizeT index; + Tcl_Size index; Tcl_Obj *elemObj = NULL; for (i=0 ; i Date: Sun, 23 Oct 2022 10:44:39 +0000 Subject: Update rules.vc to version 11 (with TIP #628 support) --- win/rules.vc | 34 +++++++++++++++++++++++++++++++--- 1 file changed, 31 insertions(+), 3 deletions(-) diff --git a/win/rules.vc b/win/rules.vc index fdc68e0..89a72ce 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -24,7 +24,7 @@ _RULES_VC = 1 # For modifications that are not backward-compatible, you *must* change # the major version. RULES_VERSION_MAJOR = 1 -RULES_VERSION_MINOR = 10 +RULES_VERSION_MINOR = 11 # The PROJECT macro must be defined by parent makefile. !if "$(PROJECT)" == "" @@ -877,6 +877,11 @@ TCL_THREADS = 0 USE_THREAD_ALLOC= 0 !endif +!if [nmakehlp -f $(OPTS) "tcl8"] +!message *** Build for Tcl8 +TCL_BUILD_FOR = 8 +!endif + !if $(TCL_MAJOR_VERSION) == 8 !if [nmakehlp -f $(OPTS) "time64bit"] !message *** Force 64-bit time_t @@ -1146,7 +1151,11 @@ TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) TCLSCRIPTZIP = $(OUT_DIR)\$(TCLSCRIPTZIPNAME) +!if $(TCL_MAJOR_VERSION) == 8 TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib +!else +TCLSTUBLIBNAME = $(STUBPREFIX).lib +!endif TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) TCL_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" @@ -1162,7 +1171,11 @@ TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX:t=).exe TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX:t=).exe !endif +!if $(TCL_MAJOR_VERSION) == 8 TCLSTUBLIB = $(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib +!else +TCLSTUBLIB = $(_TCLDIR)\lib\tclstub.lib +!endif TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX:t=).lib # When building extensions, may be linking against Tcl that does not add # "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. @@ -1182,7 +1195,11 @@ TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX:t=).exe !if !exist($(TCLSH)) TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX:t=).exe !endif +!if $(TCL_MAJOR_VERSION) == 8 TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib +!else +TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub.lib +!endif TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX:t=).lib # When building extensions, may be linking against Tcl that does not add # "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility. @@ -1198,7 +1215,11 @@ TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win" !endif # TCLINSTALL +!if !$(STATIC_BUILD) && "$(TCL_BUILD_FOR)" == "8" +tcllibs = "$(TCLSTUBLIB)" +!else tcllibs = "$(TCLSTUBLIB)" "$(TCLIMPLIB)" +!endif !endif # $(DOING_TCL) @@ -1218,7 +1239,7 @@ WISHNAMEPREFIX = wish WISHNAME = $(WISHNAMEPREFIX)$(TK_VERSION)$(SUFX).exe TKLIBNAME8 = tk$(TK_VERSION)$(SUFX).$(EXT) TKLIBNAME9 = tcl9tk$(TK_VERSION)$(SUFX).$(EXT) -!if $(TCL_MAJOR_VERSION) == 8 +!if $(TCL_MAJOR_VERSION) == 8 || "$(TCL_BUILD_FOR)" == "8" TKLIBNAME = tk$(TK_VERSION)$(SUFX).$(EXT) TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX).lib !else @@ -1275,14 +1296,18 @@ tklibs = "$(TKSTUBLIB)" "$(TKIMPLIB)" PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib PRJLIBNAME8 = $(PROJECT)$(VERSION)$(SUFX).$(EXT) PRJLIBNAME9 = tcl9$(PROJECT)$(VERSION)$(SUFX).$(EXT) -!if $(TCL_MAJOR_VERSION) == 8 +!if $(TCL_MAJOR_VERSION) == 8 || "$(TCL_BUILD_FOR)" == "8" PRJLIBNAME = $(PRJLIBNAME8) !else PRJLIBNAME = $(PRJLIBNAME9) !endif PRJLIB = $(OUT_DIR)\$(PRJLIBNAME) +!if $(TCL_MAJOR_VERSION) == 8 PRJSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib +!else +PRJSTUBLIBNAME = $(STUBPREFIX).lib +!endif PRJSTUBLIB = $(OUT_DIR)\$(PRJSTUBLIBNAME) # If extension parent makefile has not defined a resource definition file, @@ -1429,6 +1454,9 @@ COMPILERFLAGS = /D_ATL_XP_TARGETING !if "$(TCL_UTF_MAX)" == "3" OPTDEFINES = $(OPTDEFINES) /DTCL_UTF_MAX=3 !endif +!if "$(TCL_BUILD_FOR)" == "8" +OPTDEFINES = $(OPTDEFINES) /DTCL_MAJOR_VERSION=8 +!endif # Like the TEA system only set this non empty for non-Tk extensions # Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME -- cgit v0.12 From 649be23ea62274f8e19a6019d3ec476470fb9206 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 23 Oct 2022 14:08:49 +0000 Subject: Change back some Tcl_Size usage to size_t (e.g. in MODULE_SCOPE definitions, which are not supported by TIP #628) --- generic/tcl.decls | 2 +- generic/tclCompile.h | 42 +++++++++-------- generic/tclInt.h | 122 +++++++++++++++++++++++++------------------------ generic/tclPlatDecls.h | 4 +- 4 files changed, 87 insertions(+), 83 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 23b9b0c..690fcfd 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2630,7 +2630,7 @@ interface tclPlat declare 1 { int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, - int hasResourceFile, Tcl_Size maxPathLen, char *libraryPath) + int hasResourceFile, size_t maxPathLen, char *libraryPath) } declare 2 { void Tcl_MacOSXNotifierAddRunLoopMode(const void *runLoopMode) diff --git a/generic/tclCompile.h b/generic/tclCompile.h index d86faef..b88fa4c 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1062,6 +1062,7 @@ typedef struct { *---------------------------------------------------------------- */ +#if TCL_MAJOR_VERSION > 8 MODULE_SCOPE Tcl_ObjCmdProc TclNRInterpCoroutine; /* @@ -1081,38 +1082,38 @@ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr, */ MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Tcl_Size depth, Command *cmdPtr, + Tcl_Parse *parsePtr, size_t depth, Command *cmdPtr, CompileEnv *envPtr); MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, ExceptionAux *auxPtr); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, - Tcl_Token *tokenPtr, Tcl_Size count, + Tcl_Token *tokenPtr, size_t count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script, - Tcl_Size numBytes, CompileEnv *envPtr, int optimize); + size_t numBytes, CompileEnv *envPtr, int optimize); MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp, - Tcl_Token *tokenPtr, Tcl_Size numWords, + Tcl_Token *tokenPtr, size_t numWords, CompileEnv *envPtr); MODULE_SCOPE void TclCompileInvocation(Tcl_Interp *interp, - Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, Tcl_Size numWords, + Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, size_t numWords, CompileEnv *envPtr); MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp, - const char *script, Tcl_Size numBytes, + const char *script, size_t numBytes, CompileEnv *envPtr); MODULE_SCOPE void TclCompileSyntaxError(Tcl_Interp *interp, CompileEnv *envPtr); MODULE_SCOPE void TclCompileTokens(Tcl_Interp *interp, - Tcl_Token *tokenPtr, Tcl_Size count, + Tcl_Token *tokenPtr, size_t count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp, Tcl_Token *tokenPtr, CompileEnv *envPtr); -MODULE_SCOPE Tcl_Size TclCreateAuxData(void *clientData, +MODULE_SCOPE size_t TclCreateAuxData(void *clientData, const AuxDataType *typePtr, CompileEnv *envPtr); -MODULE_SCOPE Tcl_Size TclCreateExceptRange(ExceptionRangeType type, +MODULE_SCOPE size_t TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); -MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, Tcl_Size size); +MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, size_t size); MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes, - Tcl_Size length, TCL_HASH_TYPE hash, int *newPtr, + size_t length, TCL_HASH_TYPE hash, int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr); MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr); @@ -1127,7 +1128,7 @@ MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, ByteCode *codePtr); MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, TCL_HASH_TYPE index); -MODULE_SCOPE Tcl_Size TclFindCompiledLocal(const char *name, Tcl_Size nameChars, +MODULE_SCOPE size_t TclFindCompiledLocal(const char *name, size_t nameChars, int create, CompileEnv *envPtr); MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, JumpFixup *jumpFixupPtr, int jumpDist, @@ -1135,13 +1136,13 @@ MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr, - Tcl_Size before, Tcl_Size after, int *indexPtr); + size_t before, size_t after, int *indexPtr); MODULE_SCOPE ByteCode * TclInitByteCode(CompileEnv *envPtr); MODULE_SCOPE ByteCode * TclInitByteCodeObj(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, CompileEnv *envPtr); MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr, const char *string, - Tcl_Size numBytes, const CmdFrame *invoker, int word); + size_t numBytes, const CmdFrame *invoker, int word); MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr); MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr, @@ -1156,9 +1157,9 @@ MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr, MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); MODULE_SCOPE int TclLog2(int value); #endif -MODULE_SCOPE Tcl_Size TclLocalScalar(const char *bytes, Tcl_Size numBytes, +MODULE_SCOPE size_t TclLocalScalar(const char *bytes, size_t numBytes, CompileEnv *envPtr); -MODULE_SCOPE Tcl_Size TclLocalScalarFromToken(Tcl_Token *tokenPtr, +MODULE_SCOPE size_t TclLocalScalarFromToken(Tcl_Token *tokenPtr, CompileEnv *envPtr); MODULE_SCOPE void TclOptimizeBytecode(void *envPtr); #ifdef TCL_COMPILE_DEBUG @@ -1168,9 +1169,9 @@ MODULE_SCOPE void TclPrintByteCodeObj(Tcl_Interp *interp, MODULE_SCOPE int TclPrintInstruction(ByteCode *codePtr, const unsigned char *pc); MODULE_SCOPE void TclPrintObject(FILE *outFile, - Tcl_Obj *objPtr, Tcl_Size maxChars); + Tcl_Obj *objPtr, size_t maxChars); MODULE_SCOPE void TclPrintSource(FILE *outFile, - const char *string, Tcl_Size maxChars); + const char *string, size_t maxChars); MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, @@ -1192,14 +1193,15 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr, Tcl_Obj *valuePtr); MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp, const char *script, const char *command, - Tcl_Size length, const unsigned char *pc, + size_t length, const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); MODULE_SCOPE int TclPushProcCallFrame(void *clientData, - Tcl_Interp *interp, Tcl_Size objc, + Tcl_Interp *interp, size_t objc, Tcl_Obj *const objv[], int isLambda); +#endif /* TCL_MAJOR_VERSION > 8 */ /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 3bbbf39..5cdd9b4 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3017,13 +3017,14 @@ struct Tcl_LoadHandle_ { *---------------------------------------------------------------- */ +#if TCL_MAJOR_VERSION > 8 MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, - const unsigned char *bytes, Tcl_Size len); + const unsigned char *bytes, size_t len); MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); -MODULE_SCOPE void TclAdvanceContinuations(Tcl_Size *line, int **next, +MODULE_SCOPE void TclAdvanceContinuations(size_t *line, int **next, int loc); -MODULE_SCOPE void TclAdvanceLines(Tcl_Size *line, const char *start, +MODULE_SCOPE void TclAdvanceLines(size_t *line, const char *start, const char *end); MODULE_SCOPE void TclArgumentEnter(Tcl_Interp *interp, Tcl_Obj *objv[], int objc, CmdFrame *cf); @@ -3031,7 +3032,7 @@ MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp, Tcl_Obj *objv[], int objc); MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp, Tcl_Obj *objv[], int objc, - void *codePtr, CmdFrame *cfPtr, int cmd, Tcl_Size pc); + void *codePtr, CmdFrame *cfPtr, int cmd, size_t pc); MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, CmdFrame *cfPtr); MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, @@ -3041,8 +3042,8 @@ MODULE_SCOPE int TclAsyncNotifier(int sigNumber, Tcl_ThreadId threadId, MODULE_SCOPE void TclAsyncMarkFromNotifier(void); MODULE_SCOPE double TclBignumToDouble(const void *bignum); MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, - Tcl_Size strLen, const unsigned char *pattern, - Tcl_Size ptnLen, int flags); + size_t strLen, const unsigned char *pattern, + size_t ptnLen, int flags); MODULE_SCOPE double TclCeil(const void *a); MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan); MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan); @@ -3055,14 +3056,14 @@ MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); -MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, Tcl_Size num, +MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, size_t num, int *loc); MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, int start, int *clNext); MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr); MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr, Tcl_Obj *originObjPtr); -MODULE_SCOPE Tcl_Size TclConvertElement(const char *src, Tcl_Size length, +MODULE_SCOPE size_t TclConvertElement(const char *src, size_t length, char *dst, int flags); MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs(Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *nsPtr, @@ -3074,12 +3075,12 @@ MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp, MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE void TclDeleteNamespaceChildren(Namespace *nsPtr); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, - const char *dict, Tcl_Size dictLength, + const char *dict, size_t dictLength, const char **elementPtr, const char **nextPtr, - Tcl_Size *sizePtr, int *literalPtr); + size_t *sizePtr, int *literalPtr); /* TIP #280 - Modified token based evaluation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, - Tcl_Size numBytes, int flags, Tcl_Size line, + size_t numBytes, int flags, size_t line, int *clNextOuter, const char *outerScript); MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd; @@ -3102,7 +3103,7 @@ MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, Tcl_DString *toAppendPtr); MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp, - Tcl_Obj *const *objv, Tcl_Size objc, Tcl_Size *objcPtr); + Tcl_Obj *const *objv, size_t objc, size_t *objcPtr); MODULE_SCOPE Tcl_Obj *const *TclEnsembleGetRewriteValues(Tcl_Interp *interp); MODULE_SCOPE Tcl_Namespace *TclEnsureNamespace(Tcl_Interp *interp, Tcl_Namespace *namespacePtr); @@ -3186,7 +3187,7 @@ MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); MODULE_SCOPE int TclIsDigitProc(int byte); MODULE_SCOPE int TclIsBareword(int byte); -MODULE_SCOPE Tcl_Obj * TclJoinPath(Tcl_Size elements, Tcl_Obj * const objv[], +MODULE_SCOPE Tcl_Obj * TclJoinPath(size_t elements, Tcl_Obj * const objv[], int forceRelative); MODULE_SCOPE int MakeTildeRelativePath(Tcl_Interp *interp, const char *user, const char *subPath, Tcl_DString *dsPtr); @@ -3199,25 +3200,25 @@ MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *argPtr); MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, - Tcl_Size indexCount, Tcl_Obj *const indexArray[]); + size_t indexCount, Tcl_Obj *const indexArray[]); /* TIP #280 */ -MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, Tcl_Size line, int n, +MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, size_t line, int n, int *lines, Tcl_Obj *const *elems); MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); MODULE_SCOPE int TclListObjAppendElements(Tcl_Interp *interp, - Tcl_Obj *toObj, Tcl_Size elemCount, + Tcl_Obj *toObj, size_t elemCount, Tcl_Obj *const elemObjv[]); -MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Obj *listPtr, Tcl_Size fromIdx, - Tcl_Size toIdx); +MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Obj *listPtr, size_t fromIdx, + size_t toIdx); MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *indexPtr, Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, - Tcl_Size indexCount, Tcl_Obj *const indexArray[], + size_t indexCount, Tcl_Obj *const indexArray[], Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name, const EnsembleImplMap map[]); MODULE_SCOPE int TclMakeSafe(Tcl_Interp *interp); -MODULE_SCOPE int TclMaxListLength(const char *bytes, Tcl_Size numBytes, +MODULE_SCOPE int TclMaxListLength(const char *bytes, size_t numBytes, const char **endPtr); MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, @@ -3236,15 +3237,15 @@ MODULE_SCOPE int TclObjInvokeNamespace(Tcl_Interp *interp, MODULE_SCOPE int TclObjUnsetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); MODULE_SCOPE int TclParseBackslash(const char *src, - Tcl_Size numBytes, Tcl_Size *readPtr, char *dst); -MODULE_SCOPE int TclParseHex(const char *src, Tcl_Size numBytes, + size_t numBytes, size_t *readPtr, char *dst); +MODULE_SCOPE int TclParseHex(const char *src, size_t numBytes, int *resultPtr); MODULE_SCOPE int TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *expected, const char *bytes, - Tcl_Size numBytes, const char **endPtrPtr, int flags); + size_t numBytes, const char **endPtrPtr, int flags); MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string, - Tcl_Size numBytes, Tcl_Parse *parsePtr); -MODULE_SCOPE Tcl_Size TclParseAllWhiteSpace(const char *src, Tcl_Size numBytes); + size_t numBytes, Tcl_Parse *parsePtr); +MODULE_SCOPE size_t TclParseAllWhiteSpace(const char *src, size_t numBytes); MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); @@ -3252,7 +3253,7 @@ MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, - Tcl_Size len); + size_t len); MODULE_SCOPE void TclpAlertNotifier(void *clientData); MODULE_SCOPE void *TclpNotifierData(void); MODULE_SCOPE void TclpServiceModeHook(int mode); @@ -3273,8 +3274,8 @@ MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, const char **errorMsgPtr); MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, - Tcl_Size stackSize, int flags); -MODULE_SCOPE Tcl_Size TclpFindVariable(const char *name, Tcl_Size *lengthPtr); + size_t stackSize, int flags); +MODULE_SCOPE size_t TclpFindVariable(const char *name, size_t *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); @@ -3289,9 +3290,9 @@ MODULE_SCOPE int TclpMatchFiles(Tcl_Interp *interp, char *separators, MODULE_SCOPE int TclpObjNormalizePath(Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint); MODULE_SCOPE void TclpNativeJoinPath(Tcl_Obj *prefix, const char *joining); -MODULE_SCOPE Tcl_Obj * TclpNativeSplitPath(Tcl_Obj *pathPtr, Tcl_Size *lenPtr); +MODULE_SCOPE Tcl_Obj * TclpNativeSplitPath(Tcl_Obj *pathPtr, size_t *lenPtr); MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr, - Tcl_Size *driveNameLengthPtr, Tcl_Obj **driveNameRef); + size_t *driveNameLengthPtr, Tcl_Obj **driveNameRef); MODULE_SCOPE int TclCrossFilesystemCopy(Tcl_Interp *interp, Tcl_Obj *source, Tcl_Obj *target); MODULE_SCOPE int TclpMatchInDirectory(Tcl_Interp *interp, @@ -3322,9 +3323,9 @@ MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id); MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex); MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, - Tcl_Size reStrLen, Tcl_DString *dsPtr, int *flagsPtr, + size_t reStrLen, Tcl_DString *dsPtr, int *flagsPtr, int *quantifiersFoundPtr); -MODULE_SCOPE TCL_HASH_TYPE TclScanElement(const char *string, Tcl_Size length, +MODULE_SCOPE TCL_HASH_TYPE TclScanElement(const char *string, size_t length, char *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); @@ -3339,44 +3340,44 @@ MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue, Tcl_Encoding encoding); MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, - Tcl_Obj *const *objv, Tcl_Size objc, Tcl_Size subIdx, + Tcl_Obj *const *objv, size_t objc, size_t subIdx, Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, - Tcl_Size numBytes); + size_t numBytes); typedef int (*memCmpFn_t)(const void*, const void*, size_t); MODULE_SCOPE int TclStringCmp(Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr, - int checkEq, int nocase, Tcl_Size reqlength); + int checkEq, int nocase, size_t reqlength); MODULE_SCOPE int TclStringCmpOpts(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int *nocase, int *reqlength); -MODULE_SCOPE int TclStringMatch(const char *str, Tcl_Size strLen, +MODULE_SCOPE int TclStringMatch(const char *str, size_t strLen, const char *pattern, int ptnLen, int flags); MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, Tcl_Obj *patternObj, int flags); MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes, - Tcl_Size numBytes, int flags, Tcl_Size line, + size_t numBytes, int flags, size_t line, struct CompileEnv *envPtr); -MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, Tcl_Size numOpts, +MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, size_t numOpts, Tcl_Obj *const opts[], int *flagPtr); MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes, - Tcl_Size numBytes, int flags, Tcl_Parse *parsePtr, + size_t numBytes, int flags, Tcl_Parse *parsePtr, Tcl_InterpState *statePtr); MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, - Tcl_Size count, int *tokensLeftPtr, Tcl_Size line, + size_t count, int *tokensLeftPtr, size_t line, int *clNextOuter, const char *outerScript); -MODULE_SCOPE Tcl_Size TclTrim(const char *bytes, Tcl_Size numBytes, - const char *trim, Tcl_Size numTrim, Tcl_Size *trimRight); -MODULE_SCOPE Tcl_Size TclTrimLeft(const char *bytes, Tcl_Size numBytes, - const char *trim, Tcl_Size numTrim); -MODULE_SCOPE Tcl_Size TclTrimRight(const char *bytes, Tcl_Size numBytes, - const char *trim, Tcl_Size numTrim); +MODULE_SCOPE size_t TclTrim(const char *bytes, size_t numBytes, + const char *trim, size_t numTrim, size_t *trimRight); +MODULE_SCOPE size_t TclTrimLeft(const char *bytes, size_t numBytes, + const char *trim, size_t numTrim); +MODULE_SCOPE size_t TclTrimRight(const char *bytes, size_t numBytes, + const char *trim, size_t numTrim); MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command); MODULE_SCOPE void TclRegisterCommandTypeName( Tcl_ObjCmdProc *implementationProc, const char *nameStr); MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); -MODULE_SCOPE Tcl_Size TclUtfCount(int ch); +MODULE_SCOPE size_t TclUtfCount(int ch); #if TCL_UTF_MAX > 3 # define TclUtfToUCS4 Tcl_UtfToUniChar # define TclUniCharToUCS4(src, ptr) (*ptr = *(src),1) @@ -3423,7 +3424,7 @@ MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); MODULE_SCOPE void TclpThreadSetGlobalTSD(void *tsdKeyPtr, void *ptr); MODULE_SCOPE void * TclpThreadGetGlobalTSD(void *tsdKeyPtr); MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, - const char *msg, Tcl_Size length); + const char *msg, size_t length); /* Tip 430 */ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); @@ -3472,7 +3473,7 @@ MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, Tcl_Obj *part2Ptr, int index, int pathc, Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, - Tcl_Size pathc, Tcl_Obj *const pathv[]); + size_t pathc, Tcl_Obj *const pathv[]); MODULE_SCOPE Tcl_ObjCmdProc Tcl_DisassembleObjCmd; /* Assemble command function */ @@ -3998,13 +3999,13 @@ MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, MODULE_SCOPE Tcl_Obj * TclStringCat(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); MODULE_SCOPE Tcl_Obj * TclStringFirst(Tcl_Obj *needle, Tcl_Obj *haystack, - Tcl_Size start); + size_t start); MODULE_SCOPE Tcl_Obj * TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack, - Tcl_Size last); + size_t last); MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr, - Tcl_Size count, int flags); + size_t count, int flags); MODULE_SCOPE Tcl_Obj * TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr, - Tcl_Size first, Tcl_Size count, Tcl_Obj *insertPtr, + size_t first, size_t count, Tcl_Obj *insertPtr, int flags); MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr, int flags); @@ -4072,11 +4073,11 @@ MODULE_SCOPE int TclFullFinalizationRequested(void); * TIP #542 */ -MODULE_SCOPE Tcl_Size TclUniCharLen(const Tcl_UniChar *uniStr); +MODULE_SCOPE size_t TclUniCharLen(const Tcl_UniChar *uniStr); MODULE_SCOPE int TclUniCharNcmp(const Tcl_UniChar *ucs, - const Tcl_UniChar *uct, Tcl_Size numChars); + const Tcl_UniChar *uct, size_t numChars); MODULE_SCOPE int TclUniCharNcasecmp(const Tcl_UniChar *ucs, - const Tcl_UniChar *uct, Tcl_Size numChars); + const Tcl_UniChar *uct, size_t numChars); MODULE_SCOPE int TclUniCharCaseMatch(const Tcl_UniChar *uniStr, const Tcl_UniChar *uniPattern, int nocase); @@ -4131,8 +4132,9 @@ MODULE_SCOPE Tcl_Obj * TclGetArrayDefault(Var *arrayPtr); */ MODULE_SCOPE int TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr, - Tcl_Size before, Tcl_Size after, int *indexPtr); -MODULE_SCOPE Tcl_Size TclIndexDecode(int encoded, Tcl_Size endValue); + size_t before, size_t after, int *indexPtr); +MODULE_SCOPE size_t TclIndexDecode(int encoded, size_t endValue); +#endif /* TCL_MAJOR_VERSION > 8 */ /* Constants used in index value encoding routines. */ #define TCL_INDEX_END ((Tcl_Size)-2) @@ -4408,7 +4410,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, * * The ANSI C "prototype" for this macro is: * - * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, Tcl_Size len); + * MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, size_t len); * *---------------------------------------------------------------- */ @@ -4769,7 +4771,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; * * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d); - * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, Tcl_Size len); + * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, size_t len); * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral); * *---------------------------------------------------------------- diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index 1c60bf8..10d3094 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -151,7 +151,7 @@ extern "C" { EXTERN int Tcl_MacOSXOpenVersionedBundleResources( Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, - int hasResourceFile, Tcl_Size maxPathLen, + int hasResourceFile, size_t maxPathLen, char *libraryPath); /* 2 */ EXTERN void Tcl_MacOSXNotifierAddRunLoopMode( @@ -164,7 +164,7 @@ typedef struct TclPlatStubs { void *hooks; void (*reserved0)(void); - int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, Tcl_Size maxPathLen, char *libraryPath); /* 1 */ + int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, size_t maxPathLen, char *libraryPath); /* 1 */ void (*tcl_MacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 2 */ void (*tcl_WinConvertError) (unsigned errCode); /* 3 */ } TclPlatStubs; -- cgit v0.12 From 1f58beed10dd10570b37d1f8e54391bcf1fb7f7c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 23 Oct 2022 14:32:54 +0000 Subject: Change back some Tcl_Size usages to int (e.g. in MODULE_SCOPE definitions) --- generic/tcl.decls | 4 +- generic/tclCompile.h | 52 +++++++++---------- generic/tclInt.h | 133 ++++++++++++++++++++++++------------------------- generic/tclPlatDecls.h | 4 +- 4 files changed, 94 insertions(+), 99 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 49f2b2c..a85c723 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2591,7 +2591,7 @@ declare 0 macosx { declare 1 macosx { int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, - int hasResourceFile, Tcl_Size maxPathLen, char *libraryPath) + int hasResourceFile, int maxPathLen, char *libraryPath) } declare 2 macosx { void Tcl_MacOSXNotifierAddRunLoopMode(const void *runLoopMode) @@ -2602,7 +2602,7 @@ declare 2 macosx { # Public functions that are not accessible via the stubs table. export { - void Tcl_Main(int argc, char **argv, Tcl_AppInitProc *appInitProc) + void Tcl_Main(Tcl_Size argc, char **argv, Tcl_AppInitProc *appInitProc) } export { void Tcl_MainEx(Tcl_Size argc, char **argv, Tcl_AppInitProc *appInitProc, diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 7e062f0..2843ef5 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -217,7 +217,7 @@ typedef struct { * the AuxData structure. */ -typedef void *(AuxDataDupProc) (void *clientData); +typedef void *(AuxDataDupProc) (void *clientData); typedef void (AuxDataFreeProc) (void *clientData); typedef void (AuxDataPrintProc)(void *clientData, Tcl_Obj *appendObj, struct ByteCode *codePtr, @@ -1093,38 +1093,38 @@ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr, */ MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Tcl_Size depth, Command *cmdPtr, + Tcl_Parse *parsePtr, int depth, Command *cmdPtr, CompileEnv *envPtr); MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, ExceptionAux *auxPtr); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, - Tcl_Token *tokenPtr, Tcl_Size count, + Tcl_Token *tokenPtr, int count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script, - Tcl_Size numBytes, CompileEnv *envPtr, int optimize); + int numBytes, CompileEnv *envPtr, int optimize); MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp, - Tcl_Token *tokenPtr, Tcl_Size numWords, + Tcl_Token *tokenPtr, int numWords, CompileEnv *envPtr); MODULE_SCOPE void TclCompileInvocation(Tcl_Interp *interp, - Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, Tcl_Size numWords, + Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords, CompileEnv *envPtr); MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp, - const char *script, Tcl_Size numBytes, + const char *script, int numBytes, CompileEnv *envPtr); MODULE_SCOPE void TclCompileSyntaxError(Tcl_Interp *interp, CompileEnv *envPtr); MODULE_SCOPE void TclCompileTokens(Tcl_Interp *interp, - Tcl_Token *tokenPtr, Tcl_Size count, + Tcl_Token *tokenPtr, int count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp, Tcl_Token *tokenPtr, CompileEnv *envPtr); -MODULE_SCOPE Tcl_Size TclCreateAuxData(void *clientData, +MODULE_SCOPE int TclCreateAuxData(void *clientData, const AuxDataType *typePtr, CompileEnv *envPtr); -MODULE_SCOPE Tcl_Size TclCreateExceptRange(ExceptionRangeType type, +MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); -MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, Tcl_Size size); +MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size); MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes, - Tcl_Size length, TCL_HASH_TYPE hash, int *newPtr, + int length, TCL_HASH_TYPE hash, int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr); MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr); @@ -1139,7 +1139,7 @@ MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, ByteCode *codePtr); MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, TCL_HASH_TYPE index); -MODULE_SCOPE Tcl_Size TclFindCompiledLocal(const char *name, Tcl_Size nameChars, +MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars, int create, CompileEnv *envPtr); MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, JumpFixup *jumpFixupPtr, int jumpDist, @@ -1147,13 +1147,13 @@ MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr, - Tcl_Size before, Tcl_Size after, int *indexPtr); + int before, int after, int *indexPtr); MODULE_SCOPE ByteCode * TclInitByteCode(CompileEnv *envPtr); MODULE_SCOPE ByteCode * TclInitByteCodeObj(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, CompileEnv *envPtr); MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr, const char *string, - Tcl_Size numBytes, const CmdFrame *invoker, int word); + int numBytes, const CmdFrame *invoker, int word); MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr); MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr, @@ -1168,9 +1168,9 @@ MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr, MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); MODULE_SCOPE int TclLog2(int value); #endif -MODULE_SCOPE Tcl_Size TclLocalScalar(const char *bytes, Tcl_Size numBytes, +MODULE_SCOPE int TclLocalScalar(const char *bytes, int numBytes, CompileEnv *envPtr); -MODULE_SCOPE Tcl_Size TclLocalScalarFromToken(Tcl_Token *tokenPtr, +MODULE_SCOPE int TclLocalScalarFromToken(Tcl_Token *tokenPtr, CompileEnv *envPtr); MODULE_SCOPE void TclOptimizeBytecode(void *envPtr); #ifdef TCL_COMPILE_DEBUG @@ -1180,9 +1180,9 @@ MODULE_SCOPE void TclPrintByteCodeObj(Tcl_Interp *interp, MODULE_SCOPE int TclPrintInstruction(ByteCode *codePtr, const unsigned char *pc); MODULE_SCOPE void TclPrintObject(FILE *outFile, - Tcl_Obj *objPtr, Tcl_Size maxChars); + Tcl_Obj *objPtr, int maxChars); MODULE_SCOPE void TclPrintSource(FILE *outFile, - const char *string, Tcl_Size maxChars); + const char *string, int maxChars); MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, @@ -1204,13 +1204,13 @@ MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr, Tcl_Obj *valuePtr); MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp, const char *script, const char *command, - Tcl_Size length, const unsigned char *pc, + int length, const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); MODULE_SCOPE int TclPushProcCallFrame(void *clientData, - Tcl_Interp *interp, Tcl_Size objc, + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int isLambda); @@ -1543,7 +1543,7 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, * these macros are: * * static void PushLiteral(CompileEnv *envPtr, - * const char *string, Tcl_Size length); + * const char *string, int length); * static void PushStringLiteral(CompileEnv *envPtr, * const char *string); */ @@ -1580,9 +1580,9 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, * of LOOP ranges is an interesting datum for debugging purposes, and that is * what we compute now. * - * static int ExceptionRangeStarts(CompileEnv *envPtr, Tcl_Size index); - * static void ExceptionRangeEnds(CompileEnv *envPtr, Tcl_Size index); - * static void ExceptionRangeTarget(CompileEnv *envPtr, Tcl_Size index, LABEL); + * static int ExceptionRangeStarts(CompileEnv *envPtr, int index); + * static void ExceptionRangeEnds(CompileEnv *envPtr, int index); + * static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL); */ #define ExceptionRangeStarts(envPtr, index) \ @@ -1641,7 +1641,7 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, #define DefineLineInformation \ ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ - Tcl_Size eclIndex = mapPtr->nuloc - 1 + int eclIndex = mapPtr->nuloc - 1 #define SetLineInformation(word) \ envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ diff --git a/generic/tclInt.h b/generic/tclInt.h index 45a41ab..40cf10c 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -290,7 +290,7 @@ typedef struct Namespace { * NULL, there are no children. */ #endif unsigned long nsId; /* Unique id for the namespace. */ - Tcl_Interp *interp; /* The interpreter containing this + Tcl_Interp *interp; /* The interpreter containing this * namespace. */ int flags; /* OR-ed combination of the namespace status * flags NS_DYING and NS_DEAD listed below. */ @@ -1485,9 +1485,9 @@ typedef struct CoroutineData { * numLevels of the create/resume command is * stored here; for suspended coroutines it * holds the nesting numLevels at yield. */ - int nargs; /* Number of args required for resuming this - * coroutine; -2 means "0 or 1" (default), -1 - * means "any" */ + Tcl_Size nargs; /* Number of args required for resuming this + * coroutine; COROUTINE_ARGUMENTS_SINGLE_OPTIONAL means "0 or 1" + * (default), COROUTINE_ARGUMENTS_ARBITRARY means "any" */ Tcl_Obj *yieldPtr; /* The command to yield to. Stored here in * order to reset splice point in * TclNRCoroutineActivateCallback if the @@ -1871,7 +1871,6 @@ typedef struct Interp { * contains one optimizer, which can be * selectively overridden by extensions. */ } extra; - /* * Information related to procedures and variables. See tclProc.c and * tclVar.c for usage. @@ -2439,17 +2438,13 @@ typedef enum TclEolTranslation { #define TCL_INVOKE_NO_TRACEBACK (1<<2) #if TCL_MAJOR_VERSION > 8 - /* * SSIZE_MAX, NOT SIZE_MAX as negative differences need to be expressed * between values of the Tcl_Size type so limit the range to signed */ -#define ListSizeT_MAX ((Tcl_Size)PTRDIFF_MAX) - +# define ListSizeT_MAX ((Tcl_Size)PTRDIFF_MAX) #else - -#define ListSizeT_MAX INT_MAX - +# define ListSizeT_MAX INT_MAX #endif /* @@ -3049,12 +3044,12 @@ struct Tcl_LoadHandle_ { */ MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr, - const unsigned char *bytes, Tcl_Size len); + const unsigned char *bytes, int len); MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); -MODULE_SCOPE void TclAdvanceContinuations(Tcl_Size *line, int **next, +MODULE_SCOPE void TclAdvanceContinuations(int *line, int **next, int loc); -MODULE_SCOPE void TclAdvanceLines(Tcl_Size *line, const char *start, +MODULE_SCOPE void TclAdvanceLines(int *line, const char *start, const char *end); MODULE_SCOPE void TclArgumentEnter(Tcl_Interp *interp, Tcl_Obj *objv[], int objc, CmdFrame *cf); @@ -3062,7 +3057,7 @@ MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp, Tcl_Obj *objv[], int objc); MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp, Tcl_Obj *objv[], int objc, - void *codePtr, CmdFrame *cfPtr, int cmd, Tcl_Size pc); + void *codePtr, CmdFrame *cfPtr, int cmd, int pc); MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp, CmdFrame *cfPtr); MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj, @@ -3072,8 +3067,8 @@ MODULE_SCOPE int TclAsyncNotifier(int sigNumber, Tcl_ThreadId threadId, MODULE_SCOPE void TclAsyncMarkFromNotifier(void); MODULE_SCOPE double TclBignumToDouble(const void *bignum); MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, - Tcl_Size strLen, const unsigned char *pattern, - Tcl_Size ptnLen, int flags); + int strLen, const unsigned char *pattern, + int ptnLen, int flags); MODULE_SCOPE double TclCeil(const void *a); MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan); MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan); @@ -3088,14 +3083,14 @@ MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); -MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, Tcl_Size num, +MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num, int *loc); MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, int start, int *clNext); MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr); MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr, Tcl_Obj *originObjPtr); -MODULE_SCOPE Tcl_Size TclConvertElement(const char *src, Tcl_Size length, +MODULE_SCOPE int TclConvertElement(const char *src, int length, char *dst, int flags); MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs(Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *nsPtr, @@ -3107,12 +3102,12 @@ MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp, MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE void TclDeleteNamespaceChildren(Namespace *nsPtr); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, - const char *dict, Tcl_Size dictLength, + const char *dict, int dictLength, const char **elementPtr, const char **nextPtr, - Tcl_Size *sizePtr, int *literalPtr); + int *sizePtr, int *literalPtr); /* TIP #280 - Modified token based evaluation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, - Tcl_Size numBytes, int flags, Tcl_Size line, + int numBytes, int flags, int line, int *clNextOuter, const char *outerScript); MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd; @@ -3135,7 +3130,7 @@ MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, Tcl_DString *toAppendPtr); MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp, - Tcl_Obj *const *objv, Tcl_Size objc, Tcl_Size *objcPtr); + Tcl_Obj *const *objv, int objc, int *objcPtr); MODULE_SCOPE Tcl_Obj *const *TclEnsembleGetRewriteValues(Tcl_Interp *interp); MODULE_SCOPE Tcl_Namespace *TclEnsureNamespace(Tcl_Interp *interp, Tcl_Namespace *namespacePtr); @@ -3219,7 +3214,7 @@ MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); MODULE_SCOPE int TclIsDigitProc(int byte); MODULE_SCOPE int TclIsBareword(int byte); -MODULE_SCOPE Tcl_Obj * TclJoinPath(Tcl_Size elements, Tcl_Obj * const objv[], +MODULE_SCOPE Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[], int forceRelative); MODULE_SCOPE int MakeTildeRelativePath(Tcl_Interp *interp, const char *user, const char *subPath, Tcl_DString *dsPtr); @@ -3232,25 +3227,25 @@ MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *argPtr); MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, - Tcl_Size indexCount, Tcl_Obj *const indexArray[]); + int indexCount, Tcl_Obj *const indexArray[]); /* TIP #280 */ -MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, Tcl_Size line, int n, +MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, int line, int n, int *lines, Tcl_Obj *const *elems); MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); MODULE_SCOPE int TclListObjAppendElements(Tcl_Interp *interp, - Tcl_Obj *toObj, Tcl_Size elemCount, + Tcl_Obj *toObj, int elemCount, Tcl_Obj *const elemObjv[]); -MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Obj *listPtr, Tcl_Size fromIdx, - Tcl_Size toIdx); +MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Obj *listPtr, int fromIdx, + int toIdx); MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *indexPtr, Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, - Tcl_Size indexCount, Tcl_Obj *const indexArray[], + int indexCount, Tcl_Obj *const indexArray[], Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name, const EnsembleImplMap map[]); MODULE_SCOPE int TclMakeSafe(Tcl_Interp *interp); -MODULE_SCOPE int TclMaxListLength(const char *bytes, Tcl_Size numBytes, +MODULE_SCOPE int TclMaxListLength(const char *bytes, int numBytes, const char **endPtr); MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, @@ -3268,15 +3263,15 @@ MODULE_SCOPE int TclObjInvokeNamespace(Tcl_Interp *interp, MODULE_SCOPE int TclObjUnsetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); MODULE_SCOPE int TclParseBackslash(const char *src, - Tcl_Size numBytes, Tcl_Size *readPtr, char *dst); -MODULE_SCOPE int TclParseHex(const char *src, Tcl_Size numBytes, + int numBytes, int *readPtr, char *dst); +MODULE_SCOPE int TclParseHex(const char *src, int numBytes, int *resultPtr); MODULE_SCOPE int TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *expected, const char *bytes, - Tcl_Size numBytes, const char **endPtrPtr, int flags); + int numBytes, const char **endPtrPtr, int flags); MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string, - Tcl_Size numBytes, Tcl_Parse *parsePtr); -MODULE_SCOPE Tcl_Size TclParseAllWhiteSpace(const char *src, Tcl_Size numBytes); + int numBytes, Tcl_Parse *parsePtr); +MODULE_SCOPE int TclParseAllWhiteSpace(const char *src, int numBytes); MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); @@ -3284,7 +3279,7 @@ MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, - Tcl_Size len); + int len); MODULE_SCOPE void TclpAlertNotifier(void *clientData); MODULE_SCOPE void *TclpNotifierData(void); MODULE_SCOPE void TclpServiceModeHook(int mode); @@ -3305,8 +3300,8 @@ MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, const char **errorMsgPtr); MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, void *clientData, - Tcl_Size stackSize, int flags); -MODULE_SCOPE Tcl_Size TclpFindVariable(const char *name, Tcl_Size *lengthPtr); + int stackSize, int flags); +MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); @@ -3321,9 +3316,9 @@ MODULE_SCOPE int TclpMatchFiles(Tcl_Interp *interp, char *separators, MODULE_SCOPE int TclpObjNormalizePath(Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint); MODULE_SCOPE void TclpNativeJoinPath(Tcl_Obj *prefix, const char *joining); -MODULE_SCOPE Tcl_Obj * TclpNativeSplitPath(Tcl_Obj *pathPtr, Tcl_Size *lenPtr); +MODULE_SCOPE Tcl_Obj * TclpNativeSplitPath(Tcl_Obj *pathPtr, int *lenPtr); MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr, - Tcl_Size *driveNameLengthPtr, Tcl_Obj **driveNameRef); + int *driveNameLengthPtr, Tcl_Obj **driveNameRef); MODULE_SCOPE int TclCrossFilesystemCopy(Tcl_Interp *interp, Tcl_Obj *source, Tcl_Obj *target); MODULE_SCOPE int TclpMatchInDirectory(Tcl_Interp *interp, @@ -3354,9 +3349,9 @@ MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id); MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex); MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, - Tcl_Size reStrLen, Tcl_DString *dsPtr, int *flagsPtr, + int reStrLen, Tcl_DString *dsPtr, int *flagsPtr, int *quantifiersFoundPtr); -MODULE_SCOPE TCL_HASH_TYPE TclScanElement(const char *string, Tcl_Size length, +MODULE_SCOPE TCL_HASH_TYPE TclScanElement(const char *string, int length, char *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); @@ -3371,44 +3366,44 @@ MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue, Tcl_Encoding encoding); MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, - Tcl_Obj *const *objv, Tcl_Size objc, Tcl_Size subIdx, + Tcl_Obj *const *objv, int objc, int subIdx, Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, - Tcl_Size numBytes); + int numBytes); typedef int (*memCmpFn_t)(const void*, const void*, size_t); MODULE_SCOPE int TclStringCmp(Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr, - int checkEq, int nocase, Tcl_Size reqlength); + int checkEq, int nocase, int reqlength); MODULE_SCOPE int TclStringCmpOpts(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int *nocase, int *reqlength); -MODULE_SCOPE int TclStringMatch(const char *str, Tcl_Size strLen, +MODULE_SCOPE int TclStringMatch(const char *str, int strLen, const char *pattern, int ptnLen, int flags); MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, Tcl_Obj *patternObj, int flags); MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes, - Tcl_Size numBytes, int flags, Tcl_Size line, + int numBytes, int flags, int line, struct CompileEnv *envPtr); -MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, Tcl_Size numOpts, +MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, int numOpts, Tcl_Obj *const opts[], int *flagPtr); MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes, - Tcl_Size numBytes, int flags, Tcl_Parse *parsePtr, + int numBytes, int flags, Tcl_Parse *parsePtr, Tcl_InterpState *statePtr); MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, - Tcl_Size count, int *tokensLeftPtr, Tcl_Size line, + int count, int *tokensLeftPtr, int line, int *clNextOuter, const char *outerScript); -MODULE_SCOPE Tcl_Size TclTrim(const char *bytes, Tcl_Size numBytes, - const char *trim, Tcl_Size numTrim, Tcl_Size *trimRight); -MODULE_SCOPE Tcl_Size TclTrimLeft(const char *bytes, Tcl_Size numBytes, - const char *trim, Tcl_Size numTrim); -MODULE_SCOPE Tcl_Size TclTrimRight(const char *bytes, Tcl_Size numBytes, - const char *trim, Tcl_Size numTrim); +MODULE_SCOPE int TclTrim(const char *bytes, int numBytes, + const char *trim, int numTrim, int *trimRight); +MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes, + const char *trim, int numTrim); +MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, + const char *trim, int numTrim); MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command); MODULE_SCOPE void TclRegisterCommandTypeName( Tcl_ObjCmdProc *implementationProc, const char *nameStr); MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); -MODULE_SCOPE Tcl_Size TclUtfCount(int ch); +MODULE_SCOPE int TclUtfCount(int ch); #if TCL_UTF_MAX > 3 # define TclUtfToUCS4 Tcl_UtfToUniChar # define TclUniCharToUCS4(src, ptr) (*ptr = *(src),1) @@ -3455,7 +3450,7 @@ MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); MODULE_SCOPE void TclpThreadSetGlobalTSD(void *tsdKeyPtr, void *ptr); MODULE_SCOPE void * TclpThreadGetGlobalTSD(void *tsdKeyPtr); MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, - const char *msg, Tcl_Size length); + const char *msg, int length); /* Tip 430 */ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); @@ -3545,7 +3540,7 @@ MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, Tcl_Obj *part2Ptr, int index, int pathc, Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, - Tcl_Size pathc, Tcl_Obj *const pathv[]); + int pathc, Tcl_Obj *const pathv[]); MODULE_SCOPE Tcl_ObjCmdProc Tcl_DisassembleObjCmd; /* Assemble command function */ @@ -4071,13 +4066,13 @@ MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, MODULE_SCOPE Tcl_Obj * TclStringCat(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); MODULE_SCOPE Tcl_Obj * TclStringFirst(Tcl_Obj *needle, Tcl_Obj *haystack, - Tcl_Size start); + int start); MODULE_SCOPE Tcl_Obj * TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack, - Tcl_Size last); + int last); MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr, - Tcl_Size count, int flags); + int count, int flags); MODULE_SCOPE Tcl_Obj * TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr, - Tcl_Size first, Tcl_Size count, Tcl_Obj *insertPtr, + int first, int count, Tcl_Obj *insertPtr, int flags); MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr, int flags); @@ -4191,12 +4186,12 @@ MODULE_SCOPE Tcl_Obj * TclGetArrayDefault(Var *arrayPtr); */ MODULE_SCOPE int TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr, - Tcl_Size before, Tcl_Size after, int *indexPtr); -MODULE_SCOPE Tcl_Size TclIndexDecode(int encoded, Tcl_Size endValue); + int before, int after, int *indexPtr); +MODULE_SCOPE int TclIndexDecode(int encoded, int endValue); /* Constants used in index value encoding routines. */ -#define TCL_INDEX_END ((Tcl_Size)-2) -#define TCL_INDEX_START ((Tcl_Size)0) +#define TCL_INDEX_END (-2) +#define TCL_INDEX_START (0) /* *---------------------------------------------------------------------- @@ -4834,7 +4829,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; * * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d); - * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, Tcl_Size len); + * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, int len); * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral); * *---------------------------------------------------------------- diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index 659c3e6..f2bc0da 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -78,7 +78,7 @@ EXTERN int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp, EXTERN int Tcl_MacOSXOpenVersionedBundleResources( Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, - int hasResourceFile, Tcl_Size maxPathLen, + int hasResourceFile, int maxPathLen, char *libraryPath); /* 2 */ EXTERN void Tcl_MacOSXNotifierAddRunLoopMode( @@ -97,7 +97,7 @@ typedef struct TclPlatStubs { #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath); /* 0 */ - int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, Tcl_Size maxPathLen, char *libraryPath); /* 1 */ + int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath); /* 1 */ void (*tcl_MacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 2 */ #endif /* MACOSX */ } TclPlatStubs; -- cgit v0.12 From 5a60ace74d3eabbb41d24ce1801f1f5e0358bd1e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 23 Oct 2022 14:46:44 +0000 Subject: off-by-one in TCL_MAJOR_VERSION check --- generic/tclInt.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 9ddc2a1..33f244d 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -224,9 +224,9 @@ typedef struct NamespacePathEntry NamespacePathEntry; typedef struct TclVarHashTable { Tcl_HashTable table; struct Namespace *nsPtr; -#if TCL_MAJOR_VERSION > 9 +#if TCL_MAJOR_VERSION > 8 struct Var *arrayPtr; -#endif /* TCL_MAJOR_VERSION > 9 */ +#endif /* TCL_MAJOR_VERSION > 8 */ } TclVarHashTable; /* -- cgit v0.12 From 4288b3bee9191cd1a30c663d565e352ff6866a68 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 23 Oct 2022 20:40:32 +0000 Subject: Add support for macOS Ventura --- library/platform/pkgIndex.tcl | 2 +- library/platform/platform.tcl | 13 ++++++++++++- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 4 files changed, 17 insertions(+), 6 deletions(-) diff --git a/library/platform/pkgIndex.tcl b/library/platform/pkgIndex.tcl index de28fd1..e7029d0 100644 --- a/library/platform/pkgIndex.tcl +++ b/library/platform/pkgIndex.tcl @@ -1,3 +1,3 @@ -package ifneeded platform 1.0.18 [list source [file join $dir platform.tcl]] +package ifneeded platform 1.0.19 [list source [file join $dir platform.tcl]] package ifneeded platform::shell 1.1.4 [list source [file join $dir shell.tcl]] diff --git a/library/platform/platform.tcl b/library/platform/platform.tcl index 752f069..00eef1c 100644 --- a/library/platform/platform.tcl +++ b/library/platform/platform.tcl @@ -364,6 +364,17 @@ proc ::platform::patterns {id} { foreach {major minor} [split $v .] break set res {} + if {$major eq 13} { + # Add 13.0 to 13.minor to patterns. + for {set j $minor} {$j >= 0} {incr j -1} { + lappend res macosx${major}.${j}-${cpu} + foreach a $alt { + lappend res macosx${major}.${j}-$a + } + } + set major 12 + set minor 6 + } if {$major eq 12} { # Add 12.0 to 12.minor to patterns. for {set j $minor} {$j >= 0} {incr j -1} { @@ -420,7 +431,7 @@ proc ::platform::patterns {id} { # ### ### ### ######### ######### ######### ## Ready -package provide platform 1.0.18 +package provide platform 1.0.19 # ### ### ### ######### ######### ######### ## Demo application diff --git a/unix/Makefile.in b/unix/Makefile.in index 316ec22..340edbf 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -963,9 +963,9 @@ install-libraries: libraries @echo "Installing package tcltest 2.5.5 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \ "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.5.tm" - @echo "Installing package platform 1.0.18 as a Tcl Module" + @echo "Installing package platform 1.0.19 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \ - "$(MODULE_INSTALL_DIR)/8.4/platform-1.0.18.tm" + "$(MODULE_INSTALL_DIR)/8.4/platform-1.0.19.tm" @echo "Installing package platform::shell 1.1.4 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl \ "$(MODULE_INSTALL_DIR)/8.4/platform/shell-1.1.4.tm" diff --git a/win/Makefile.in b/win/Makefile.in index 73387e3..8e15849 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -746,8 +746,8 @@ install-libraries: libraries install-tzdata install-msgs @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl "$(MODULE_INSTALL_DIR)/8.5/msgcat-1.6.1.tm"; @echo "Installing package tcltest 2.5.5 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.5.tm"; - @echo "Installing package platform 1.0.18 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl "$(MODULE_INSTALL_DIR)/8.4/platform-1.0.18.tm"; + @echo "Installing package platform 1.0.19 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl "$(MODULE_INSTALL_DIR)/8.4/platform-1.0.19.tm"; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/shell.tcl "$(MODULE_INSTALL_DIR)/8.4/platform/shell-1.1.4.tm"; @echo "Installing encodings"; -- cgit v0.12 From 2c5609394cbdbe7c6d63b310293830a496bc979d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 24 Oct 2022 11:54:10 +0000 Subject: Fix env-2.1, env-2.2, env-2.1, env-2.3, env-2.4, env-3.1, env-4.1, env-4.3, env-4.4, env-4.5 testcases on win32 --- tests/env.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/env.test b/tests/env.test index 25367c3..ff111e9 100644 --- a/tests/env.test +++ b/tests/env.test @@ -104,8 +104,8 @@ variable keep { __CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM CommonProgramFiles CommonProgramFiles(x86) ProgramFiles ProgramFiles(x86) CommonProgramW6432 ProgramW6432 - WINECONFIGDIR WINEDATADIR WINEDLLDIR0 WINEHOMEDIR PROCESSOR_ARCHITECTURE - USERPROFILE + PROCESSOR_ARCHITECTURE PROCESSOR_ARCHITEW6432 USERPROFILE + WINECONFIGDIR WINEDATADIR WINEDLLDIR0 WINEHOMEDIR } variable printenvScript [makeFile [string map [list @keep@ [list $keep]] { -- cgit v0.12 From df727328685d1279729add16629922fdd29d3279 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 25 Oct 2022 06:12:11 +0000 Subject: Since MacOS 12.6 reports as 12.5 .... --- library/platform/platform.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/platform/platform.tcl b/library/platform/platform.tcl index 00eef1c..acaebf2 100644 --- a/library/platform/platform.tcl +++ b/library/platform/platform.tcl @@ -373,7 +373,7 @@ proc ::platform::patterns {id} { } } set major 12 - set minor 6 + set minor 5 } if {$major eq 12} { # Add 12.0 to 12.minor to patterns. -- cgit v0.12 -- cgit v0.12 From d33fc57550e1921bfadb8fe4b90d7e55bf23e6f5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 25 Oct 2022 12:23:26 +0000 Subject: Some more int -> Tcl_Size conversions, making the diff with the Tcl 9.0 header-files smaller --- generic/tclArithSeries.h | 4 ++-- generic/tclCompile.h | 17 ++++++++--------- generic/tclDecls.h | 28 ++++++++++++++-------------- generic/tclInt.h | 6 +++--- generic/tclStringRep.h | 19 ++++++++++++------- win/tclWinPort.h | 3 +++ 6 files changed, 42 insertions(+), 35 deletions(-) diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h index 3ace052..af4777c 100644 --- a/generic/tclArithSeries.h +++ b/generic/tclArithSeries.h @@ -41,11 +41,11 @@ MODULE_SCOPE int TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **elementObj); MODULE_SCOPE Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Interp *interp, - Tcl_Obj *arithSeriesPtr, int fromIdx, int toIdx); + Tcl_Obj *arithSeriesPtr, Tcl_Size fromIdx, Tcl_Size toIdx); MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Interp *interp, Tcl_Obj *arithSeriesPtr); MODULE_SCOPE int TclArithSeriesGetElements(Tcl_Interp *interp, - Tcl_Obj *objPtr, int *objcPtr, Tcl_Obj ***objvPtr); + Tcl_Obj *objPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); MODULE_SCOPE Tcl_Obj * TclNewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len); diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 2843ef5..b21ed7d 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1212,7 +1212,6 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); MODULE_SCOPE int TclPushProcCallFrame(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int isLambda); - /* *---------------------------------------------------------------- @@ -1260,10 +1259,10 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, #define TclCheckStackDepth(depth, envPtr) \ do { \ - int _dd = (depth); \ - if (_dd != (envPtr)->currStackDepth) { \ - Tcl_Panic("bad stack depth computations: is %i, should be %i", \ - (envPtr)->currStackDepth, _dd); \ + size_t _dd = (depth); \ + if (_dd != (size_t)(envPtr)->currStackDepth) { \ + Tcl_Panic("bad stack depth computations: is %" TCL_Z_MODIFIER "u, should be %" TCL_Z_MODIFIER "u", \ + (size_t)(envPtr)->currStackDepth, _dd); \ } \ } while (0) @@ -1580,9 +1579,9 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, * of LOOP ranges is an interesting datum for debugging purposes, and that is * what we compute now. * - * static int ExceptionRangeStarts(CompileEnv *envPtr, int index); - * static void ExceptionRangeEnds(CompileEnv *envPtr, int index); - * static void ExceptionRangeTarget(CompileEnv *envPtr, int index, LABEL); + * static int ExceptionRangeStarts(CompileEnv *envPtr, Tcl_Size index); + * static void ExceptionRangeEnds(CompileEnv *envPtr, Tcl_Size index); + * static void ExceptionRangeTarget(CompileEnv *envPtr, Tcl_Size index, LABEL); */ #define ExceptionRangeStarts(envPtr, index) \ @@ -1641,7 +1640,7 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, #define DefineLineInformation \ ExtCmdLoc *mapPtr = envPtr->extCmdMapPtr; \ - int eclIndex = mapPtr->nuloc - 1 + Tcl_Size eclIndex = mapPtr->nuloc - 1 #define SetLineInformation(word) \ envPtr->line = mapPtr->loc[eclIndex].line[(word)]; \ diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 0736b73..d1af7be 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4351,9 +4351,9 @@ extern const TclStubs *tclStubsPtr; #undef Tcl_GetString #undef Tcl_GetUnicode #define Tcl_GetString(objPtr) \ - Tcl_GetStringFromObj(objPtr, (int *)NULL) + Tcl_GetStringFromObj(objPtr, (Tcl_Size *)NULL) #define Tcl_GetUnicode(objPtr) \ - Tcl_GetUnicodeFromObj(objPtr, (int *)NULL) + Tcl_GetUnicodeFromObj(objPtr, (Tcl_Size *)NULL) #undef Tcl_GetBytesFromObj #undef Tcl_GetIndexFromObjStruct #undef Tcl_GetBooleanFromObj @@ -4441,17 +4441,17 @@ extern const TclStubs *tclStubsPtr; #endif #if defined(USE_TCL_STUBS) # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ - ? (char *(*)(const wchar_t *, int, Tcl_DString *))tclStubsPtr->tcl_UniCharToUtfDString \ - : (char *(*)(const wchar_t *, int, Tcl_DString *))Tcl_Char16ToUtfDString) + ? (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))tclStubsPtr->tcl_UniCharToUtfDString \ + : (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_Char16ToUtfDString) # define Tcl_UtfToWCharDString (sizeof(wchar_t) != sizeof(short) \ - ? (wchar_t *(*)(const char *, int, Tcl_DString *))tclStubsPtr->tcl_UtfToUniCharDString \ - : (wchar_t *(*)(const char *, int, Tcl_DString *))Tcl_UtfToChar16DString) + ? (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))tclStubsPtr->tcl_UtfToUniCharDString \ + : (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToChar16DString) # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ ? (int (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToUniChar \ : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16) # define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ - ? (int (*)(wchar_t *))tclStubsPtr->tcl_UniCharLen \ - : (int (*)(wchar_t *))Tcl_Char16Len) + ? (Tcl_Size (*)(wchar_t *))tclStubsPtr->tcl_UniCharLen \ + : (Tcl_Size (*)(wchar_t *))Tcl_Char16Len) #ifdef TCL_NO_DEPRECATED # undef Tcl_ListObjGetElements # define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) == sizeof(int) \ @@ -4484,17 +4484,17 @@ extern const TclStubs *tclStubsPtr; #endif /* TCL_NO_DEPRECATED */ #else # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ - ? (char *(*)(const wchar_t *, int, Tcl_DString *))Tcl_UniCharToUtfDString \ - : (char *(*)(const wchar_t *, int, Tcl_DString *))Tcl_Char16ToUtfDString) + ? (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_UniCharToUtfDString \ + : (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_Char16ToUtfDString) # define Tcl_UtfToWCharDString (sizeof(wchar_t) != sizeof(short) \ - ? (wchar_t *(*)(const char *, int, Tcl_DString *))Tcl_UtfToUniCharDString \ - : (wchar_t *(*)(const char *, int, Tcl_DString *))Tcl_UtfToChar16DString) + ? (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToUniCharDString \ + : (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToChar16DString) # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ ? (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar \ : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16) # define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ - ? (int (*)(wchar_t *))Tcl_UniCharLen \ - : (int (*)(wchar_t *))Tcl_Char16Len) + ? (Tcl_Size (*)(wchar_t *))Tcl_UniCharLen \ + : (Tcl_Size (*)(wchar_t *))Tcl_Char16Len) #ifdef TCL_NO_DEPRECATED # define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) == sizeof(int) \ ? (Tcl_ListObjGetElements)((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr)) \ diff --git a/generic/tclInt.h b/generic/tclInt.h index 40cf10c..6af0991 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4190,8 +4190,8 @@ MODULE_SCOPE int TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr, MODULE_SCOPE int TclIndexDecode(int encoded, int endValue); /* Constants used in index value encoding routines. */ -#define TCL_INDEX_END (-2) -#define TCL_INDEX_START (0) +#define TCL_INDEX_END ((Tcl_Size)-2) +#define TCL_INDEX_START ((Tcl_Size)0) /* *---------------------------------------------------------------------- @@ -4697,7 +4697,7 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; * of counting along a string of all one-byte characters. The ANSI C * "prototype" for this macro is: * - * MODULE_SCOPE void TclNumUtfChars(int numChars, const char *bytes, + * MODULE_SCOPE void TclNumUtfCharsM(int numChars, const char *bytes, * int numBytes); *---------------------------------------------------------------- */ diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h index faa2c2c..bce9092 100644 --- a/generic/tclStringRep.h +++ b/generic/tclStringRep.h @@ -31,6 +31,10 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ + +#ifndef _TCLSTRINGREP +#define _TCLSTRINGREP + /* * The following structure is the internal rep for a String object. It keeps @@ -42,15 +46,15 @@ */ typedef struct { - int numChars; /* The number of chars in the string. -1 means - * this value has not been calculated. >= 0 - * means that there is a valid Unicode rep, or - * that the number of UTF bytes == the number - * of chars. */ - int allocated; /* The amount of space actually allocated for + Tcl_Size numChars; /* The number of chars in the string. + * TCL_INDEX_NONE means this value has not been + * calculated. Any other means that there is a valid + * Unicode rep, or that the number of UTF bytes == + * the number of chars. */ + Tcl_Size allocated; /* The amount of space actually allocated for * the UTF string (minus 1 byte for the * termination char). */ - int maxChars; /* Max number of chars that can fit in the + Tcl_Size maxChars; /* Max number of chars that can fit in the * space allocated for the unicode array. */ int hasUnicode; /* Boolean determining whether the string has * a Unicode representation. */ @@ -84,6 +88,7 @@ typedef struct { ((objPtr)->internalRep.twoPtrValue.ptr2 = NULL), \ ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr)) +#endif /* _TCLSTRINGREP */ /* * Local Variables: * mode: c diff --git a/win/tclWinPort.h b/win/tclWinPort.h index b61e481..d7d60a4 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -461,6 +461,9 @@ typedef DWORD_PTR * PDWORD_PTR; # pragma warning(disable:4090) /* see: https://developercommunity.visualstudio.com/t/c-compiler-incorrect-propagation-of-const-qualifie/390711 */ # pragma warning(disable:4146) # pragma warning(disable:4244) +#if !defined(_WIN64) +# pragma warning(disable:4305) +#endif # pragma warning(disable:4267) # pragma warning(disable:4996) #endif -- cgit v0.12 From ba62d5de6e8d0818da84501ef2dd6cd9a635b27b Mon Sep 17 00:00:00 2001 From: kjnash Date: Tue, 25 Oct 2022 16:23:54 +0000 Subject: Fix bug 1173760 (proxy server for https). Add http::config options -proxynot, -proxyauth. --- doc/http.n | 51 +++- library/http/http.tcl | 335 ++++++++++++++++++++--- tests/http.test | 6 +- tests/httpProxy.test | 456 ++++++++++++++++++++++++++++++++ tests/httpProxySquidConfigForEL8.tar.gz | Bin 0 -> 2266 bytes 5 files changed, 801 insertions(+), 47 deletions(-) create mode 100644 tests/httpProxy.test create mode 100644 tests/httpProxySquidConfigForEL8.tar.gz diff --git a/doc/http.n b/doc/http.n index 59f15b6..ff2307e 100644 --- a/doc/http.n +++ b/doc/http.n @@ -172,14 +172,15 @@ fresh socket, overriding the \fB\-keepalive\fR option of command \fBhttp::geturl\fR. See the \fBPERSISTENT SOCKETS\fR section for details. The default is 0. .TP -\fB\-proxyhost\fR \fIhostname\fR -. -The name of the proxy host, if any. If this value is the -empty string, the URL host is contacted directly. -.TP -\fB\-proxyport\fR \fInumber\fR +\fB\-proxyauth\fR \fIstring\fR . -The proxy port number. +If non-empty, the string is supplied to the proxy server as the value of the +request header Proxy-Authorization. This option can be used for HTTP Basic +Authentication. If the proxy server requires authentication by another +technique, e.g. Digest Authentication, the \fB\-proxyauth\fR option is not +useful. In that case the caller must expect a 407 response from the proxy, +compute the authentication value to be supplied, and use the \fB\-headers\fR +option to supply it as the value of the Proxy-Authorization header. .TP \fB\-proxyfilter\fR \fIcommand\fR . @@ -188,18 +189,46 @@ The command is a callback that is made during to determine if a proxy is required for a given host. One argument, a host name, is added to \fIcommand\fR when it is invoked. If a proxy is required, the callback should return a two-element list containing -the proxy server and proxy port. Otherwise the filter should return -an empty list. The default filter returns the values of the -\fB\-proxyhost\fR and \fB\-proxyport\fR settings if they are -non-empty. +the proxy server and proxy port. Otherwise the filter command should return +an empty list. .RS .PP +The default value of \fB\-proxyfilter\fR is \fBhttp::ProxyRequired\fR, and +this command returns the values of the \fB\-proxyhost\fR and +\fB\-proxyport\fR settings if they are non-empty. The options +\fB\-proxyhost\fR, \fB\-proxyport\fR, and \fB\-proxynot\fR are used only +by \fBhttp::ProxyRequired\fR, and nowhere else in \fB::http::geturl\fR. +A user-supplied \fB\-proxyfilter\fR command may use these options, or +alternatively it may obtain values from elsewhere in the calling script. +In the latter case, any values provided for \fB\-proxyhost\fR, +\fB\-proxyport\fR, and \fB\-proxynot\fR are unused. +.PP The \fB::http::geturl\fR command runs the \fB\-proxyfilter\fR callback inside a \fBcatch\fR command. Therefore an error in the callback command does not call the \fBbgerror\fR handler. See the \fBERRORS\fR section for details. .RE .TP +\fB\-proxyhost\fR \fIhostname\fR +. +The host name or IP address of the proxy server, if any. If this value is +the empty string, the URL host is contacted directly. See +\fB\-proxyfilter\fR for how the value is used. +.TP +\fB\-proxynot\fR \fIlist\fR +. +A Tcl list of domain names and IP addresses that should be accessed directly, +not through the proxy server. The target hostname is compared with each list +element using a case-insensitive \fBstring match\fR. It is often convenient +to use the wildcard "*" at the start of a domain name (e.g. *.example.com) or +at the end of an IP address (e.g. 192.168.0.*). See \fB\-proxyfilter\fR for +how the value is used. +.TP +\fB\-proxyport\fR \fInumber\fR +. +The port number of the proxy server. See \fB\-proxyfilter\fR for how the +value is used. +.TP \fB\-repost\fR \fIboolean\fR . Specifies what to do if a POST request over a persistent connection fails diff --git a/library/http/http.tcl b/library/http/http.tcl index 88685ec..fcb03e1 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -26,6 +26,8 @@ namespace eval http { -proxyhost {} -proxyport {} -proxyfilter http::ProxyRequired + -proxynot {} + -proxyauth {} -repost 0 -threadlevel 0 -urlencoding utf-8 @@ -470,7 +472,9 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { if {[info exists state(-command)] && (!$skipCB) && (![info exists state(done-command-cb)])} { set state(done-command-cb) yes - if {[catch {namespace eval :: $state(-command) $token} err] && $errormsg eq ""} { + if { [catch {namespace eval :: $state(-command) $token} err] + && ($errormsg eq "") + } { set state(error) [list $err $errorInfo $errorCode] set state(status) error } @@ -886,20 +890,22 @@ proc http::reset {token {why reset}} { proc http::geturl {url args} { variable urlTypes - # The value is set in the namespace header of this file. If the file has - # not been modified the value is "::http::socket". - set socketCmd [lindex $urlTypes(http) 1] - # - If ::tls::socketCmd has its default value "::socket", change it to the - # new value $socketCmd. + # new value ::http::socketForTls. # - If the old value is different, then it has been modified either by the # script or by the Tcl installation, and replaced by a new command. The # script or installation that modified ::tls::socketCmd is also - # responsible for integrating ::http::socket into its own "new" command, - # if it wishes to do so. + # responsible for integrating ::http::socketForTls into its own "new" + # command, if it wishes to do so. + # - Commands that open a socket: + # - ::socket - basic + # - ::http::socket - can use a thread to avoid blockage by slow DNS + # lookup. See http::config option -threadlevel. + # - ::http::socketForTls - as ::http::socket, but can also open a socket + # for HTTPS/TLS through a proxy. if {[info exists ::tls::socketCmd] && ($::tls::socketCmd eq {::socket})} { - set ::tls::socketCmd $socketCmd + set ::tls::socketCmd ::http::socketForTls } set token [CreateToken $url {*}$args] @@ -1023,6 +1029,7 @@ proc http::CreateToken {url args} { requestHeaders {} requestLine {} transfer {} + proxyUsed none } set state(-keepalive) $defaultKeepalive set state(-strict) $strict @@ -1299,11 +1306,16 @@ proc http::CreateToken {url args} { set state(-keepalive) 0 } - # If we are using the proxy, we must pass in the full URL that includes - # the server name. - if {$phost ne ""} { + # Handle proxy requests here for http:// but not for https:// + # The proxying for https is done in the ::http::socketForTls command. + # A proxy request for http:// needs the full URL in the HTTP request line, + # including the server name. + # The *tls* test below attempts to describe protocols in addition to + # "https on port 443" that use HTTP over TLS. + if {($phost ne "") && (![string match -nocase *tls* $defcmd])} { set srvurl $url set targetAddr [list $phost $pport] + set state(proxyUsed) HttpProxy } else { set targetAddr [list $host $port] } @@ -1316,7 +1328,7 @@ proc http::CreateToken {url args} { } set state(connArgs) [list $proto $phost $srvurl] - set state(openCmd) [list {*}$defcmd {*}$sockopts {*}$targetAddr] + set state(openCmd) [list {*}$defcmd {*}$sockopts -type $token {*}$targetAddr] # See if we are supposed to use a previously opened channel. # - In principle, ANY call to http::geturl could use a previously opened @@ -1663,12 +1675,14 @@ proc http::OpenSocket {token DoLater} { ##Log pre socket opened, - token $token ##Log $state(openCmd) - token $token set sock [namespace eval :: $state(openCmd)] - + set state(sock) $sock # Normal return from $state(openCmd) always returns a valid socket. + # A TLS proxy connection with 407 or other failure from the + # proxy server raises an error. + # Initialisation of a new socket. ##Log post socket opened, - token $token ##Log socket opened, now fconfigure - token $token - set state(sock) $sock set delay [expr {[clock milliseconds] - $pre}] if {$delay > 3000} { Log socket delay $delay - token $token @@ -1684,7 +1698,15 @@ proc http::OpenSocket {token DoLater} { # Code above has set state(sock) $sock ConfigureNewSocket $token $sockOld $DoLater } result errdict]} { - Finish $token $result + if {[string range $result 0 20] eq {proxy connect failed:}} { + # The socket can be persistent: if so it is identified with + # the https target host, and will be kept open. + # Results of the failed proxy CONNECT have been copied to $token and + # are available to the caller. + Eot $token + } else { + Finish $token $result + } } ##Log Leaving http::OpenSocket coroutine [info coroutine] - token $token return @@ -1715,7 +1737,8 @@ proc http::OpenSocket {token DoLater} { # # Arguments: # token - connection token (name of an array) -# sockOld - handle or placeholder used for a socket before the call to OpenSocket +# sockOld - handle or placeholder used for a socket before the call to +# OpenSocket # DoLater - dictionary of boolean values listing unfinished tasks # # Return Value: none @@ -2083,9 +2106,15 @@ proc http::Connected {token proto phost srvurl} { Log ^B$tk begin sending request - token $token if {[catch { - set state(method) $how - set state(requestHeaders) {} - set state(requestLine) "$how $srvurl HTTP/$state(-protocol)" + if {[info exists state(bypass)]} { + set state(method) [lindex [split $state(bypass) { }] 0] + set state(requestHeaders) {} + set state(requestLine) $state(bypass) + } else { + set state(method) $how + set state(requestHeaders) {} + set state(requestLine) "$how $srvurl HTTP/$state(-protocol)" + } puts $sock $state(requestLine) set hostValue [GetFieldValue $state(-headers) Host] if {$hostValue ne {}} { @@ -2119,6 +2148,11 @@ proc http::Connected {token proto phost srvurl} { # and "state(-keepalive) 0". set ConnVal close } + # Proxy authorisation (cf. mod by Anders Ramdahl to autoproxy by + # Pat Thoyts). + if {($http(-proxyauth) ne {}) && ($state(proxyUsed) eq {HttpProxy})} { + SendHeader $token Proxy-Authorization $http(-proxyauth) + } # RFC7230 A.1 - "clients are encouraged not to send the # Proxy-Connection header field in any requests" set accept_encoding_seen 0 @@ -2143,7 +2177,12 @@ proc http::Connected {token proto phost srvurl} { set contDone 1 set state(querylength) $value } - if {[string equal -nocase $key "connection"]} { + if { [string equal -nocase $key "connection"] + && [info exists state(bypass)] + } { + # Value supplied in -headers overrides $ConnVal. + set connection_seen 1 + } elseif {[string equal -nocase $key "connection"]} { # Remove "close" or "keep-alive" and use our own value. # In an upgrade request, the upgrade is not guaranteed. # Value "close" or "keep-alive" tells the server what to do @@ -3121,6 +3160,7 @@ proc http::responseInfo {token} { currentPost STATE queryoffset totalSize STATE totalsize currentSize STATE currentsize + proxyUsed STATE proxyUsed } { if {$origin eq {STATE}} { if {[info exists state($name)]} { @@ -3604,6 +3644,45 @@ proc http::Event {sock token} { set state(state) complete Eot $token return + } elseif { + ($state(method) eq {CONNECT}) + && [string is integer -strict $state(responseCode)] + && ($state(responseCode) >= 200) + && ($state(responseCode) < 300) + } { + # A successful CONNECT response has no body. + # (An unsuccessful CONNECT has headers and body.) + # The code below is abstracted from Eot/Finish, but + # keeps the socket open. + catch {fileevent $state(sock) readable {}} + catch {fileevent $state(sock) writable {}} + set state(state) complete + set state(status) ok + if {[info commands ${token}--EventCoroutine] ne {}} { + rename ${token}--EventCoroutine {} + } + if {[info commands ${token}--SocketCoroutine] ne {}} { + rename ${token}--SocketCoroutine {} + } + if {[info exists state(socketcoro)]} { + Log $token Cancel socket after-idle event (Finish) + after cancel $state(socketcoro) + unset state(socketcoro) + } + if {[info exists state(after)]} { + after cancel $state(after) + unset state(after) + } + if { [info exists state(-command)] + && (![info exists state(done-command-cb)]) + } { + set state(done-command-cb) yes + if {[catch {namespace eval :: $state(-command) $token} err]} { + set state(error) [list $err $errorInfo $errorCode] + set state(status) error + } + } + return } else { } @@ -4305,7 +4384,7 @@ proc http::CopyDone {token count {error {}}} { # reason - "eof" means premature EOF (not EOF as the natural end of # the response) # - "" means completion of response, with or without EOF -# - anything else describes an error confition other than +# - anything else describes an error condition other than # premature EOF. # # Side Effects @@ -4537,17 +4616,23 @@ proc http::quoteString {string} { proc http::ProxyRequired {host} { variable http - if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} { - if { - ![info exists http(-proxyport)] || - ![string length $http(-proxyport)] - } { - set http(-proxyport) 8080 - } - return [list $http(-proxyhost) $http(-proxyport)] + if {(![info exists http(-proxyhost)]) || ($http(-proxyhost) eq {})} { + return + } + if {![info exists http(-proxyport)] || ($http(-proxyport) eq {})} { + set port 8080 } else { - return + set port $http(-proxyport) + } + + # Simple test (cf. autoproxy) for hosts that must be accessed directly, + # not through the proxy server. + foreach domain $http(-proxynot) { + if {[string match -nocase $domain $host]} { + return {} + } } + return [list $http(-proxyhost) $port] } # http::CharsetToEncoding -- @@ -4730,6 +4815,190 @@ interp alias {} http::meta {} http::responseHeaders interp alias {} http::metaValue {} http::responseHeaderValue interp alias {} http::ncode {} http::responseCode + +# ------------------------------------------------------------------------------ +# Proc http::socketForTls +# ------------------------------------------------------------------------------ +# Command to use in place of ::socket as the value of ::tls::socketCmd. +# This command does the same as http::socket, and also handles https connections +# through a proxy server. +# +# Notes. +# - The proxy server works differently for https and http. This implementation +# is for https. The proxy for http is implemented in http::CreateToken (in +# code that was previously part of http::geturl). +# - This code implicitly uses the tls options set for https in a call to +# http::register, and does not need to call commands tls::*. This simple +# implementation is possible because tls uses a callback to ::socket that can +# be redirected by changing the value of ::tls::socketCmd. +# +# Arguments: +# args - as for ::socket +# +# Return Value: a socket identifier +# ------------------------------------------------------------------------------ + +proc http::socketForTls {args} { + variable http + set host [lindex $args end-1] + set port [lindex $args end] + if { ($http(-proxyfilter) ne {}) + && (![catch {$http(-proxyfilter) $host} proxy]) + } { + set phost [lindex $proxy 0] + set pport [lindex $proxy 1] + } else { + set phost {} + set pport {} + } + if {$phost eq ""} { + set sock [::http::socket {*}$args] + } else { + set sock [::http::SecureProxyConnect {*}$args $phost $pport] + } + return $sock +} + + +# ------------------------------------------------------------------------------ +# Proc http::SecureProxyConnect +# ------------------------------------------------------------------------------ +# Command to open a socket through a proxy server to a remote server for use by +# tls. The caller must perform the tls handshake. +# +# Notes +# - Based on patch supplied by Melissa Chawla in ticket 1173760, and +# Proxy-Authorization header cf. autoproxy by Pat Thoyts. +# - Rewritten as a call to http::geturl, because response headers and body are +# needed if the CONNECT request fails. CONNECT is implemented for this case +# only, by state(bypass). +# - FUTURE WORK: give http::geturl a -connect option for a general CONNECT. +# - The request header Proxy-Connection is discouraged in RFC 7230 (June 2014), +# RFC 9112 (June 2022). +# +# Arguments: +# args - as for ::socket, ending in host, port; with proxy host, proxy +# port appended. +# +# Return Value: a socket identifier +# ------------------------------------------------------------------------------ +proc http::AllDone {varName args} { + set $varName done + return +} + +proc http::SecureProxyConnect {args} { + variable http + variable ConnectVar + variable ConnectCounter + set varName ::http::ConnectVar([incr ConnectCounter]) + + # Extract (non-proxy) target from args. + set host [lindex $args end-3] + set port [lindex $args end-2] + set args [lremove $args end-3 end-2] + + # Proxy server URL for connection. + # This determines where the socket is opened. + set phost [lindex $args end-1] + set pport [lindex $args end] + if {[string first : $phost] != -1} { + # IPv6 address, wrap it in [] so we can append :pport + set phost "\[${phost}\]" + } + set url http://${phost}:${pport} + # Elements of args other than host and port are not used when + # AsyncTransaction opens a socket. Those elements are -async and the + # -type $tokenName for the https transaction. Option -async is used by + # AsyncTransaction anyway, and -type $tokenName should not be propagated: + # the proxy request adds its own -type value. + + set targ [lsearch -exact $args -type] + if {$targ != -1} { + # Record in the token that this is a proxy call. + set token [lindex $args $targ+1] + upvar 0 ${token} state + set state(proxyUsed) SecureProxy + set tim $state(-timeout) + } else { + set tim 0 + } + if {$tim == 0} { + # Do not use infinite timeout for the proxy. + set tim 30000 + } + + # Prepare and send a CONNECT request to the proxy, using + # code similar to http::geturl. + set requestHeaders [list Host $host] + lappend requestHeaders Connection keep-alive + if {$http(-proxyauth) != {}} { + lappend requestHeaders Proxy-Authorization $http(-proxyauth) + } + + set token2 [CreateToken $url -keepalive 0 -timeout $tim \ + -headers $requestHeaders -command [list http::AllDone $varName]] + variable $token2 + upvar 0 $token2 state2 + + # Setting this variable overrides the HTTP request line and allows + # -headers to override the Connection: header set by -keepalive. + set state2(bypass) "CONNECT $host:$port HTTP/1.1" + + AsyncTransaction $token2 + + if {[info coroutine] ne {}} { + # All callers in the http package are coroutines launched by + # the event loop. + # The cwait command requires a coroutine because it yields + # to the caller; $varName is traced and the coroutine resumes + # when the variable is written. + cwait $varName + } else { + return -code error {code must run in a coroutine} + # For testing with a non-coroutine caller outside the http package. + # vwait $varName + } + unset $varName + + set sock $state2(sock) + set code $state2(responseCode) + if {[string is integer -strict $code] && ($code >= 200) && ($code < 300)} { + # All OK. The caller in tls will now call "tls::import $sock". + # Do not use Finish, which will close (sock). + # Other tidying done in http::Event. + array unset state2 + } elseif {$targ != -1} { + # Bad HTTP status code; token is known. + # Copy from state2 to state, including (sock). + foreach name [array names state2] { + set state($name) $state2($name) + } + set state(proxyUsed) SecureProxy + set state(proxyFail) failed + + # Do not use Finish, which will close (sock). + # Other tidying done in http::Event. + array unset state2 + + # Error message detected by http::OpenSocket. + return -code error "proxy connect failed: $code" + } else { + # Bad HTTP status code; token is not known because option -type + # (cf. targ) was not passed through tcltls, and so the script + # cannot write to state(*). + # Do not use Finish, which will close (sock). + # Other tidying done in http::Event. + array unset state2 + + # Error message detected by http::OpenSocket. + return -code error "proxy connect failed: $code\n$block" + } + + return $sock +} + + # ------------------------------------------------------------------------------ # Proc http::socket # ------------------------------------------------------------------------------ @@ -4767,7 +5036,7 @@ proc http::socket {args} { LoadThreadIfNeeded - set targ [lsearch -exact $args -token] + set targ [lsearch -exact $args -type] if {$targ != -1} { set token [lindex $args $targ+1] set args [lreplace $args $targ $targ+1] @@ -4831,7 +5100,7 @@ proc http::socket {args} { } # The commands below are dependencies of http::socket and -# are not used elsewhere. +# http::SecureProxyConnect and are not used elsewhere. # ------------------------------------------------------------------------------ # Proc http::LoadThreadIfNeeded diff --git a/tests/http.test b/tests/http.test index 1218536..18850d9 100644 --- a/tests/http.test +++ b/tests/http.test @@ -89,7 +89,7 @@ http::config -threadlevel $ThreadLevel test http-1.1 {http::config} { http::config -useragent UserAgent http::config -} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -threadlevel $ThreadLevel -urlencoding utf-8 -useragent UserAgent -zip 1] +} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyauth {} -proxyfilter http::ProxyRequired -proxyhost {} -proxynot {} -proxyport {} -repost 0 -threadlevel $ThreadLevel -urlencoding utf-8 -useragent UserAgent -zip 1] test http-1.2 {http::config} { http::config -proxyfilter } http::ProxyRequired @@ -104,10 +104,10 @@ test http-1.4 {http::config} { set x [http::config] http::config {*}$savedconf set x -} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -threadlevel $ThreadLevel -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1] +} [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyauth {} -proxyfilter myFilter -proxyhost nowhere.come -proxynot {} -proxyport 8080 -repost 0 -threadlevel $ThreadLevel -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1] test http-1.5 {http::config} -returnCodes error -body { http::config -proxyhost {} -junk 8080 -} -result {Unknown option -junk, must be: -accept, -cookiejar, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -threadlevel, -urlencoding, -useragent, -zip} +} -result {Unknown option -junk, must be: -accept, -cookiejar, -pipeline, -postfresh, -proxyauth, -proxyfilter, -proxyhost, -proxynot, -proxyport, -repost, -threadlevel, -urlencoding, -useragent, -zip} test http-1.6 {http::config} -setup { set oldenc [http::config -urlencoding] } -body { diff --git a/tests/httpProxy.test b/tests/httpProxy.test new file mode 100644 index 0000000..2d0bea2 --- /dev/null +++ b/tests/httpProxy.test @@ -0,0 +1,456 @@ +# Commands covered: http::geturl when using a proxy server. +# +# This file contains a collection of tests for the http script library. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright © 1991-1993 The Regents of the University of California. +# Copyright © 1994-1996 Sun Microsystems, Inc. +# Copyright © 1998-2000 Ajuba Solutions. +# Copyright © 2022 Keith Nash. +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 + namespace import -force ::tcltest::* +} + +package require http 2.10 + +proc bgerror {args} { + global errorInfo + puts stderr "httpProxy.test bgerror" + puts stderr [join $args] + puts stderr $errorInfo +} + +if {![info exists ThreadLevel]} { + if {[catch {package require Thread}] == 0} { + set ValueRange {0 1 2} + } else { + set ValueRange {0 1} + } + + # For each value of ThreadLevel, source this file recursively in the + # same interpreter. + foreach ThreadLevel $ValueRange { + source [info script] + } + catch {unset ThreadLevel} + catch {unset ValueRange} + return +} + +catch {puts "==== Test with ThreadLevel $ThreadLevel ===="} +http::config -threadlevel $ThreadLevel + + +#testConstraint needsSquid 1 +#testConstraint needsTls 1 + +if {[testConstraint needsTls]} { + package require tls + http::register https 443 [list ::tls::socket -ssl2 0 -ssl3 0 \ + -tls1 0 -tls1.1 0 -tls1.2 1 -tls1.3 0 -autoservername 1] +} + +# Testing with Squid +# - Example Squid configuration for Enterprise Linux 8 (Red Hat, Oracle, Rocky, +# Alma, ...) is in file tests/httpProxySquidConfigForEL8.tar.gz. +# - Two instances of Squid are launched, one that needs authentication and one +# that does not. +# - Each instance of Squid listens on IPv4 and IPv6, on different ports. + +# Instance of Squid that does not need authentication. +set n4host 127.0.0.1 +set n6host ::1 +set n4port 3128 +set n6port 3130 + +# Instance of Squid that needs authentication. +set a4host 127.0.0.1 +set a6host ::1 +set a4port 3129 +set a6port 3131 + +# concat Basic [base64::encode alice:alicia] +set aliceCreds {Basic YWxpY2U6YWxpY2lh} + +# concat Basic [base64::encode intruder:intruder] +set badCreds {Basic aW50cnVkZXI6aW50cnVkZXI=} + +test httpProxy-1.1 {squid is running - ipv4 noauth} -constraints {needsSquid} -setup { +} -body { + set token [http::geturl http://$n4host:$n4port/] + set ri [http::responseInfo $token] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" +} -result {complete ok 400 none} -cleanup { + http::cleanup $token + unset -nocomplain ri res +} + +test httpProxy-1.2 {squid is running - ipv6 noauth} -constraints {needsSquid} -setup { +} -body { + set token [http::geturl http://\[$n6host\]:$n6port/] + set ri [http::responseInfo $token] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" +} -result {complete ok 400 none} -cleanup { + http::cleanup $token + unset -nocomplain ri res +} + +test httpProxy-1.3 {squid is running - ipv4 auth} -constraints {needsSquid} -setup { +} -body { + set token [http::geturl http://$a4host:$a4port/] + set ri [http::responseInfo $token] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" +} -result {complete ok 400 none} -cleanup { + http::cleanup $token + unset -nocomplain ri res +} + +test httpProxy-1.4 {squid is running - ipv6 auth} -constraints {needsSquid} -setup { +} -body { + set token [http::geturl http://\[$a6host\]:$a6port/] + set ri [http::responseInfo $token] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" +} -result {complete ok 400 none} -cleanup { + http::cleanup $token + unset -nocomplain ri res +} + +test httpProxy-2.1 {http no-proxy no-auth} -constraints {needsSquid} -setup { + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" +} -result {complete ok 200 none} -cleanup { + http::cleanup $token + unset -nocomplain ri res +} + +test httpProxy-2.2 {https no-proxy no-auth} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" +} -result {complete ok 200 none} -cleanup { + http::cleanup $token + unset -nocomplain ri res +} + +test httpProxy-2.3 {http with-proxy ipv4 no-auth} -constraints {needsSquid} -setup { + http::config -proxyhost $n4host -proxyport $n4port -proxynot {127.0.0.1 localhost} -proxyauth {} +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" +} -result {complete ok 200 HttpProxy} -cleanup { + http::cleanup $token + unset -nocomplain ri res + http::config -proxyhost {} -proxyport {} -proxynot {} +} + +test httpProxy-2.4 {https with-proxy ipv4 no-auth} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost $n4host -proxyport $n4port -proxynot {127.0.0.1 localhost} -proxyauth {} +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" +} -result {complete ok 200 SecureProxy} -cleanup { + http::cleanup $token + unset -nocomplain ri res + http::config -proxyhost {} -proxyport {} -proxynot {} +} + +test httpProxy-2.5 {http with-proxy ipv6 no-auth} -constraints {needsSquid} -setup { + http::config -proxyhost $n6host -proxyport $n6port -proxynot {127.0.0.1 localhost} -proxyauth {} +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" +} -result {complete ok 200 HttpProxy} -cleanup { + http::cleanup $token + unset -nocomplain ri res + http::config -proxyhost {} -proxyport {} -proxynot {} +} + +test httpProxy-2.6 {https with-proxy ipv6 no-auth} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost $n6host -proxyport $n6port -proxynot {127.0.0.1 localhost} -proxyauth {} +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" +} -result {complete ok 200 SecureProxy} -cleanup { + http::cleanup $token + unset -nocomplain ri res + http::config -proxyhost {} -proxyport {} -proxynot {} +} + +test httpProxy-3.1 {http no-proxy with-auth valid-creds-provided} -constraints {needsSquid} -setup { + http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" +} -result {complete ok 200 none 0 0} -cleanup { + http::cleanup $token + unset -nocomplain ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.2 {https no-proxy with-auth valid-creds-provided} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" +} -result {complete ok 200 none 0 0} -cleanup { + http::cleanup $token + unset -nocomplain ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.3 {http with-proxy ipv4 with-auth valid-creds-provided} -constraints {needsSquid} -setup { + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" +} -result {complete ok 200 HttpProxy 1 1} -cleanup { + http::cleanup $token + unset -nocomplain ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.4 {https with-proxy ipv4 with-auth valid-creds-provided} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" +} -result {complete ok 200 SecureProxy 0 0} -cleanup { + http::cleanup $token + unset -nocomplain ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.5 {http with-proxy ipv6 with-auth valid-creds-provided} -constraints {needsSquid} -setup { + http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" +} -result {complete ok 200 HttpProxy 1 1} -cleanup { + http::cleanup $token + unset -nocomplain ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.6 {https with-proxy ipv6 with-auth valid-creds-provided} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" +} -result {complete ok 200 SecureProxy 0 0} -cleanup { + http::cleanup $token + unset -nocomplain ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.1 {http no-proxy with-auth no-creds-provided} -constraints {needsSquid} -setup { + http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" +} -result {complete ok 200 none 0 0} -cleanup { + http::cleanup $token + unset -nocomplain ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.2 {https no-proxy with-auth no-creds-provided} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" +} -result {complete ok 200 none 0 0} -cleanup { + http::cleanup $token + unset -nocomplain ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.3 {http with-proxy ipv4 with-auth no-creds-provided} -constraints {needsSquid} -setup { + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" +} -result {complete ok 407 HttpProxy 0 0} -cleanup { + http::cleanup $token + unset -nocomplain ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.4 {https with-proxy ipv4 with-auth no-creds-provided} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" +} -result {complete ok 407 SecureProxy 0 0} -cleanup { + http::cleanup $token + unset -nocomplain ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.5 {http with-proxy ipv6 with-auth no-creds-provided} -constraints {needsSquid} -setup { + http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth {} +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" +} -result {complete ok 407 HttpProxy 0 0} -cleanup { + http::cleanup $token + unset -nocomplain ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.6 {https with-proxy ipv6 with-auth no-creds-provided} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth {} +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" +} -result {complete ok 407 SecureProxy 0 0} -cleanup { + http::cleanup $token + unset -nocomplain ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.1 {http no-proxy with-auth bad-creds-provided} -constraints {needsSquid} -setup { + http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" +} -result {complete ok 200 none 0 0} -cleanup { + http::cleanup $token + unset -nocomplain ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.2 {https no-proxy with-auth bad-creds-provided} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" +} -result {complete ok 200 none 0 0} -cleanup { + http::cleanup $token + unset -nocomplain ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.3 {http with-proxy ipv4 with-auth bad-creds-provided} -constraints {needsSquid} -setup { + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" +} -result {complete ok 407 HttpProxy 1 1} -cleanup { + http::cleanup $token + unset -nocomplain ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.4 {https with-proxy ipv4 with-auth bad-creds-provided} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" +} -result {complete ok 407 SecureProxy 1 1} -cleanup { + http::cleanup $token + unset -nocomplain ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.5 {http with-proxy ipv6 with-auth bad-creds-provided} -constraints {needsSquid} -setup { + http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds +} -body { + set token [http::geturl http://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" +} -result {complete ok 407 HttpProxy 1 1} -cleanup { + http::cleanup $token + unset -nocomplain ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.6 {https with-proxy ipv6 with-auth bad-creds-provided} -constraints {needsSquid needsTls} -setup { + http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds +} -body { + set token [http::geturl https://www.google.com/] + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" +} -result {complete ok 407 SecureProxy 1 1} -cleanup { + http::cleanup $token + unset -nocomplain ri res pos1 pos2 + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +# cleanup +unset -nocomplain n4host n6host n4port n6port a4host a6host a4port a6port + +rename bgerror {} + +::tcltest::cleanupTests + +# Local variables: +# mode: tcl +# End: + diff --git a/tests/httpProxySquidConfigForEL8.tar.gz b/tests/httpProxySquidConfigForEL8.tar.gz new file mode 100644 index 0000000..a94dbdb Binary files /dev/null and b/tests/httpProxySquidConfigForEL8.tar.gz differ -- cgit v0.12 From 27f09fdb5ced601cb23ffc86b882c29a3ee7dd21 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 26 Oct 2022 09:43:48 +0000 Subject: www.tcl-tk.org -> www.tcl-lang.org --- unix/README | 4 ++-- unix/tcl.pc.in | 3 ++- win/rules.vc | 2 +- 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/unix/README b/unix/README index b43a260..a3180c9 100644 --- a/unix/README +++ b/unix/README @@ -8,11 +8,11 @@ MacOSX platform too, but they all depend on UNIX (POSIX/ANSI C) interfaces and some of them only make sense under UNIX. Updated forms of the information found in this file is available at: - https://www.tcl-tk.org/doc/howto/compile.html#unix + https://www.tcl-lang.org/doc/howto/compile.html#unix For information on platforms where Tcl is known to compile, along with any porting notes for getting it to work on those platforms, see: - https://www.tcl-tk.org/software/tcltk/platforms.html + https://www.tcl-lang.org/software/tcltk/platforms.html The rest of this file contains instructions on how to do this. The release should compile and run either "out of the box" or with trivial changes on any diff --git a/unix/tcl.pc.in b/unix/tcl.pc.in index 84754c6..93b5e69 100644 --- a/unix/tcl.pc.in +++ b/unix/tcl.pc.in @@ -4,10 +4,11 @@ prefix=@prefix@ exec_prefix=@exec_prefix@ libdir=@libdir@ includedir=@includedir@ +libfile=@TCL_LIB_FILE@ Name: Tool Command Language Description: Tcl is a powerful, easy-to-learn dynamic programming language, suitable for a wide range of uses. -URL: https://www.tcl-tk.org/ +URL: https://www.tcl-lang.org/ Version: @TCL_VERSION@@TCL_PATCH_LEVEL@ Requires.private: zlib >= 1.2.3 Libs: -L${libdir} @TCL_LIB_FLAG@ @TCL_STUB_LIB_FLAG@ diff --git a/win/rules.vc b/win/rules.vc index fdc68e0..8d28b10 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -707,7 +707,7 @@ LINKERFLAGS = $(LINKERFLAGS) -ltcg !if defined(_TK_H) !if [echo TK_MAJOR_VERSION = \>> versions.vc] \ - && [nmakehlp -V $(_TK_H) TK_MAJOR_VERSION >> versions.vc] + && [nmakehlp -V $(_TK_H) "define TK_MAJOR_VERSION" >> versions.vc] !endif !if [echo TK_MINOR_VERSION = \>> versions.vc] \ && [nmakehlp -V $(_TK_H) TK_MINOR_VERSION >> versions.vc] -- cgit v0.12 From 2ecf92f50b4fad000f8cf4b368ce47c6035bdf4c Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 26 Oct 2022 11:28:29 +0000 Subject: Minor changes to http tests. --- tests/http.test | 5 ++++- tests/httpProxy.test | 2 +- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/tests/http.test b/tests/http.test index 18850d9..6826448 100644 --- a/tests/http.test +++ b/tests/http.test @@ -631,7 +631,10 @@ test http-4.14 {http::Event} -body { test http-4.15 {http::Event} -body { # This test may fail if you use a proxy server. That is to be # expected and is not a problem with Tcl. - set token [http::geturl //not_a_host.tcl.tk -timeout 3000 -command \#] + # With http::config -threadlevel 1 or 2, the script enters the event loop + # during the DNS lookup, and has the opportunity to time out. + # Increase -timeout from 3000 to 10000 to prevent this. + set token [http::geturl //not_a_host.tcl.tk -timeout 10000 -command \#] http::wait $token set result "[http::status $token] -- [lindex [http::error $token] 0]" # error codes vary among platforms. diff --git a/tests/httpProxy.test b/tests/httpProxy.test index 2d0bea2..42ad574 100644 --- a/tests/httpProxy.test +++ b/tests/httpProxy.test @@ -444,7 +444,7 @@ test httpProxy-5.6 {https with-proxy ipv6 with-auth bad-creds-provided} -constra } # cleanup -unset -nocomplain n4host n6host n4port n6port a4host a6host a4port a6port +unset -nocomplain n4host n6host n4port n6port a4host a6host a4port a6port aliceCreds badCreds rename bgerror {} -- cgit v0.12 From 2a8ceac88856d04e3da9842fa65cf1982733bf72 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 27 Oct 2022 13:33:10 +0000 Subject: Fix [8e2d10698b]: ioCmd.test tests need updates for -eofchar changes --- tests/ioCmd.test | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/ioCmd.test b/tests/ioCmd.test index c8daa96..9e53201 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -2905,7 +2905,7 @@ test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body rename foo {} set res } -constraints {testchannel thread} \ - -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} * -translation {auto *}}} + -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} * -translation {auto *}}} test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -2918,7 +2918,7 @@ test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { rename foo {} set res } -constraints {testchannel thread} \ - -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} * -translation {auto *}}} + -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} * -translation {auto *}}} test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -2934,7 +2934,7 @@ test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { rename foo {} set res } -constraints {testchannel thread} \ - -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} * -translation {auto *} -bar foo -snarf x}} + -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {} * -translation {auto *} -bar foo -snarf x}} test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { -- cgit v0.12 From 4a0240f1539380862fa46bac023272dcc8557053 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 27 Oct 2022 13:48:34 +0000 Subject: In a -singleproc 1 test run, [info loaded] can report libraries brought in by other test files. Protect the tests that care about that. --- tests/load.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/load.test b/tests/load.test index 728fad9..bc964a1 100644 --- a/tests/load.test +++ b/tests/load.test @@ -202,13 +202,13 @@ test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loa test load-8.2 {TclGetLoadedPackages procedure} -constraints {teststaticpkg_8.x} -body { info loaded gorp } -returnCodes error -result {could not find interpreter "gorp"} -test load-8.3a {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { +test load-8.3a {TclGetLoadedPackages procedure} [list !singleTestInterp teststaticpkg_8.x $dll $loaded] { lsort -index 1 [info loaded {}] } [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]] test load-8.3b {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { lsort -index 1 [info loaded child] } [lsort -index 1 [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]] -test load-8.4 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { +test load-8.4 {TclGetLoadedPackages procedure} [list !singleTestInterp teststaticpkg_8.x $dll $loaded] { load [file join $testDir pkgb$ext] Pkgb list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]] } [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}] -- cgit v0.12 From 6de2b2c1d639ec54c557ae563819bbcaf9ebd81e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 27 Oct 2022 14:01:17 +0000 Subject: Handle TCL_ENCODING_STRICT and TCL_CLOSE2PROC correctly, when building in --with-tcl8 mode --- generic/tcl.h | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 419929c..cb781a6 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -1294,7 +1294,11 @@ typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, void *clientData); * interface. */ -#define TCL_CLOSE2PROC NULL +#if TCL_MAJOR_VERSION > 8 +# define TCL_CLOSE2PROC NULL +#else +# define TCL_CLOSE2PROC ((void *) 1) +#endif /* * Channel version tag. This was introduced in 8.3.2/8.4. @@ -1960,8 +1964,13 @@ typedef struct Tcl_EncodingType { #define TCL_ENCODING_START 0x01 #define TCL_ENCODING_END 0x02 -#define TCL_ENCODING_STRICT 0x04 -#define TCL_ENCODING_STOPONERROR 0x0 /* Not used any more */ +#if TCL_MAJOR_VERSION > 8 +# define TCL_ENCODING_STRICT 0x04 +# define TCL_ENCODING_STOPONERROR 0x0 /* Not used any more */ +#else +# define TCL_ENCODING_STRICT 0x44 +# define TCL_ENCODING_STOPONERROR 0x04 +#endif #define TCL_ENCODING_NO_TERMINATE 0x08 #define TCL_ENCODING_CHAR_LIMIT 0x10 #define TCL_ENCODING_MODIFIED 0x20 @@ -2339,7 +2348,7 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); #define Tcl_SetPreInitScript(string) \ ((const char *(*)(const char *))TclStubCall((void *)9))(string) #endif - + /* *---------------------------------------------------------------------------- * Include the public function declarations that are accessible via the stubs @@ -2469,7 +2478,7 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); */ #define Tcl_GetHashValue(h) ((h)->clientData) -#define Tcl_SetHashValue(h, value) ((h)->clientData = (void *) (value)) +#define Tcl_SetHashValue(h, value) ((h)->clientData = (void *)(value)) #define Tcl_GetHashKey(tablePtr, h) \ ((void *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS || \ (tablePtr)->keyType == TCL_CUSTOM_PTR_KEYS) \ @@ -2481,8 +2490,10 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); * hash tables: */ +#undef Tcl_FindHashEntry #define Tcl_FindHashEntry(tablePtr, key) \ (*((tablePtr)->findProc))(tablePtr, (const char *)(key)) +#undef Tcl_CreateHashEntry #define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ (*((tablePtr)->createProc))(tablePtr, (const char *)(key), newPtr) -- cgit v0.12 From a7a483bf2a2a585bf2f1e2befbd465dea8a310b1 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 27 Oct 2022 14:35:12 +0000 Subject: Revised fix to the -singleproc 1 issue in load.test --- tests/load.test | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/load.test b/tests/load.test index bc964a1..78087bc 100644 --- a/tests/load.test +++ b/tests/load.test @@ -31,7 +31,7 @@ testConstraint $dll [file readable $x] # Tests also require that this DLL has not already been loaded. set loaded "[file tail $x]Loaded" -set alreadyLoaded [info loaded] +set alreadyLoaded [info loaded {}] testConstraint $loaded [expr {![string match *pkga* $alreadyLoaded]}] set alreadyTotalLoaded [info loaded] @@ -202,13 +202,13 @@ test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loa test load-8.2 {TclGetLoadedPackages procedure} -constraints {teststaticpkg_8.x} -body { info loaded gorp } -returnCodes error -result {could not find interpreter "gorp"} -test load-8.3a {TclGetLoadedPackages procedure} [list !singleTestInterp teststaticpkg_8.x $dll $loaded] { +test load-8.3a {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { lsort -index 1 [info loaded {}] } [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]] test load-8.3b {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { lsort -index 1 [info loaded child] } [lsort -index 1 [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]] -test load-8.4 {TclGetLoadedPackages procedure} [list !singleTestInterp teststaticpkg_8.x $dll $loaded] { +test load-8.4 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { load [file join $testDir pkgb$ext] Pkgb list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]] } [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}] -- cgit v0.12 From d74dc7638ccf0c79a057c87ef0f05b7fd6974588 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 27 Oct 2022 17:10:04 +0000 Subject: Test hygiene. This was creating one more thread than it destroyed. In a -singleproc 1 test run, this caused tests in later test files to fail because the stray thread causes test results to be different. --- tests/http.test | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/tests/http.test b/tests/http.test index 6826448..eb2bf29 100644 --- a/tests/http.test +++ b/tests/http.test @@ -47,6 +47,7 @@ if {![file exists $httpdFile]} { catch {package require Thread 2.7-} if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { set httpthread [thread::create -preserved] + lappend threadStack [list thread::release $httpthread] thread::send $httpthread [list source $httpdFile] thread::send $httpthread [list set bindata $bindata] thread::send $httpthread {httpd_init 0; set port} port @@ -64,6 +65,7 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { catch {unset port} return } + set threadStack {} } if {![info exists ThreadLevel]} { @@ -78,6 +80,7 @@ if {![info exists ThreadLevel]} { foreach ThreadLevel $ValueRange { source [info script] } + try [lpop threadStack] catch {unset ThreadLevel} catch {unset ValueRange} return @@ -1168,8 +1171,8 @@ catch {unset url} catch {unset badurl} catch {unset port} catch {unset data} -if {[info exists httpthread]} { - thread::release $httpthread +if {[llength $threadStack]} { + try [lpop threadStack] } else { close $listen } -- cgit v0.12 From c74a13788aa580ddc5a191f22096fb0a2758d41d Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 27 Oct 2022 18:38:55 +0000 Subject: duplicate test names --- tests/binary.test | 2 +- tests/http11.test | 96 ++++++++++++++++++++++++++--------------------------- tests/lreplace.test | 2 +- tests/scan.test | 2 +- 4 files changed, 51 insertions(+), 51 deletions(-) diff --git a/tests/binary.test b/tests/binary.test index a43fb49..151659a 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -767,7 +767,7 @@ test binary-21.13 {Tcl_BinaryObjCmd: scan} -setup { } -body { list [binary scan "abc def \x00 " C* arg1] $arg1 } -result {1 {abc def }} -test binary-21.12 {Tcl_BinaryObjCmd: scan} -setup { +test binary-21.14 {Tcl_BinaryObjCmd: scan} -setup { unset -nocomplain arg1 } -body { list [binary scan "abc def \x00ghi" C* arg1] $arg1 diff --git a/tests/http11.test b/tests/http11.test index 71ef4c7..ef1f40c 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -108,7 +108,7 @@ http::config -threadlevel $ThreadLevel # ------------------------------------------------------------------------- -test http11-1.0 "normal request for document " -setup { +test http11-1.0.$ThreadLevel "normal request for document " -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html -timeout 10000] @@ -119,7 +119,7 @@ test http11-1.0 "normal request for document " -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close} -test http11-1.1 "normal,gzip,non-chunked" -setup { +test http11-1.1.$ThreadLevel "normal,gzip,non-chunked" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ @@ -133,7 +133,7 @@ test http11-1.1 "normal,gzip,non-chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok gzip {} {content-encoding gzip} {}} -test http11-1.2 "normal,deflated,non-chunked" -setup { +test http11-1.2.$ThreadLevel "normal,deflated,non-chunked" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ @@ -146,7 +146,7 @@ test http11-1.2 "normal,deflated,non-chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok deflate {}} -test http11-1.2.1 "normal,deflated,non-chunked,msdeflate" -setup { +test http11-1.2.1.$ThreadLevel "normal,deflated,non-chunked,msdeflate" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1&msdeflate=1 \ @@ -159,7 +159,7 @@ test http11-1.2.1 "normal,deflated,non-chunked,msdeflate" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok deflate {}} -test http11-1.3 "normal,compressed,non-chunked" -constraints badCompress -setup { +test http11-1.3.$ThreadLevel "normal,compressed,non-chunked" -constraints badCompress -setup { # The Tcl "compress" algorithm appears to be incorrect and has been removed. # Bug [a13b9d0ce1]. variable httpd [create_httpd] @@ -174,7 +174,7 @@ test http11-1.3 "normal,compressed,non-chunked" -constraints badCompress -setup halt_httpd } -result {ok {HTTP/1.1 200 OK} ok compress {}} -test http11-1.4 "normal,identity,non-chunked" -setup { +test http11-1.4.$ThreadLevel "normal,identity,non-chunked" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ @@ -187,7 +187,7 @@ test http11-1.4 "normal,identity,non-chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} {}} -test http11-1.5 "normal request for document, unsupported coding" -setup { +test http11-1.5.$ThreadLevel "normal request for document, unsupported coding" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ @@ -200,7 +200,7 @@ test http11-1.5 "normal request for document, unsupported coding" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {}} -test http11-1.6 "normal, specify 1.1 " -setup { +test http11-1.6.$ThreadLevel "normal, specify 1.1 " -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ @@ -214,7 +214,7 @@ test http11-1.6 "normal, specify 1.1 " -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close chunked {connection close} {transfer-encoding chunked}} -test http11-1.7 "normal, 1.1 and keepalive " -setup { +test http11-1.7.$ThreadLevel "normal, 1.1 and keepalive " -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ @@ -227,7 +227,7 @@ test http11-1.7 "normal, 1.1 and keepalive " -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} chunked} -test http11-1.8 "normal, 1.1 and keepalive, server close" -setup { +test http11-1.8.$ThreadLevel "normal, 1.1 and keepalive, server close" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?close=1 \ @@ -240,7 +240,7 @@ test http11-1.8 "normal, 1.1 and keepalive, server close" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close {}} -test http11-1.9 "normal,gzip,chunked" -setup { +test http11-1.9.$ThreadLevel "normal,gzip,chunked" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ @@ -253,7 +253,7 @@ test http11-1.9 "normal,gzip,chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok gzip chunked} -test http11-1.10 "normal,deflate,chunked" -setup { +test http11-1.10.$ThreadLevel "normal,deflate,chunked" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ @@ -266,7 +266,7 @@ test http11-1.10 "normal,deflate,chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok deflate chunked} -test http11-1.10.1 "normal,deflate,chunked,msdeflate" -setup { +test http11-1.10.1.$ThreadLevel "normal,deflate,chunked,msdeflate" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html?msdeflate=1 \ @@ -279,7 +279,7 @@ test http11-1.10.1 "normal,deflate,chunked,msdeflate" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok deflate chunked} -test http11-1.11 "normal,compress,chunked" -constraints badCompress -setup { +test http11-1.11.$ThreadLevel "normal,compress,chunked" -constraints badCompress -setup { # The Tcl "compress" algorithm appears to be incorrect and has been removed. # Bug [a13b9d0ce1]. variable httpd [create_httpd] @@ -294,7 +294,7 @@ test http11-1.11 "normal,compress,chunked" -constraints badCompress -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok compress chunked} -test http11-1.12 "normal,identity,chunked" -setup { +test http11-1.12.$ThreadLevel "normal,identity,chunked" -setup { variable httpd [create_httpd] } -body { set tok [http::geturl http://localhost:$httpd_port/testdoc.html \ @@ -307,7 +307,7 @@ test http11-1.12 "normal,identity,chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} chunked} -test http11-1.13 "normal, 1.1 and keepalive as server default, no zip" -setup { +test http11-1.13.$ThreadLevel "normal, 1.1 and keepalive as server default, no zip" -setup { variable httpd [create_httpd] set zipTmp [http::config -zip] http::config -zip 0 @@ -346,7 +346,7 @@ proc progressPause {var token total current} { return } -test http11-2.0 "-channel" -setup { +test http11-2.0.$ThreadLevel "-channel" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -364,7 +364,7 @@ test http11-2.0 "-channel" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close chunked} -test http11-2.1 "-channel, encoding gzip" -setup { +test http11-2.1.$ThreadLevel "-channel, encoding gzip" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -387,7 +387,7 @@ test http11-2.1 "-channel, encoding gzip" -setup { # Cf. Bug [3610253] "CopyChunk does not drain decompressor(s)" # This test failed before the bugfix. # The pass/fail depended on file size. -test http11-2.1.1 "-channel, encoding gzip" -setup { +test http11-2.1.1.$ThreadLevel "-channel, encoding gzip" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] set fileName largedoc.html @@ -408,7 +408,7 @@ test http11-2.1.1 "-channel, encoding gzip" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close gzip chunked -- 0 bytes lost} -test http11-2.2 "-channel, encoding deflate" -setup { +test http11-2.2.$ThreadLevel "-channel, encoding deflate" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -427,7 +427,7 @@ test http11-2.2 "-channel, encoding deflate" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close deflate chunked} -test http11-2.2.1 "-channel, encoding deflate,msdeflate" -setup { +test http11-2.2.1.$ThreadLevel "-channel, encoding deflate,msdeflate" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -446,7 +446,7 @@ test http11-2.2.1 "-channel, encoding deflate,msdeflate" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close deflate chunked} -test http11-2.3 "-channel,encoding compress" -constraints badCompress -setup { +test http11-2.3.$ThreadLevel "-channel,encoding compress" -constraints badCompress -setup { # The Tcl "compress" algorithm appears to be incorrect and has been removed. # Bug [a13b9d0ce1]. variable httpd [create_httpd] @@ -468,7 +468,7 @@ test http11-2.3 "-channel,encoding compress" -constraints badCompress -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close compress chunked} -test http11-2.4 "-channel,encoding identity" -setup { +test http11-2.4.$ThreadLevel "-channel,encoding identity" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -488,7 +488,7 @@ test http11-2.4 "-channel,encoding identity" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close {} chunked} -test http11-2.4.1 "-channel,encoding identity with -progress" -setup { +test http11-2.4.1.$ThreadLevel "-channel,encoding identity with -progress" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] set logdata "" @@ -514,7 +514,7 @@ test http11-2.4.1 "-channel,encoding identity with -progress" -setup { unset -nocomplain logdata data } -result {ok {HTTP/1.1 200 OK} ok close {} chunked 0 0} -test http11-2.4.2 "-channel,encoding identity with -progress progressPause enters event loop" -constraints knownBug -setup { +test http11-2.4.2.$ThreadLevel "-channel,encoding identity with -progress progressPause enters event loop" -constraints knownBug -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] set logdata "" @@ -540,7 +540,7 @@ test http11-2.4.2 "-channel,encoding identity with -progress progressPause enter unset -nocomplain logdata data ::WaitHere } -result {ok {HTTP/1.1 200 OK} ok close {} chunked 0 0} -test http11-2.5 "-channel,encoding unsupported" -setup { +test http11-2.5.$ThreadLevel "-channel,encoding unsupported" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -560,7 +560,7 @@ test http11-2.5 "-channel,encoding unsupported" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close {} chunked} -test http11-2.6 "-channel,encoding gzip,non-chunked" -setup { +test http11-2.6.$ThreadLevel "-channel,encoding gzip,non-chunked" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -580,7 +580,7 @@ test http11-2.6 "-channel,encoding gzip,non-chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close gzip {} 0} -test http11-2.7 "-channel,encoding deflate,non-chunked" -setup { +test http11-2.7.$ThreadLevel "-channel,encoding deflate,non-chunked" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -600,7 +600,7 @@ test http11-2.7 "-channel,encoding deflate,non-chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close deflate {} 0} -test http11-2.7.1 "-channel,encoding deflate,non-chunked,msdeflate" -constraints knownBug -setup { +test http11-2.7.1.$ThreadLevel "-channel,encoding deflate,non-chunked,msdeflate" -constraints knownBug -setup { # Test fails because a -channel can only try one un-deflate algorithm, and the # compliant "decompress" is tried, not the non-compliant "inflate" of # the MS browser implementation. @@ -623,7 +623,7 @@ test http11-2.7.1 "-channel,encoding deflate,non-chunked,msdeflate" -constraints halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close deflate {} 0} -test http11-2.8 "-channel,encoding compress,non-chunked" -constraints badCompress -setup { +test http11-2.8.$ThreadLevel "-channel,encoding compress,non-chunked" -constraints badCompress -setup { # The Tcl "compress" algorithm appears to be incorrect and has been removed. # Bug [a13b9d0ce1]. variable httpd [create_httpd] @@ -645,7 +645,7 @@ test http11-2.8 "-channel,encoding compress,non-chunked" -constraints badCompres halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close compress {} 0} -test http11-2.9 "-channel,encoding identity,non-chunked" -setup { +test http11-2.9.$ThreadLevel "-channel,encoding identity,non-chunked" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -665,7 +665,7 @@ test http11-2.9 "-channel,encoding identity,non-chunked" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close {} {} 0} -test http11-2.10 "-channel,deflate,keepalive" -setup { +test http11-2.10.$ThreadLevel "-channel,deflate,keepalive" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -686,7 +686,7 @@ test http11-2.10 "-channel,deflate,keepalive" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} deflate chunked 0} -test http11-2.10.1 "-channel,deflate,keepalive,msdeflate" -setup { +test http11-2.10.1.$ThreadLevel "-channel,deflate,keepalive,msdeflate" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -707,7 +707,7 @@ test http11-2.10.1 "-channel,deflate,keepalive,msdeflate" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} deflate chunked 0} -test http11-2.11 "-channel,identity,keepalive" -setup { +test http11-2.11.$ThreadLevel "-channel,identity,keepalive" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -727,7 +727,7 @@ test http11-2.11 "-channel,identity,keepalive" -setup { halt_httpd } -result {ok {HTTP/1.1 200 OK} ok {} {} chunked} -test http11-2.12 "-channel,negotiate,keepalive" -setup { +test http11-2.12.$ThreadLevel "-channel,negotiate,keepalive" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] } -body { @@ -775,7 +775,7 @@ proc handlerPause {var sock token} { return [string length $chunk] } -test http11-3.0 "-handler,close,identity" -setup { +test http11-3.0.$ThreadLevel "-handler,close,identity" -setup { variable httpd [create_httpd] set testdata "" } -body { @@ -792,7 +792,7 @@ test http11-3.0 "-handler,close,identity" -setup { halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} -test http11-3.1 "-handler,protocol1.0" -setup { +test http11-3.1.$ThreadLevel "-handler,protocol1.0" -setup { variable httpd [create_httpd] set testdata "" } -body { @@ -810,7 +810,7 @@ test http11-3.1 "-handler,protocol1.0" -setup { halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} -test http11-3.2 "-handler,close,chunked" -setup { +test http11-3.2.$ThreadLevel "-handler,close,chunked" -setup { variable httpd [create_httpd] set testdata "" } -body { @@ -828,7 +828,7 @@ test http11-3.2 "-handler,close,chunked" -setup { halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} -test http11-3.3 "-handler,keepalive,chunked" -setup { +test http11-3.3.$ThreadLevel "-handler,keepalive,chunked" -setup { variable httpd [create_httpd] set testdata "" } -body { @@ -856,7 +856,7 @@ test http11-3.3 "-handler,keepalive,chunked" -setup { # "Connection: keep-alive", i.e. the server will keep the connection # open. In HTTP/1.0 this is not the case, and this is a test that # the Tcl client assumes "Connection: close" by default in HTTP/1.0. -test http11-3.4 "-handler,close,identity; HTTP/1.0 server does not send Connection: close header or Content-Length" -setup { +test http11-3.4.$ThreadLevel "-handler,close,identity; HTTP/1.0 server does not send Connection: close header or Content-Length" -setup { variable httpd [create_httpd] set testdata "" } -body { @@ -874,7 +874,7 @@ test http11-3.4 "-handler,close,identity; HTTP/1.0 server does not send Connecti } -result {ok {HTTP/1.0 200 OK} ok {} {} {} 0} # It is not forbidden for a handler to enter the event loop. -test http11-3.5 "-handler,close,identity as http11-3.0 but handlerPause enters event loop" -setup { +test http11-3.5.$ThreadLevel "-handler,close,identity as http11-3.0 but handlerPause enters event loop" -setup { variable httpd [create_httpd] set testdata "" } -body { @@ -891,7 +891,7 @@ test http11-3.5 "-handler,close,identity as http11-3.0 but handlerPause enters e halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0} -test http11-3.6 "-handler,close,identity as http11-3.0 but with -progress" -setup { +test http11-3.6.$ThreadLevel "-handler,close,identity as http11-3.0 but with -progress" -setup { variable httpd [create_httpd] set testdata "" set logdata "" @@ -912,7 +912,7 @@ test http11-3.6 "-handler,close,identity as http11-3.0 but with -progress" -setu halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0 0 0} -test http11-3.7 "-handler,close,identity as http11-3.0 but with -progress progressPause enters event loop" -setup { +test http11-3.7.$ThreadLevel "-handler,close,identity as http11-3.0 but with -progress progressPause enters event loop" -setup { variable httpd [create_httpd] set testdata "" set logdata "" @@ -933,7 +933,7 @@ test http11-3.7 "-handler,close,identity as http11-3.0 but with -progress progre halt_httpd } -result {ok {HTTP/1.0 200 OK} ok close {} {} 0 0 0} -test http11-3.8 "close,identity no -handler but with -progress" -setup { +test http11-3.8.$ThreadLevel "close,identity no -handler but with -progress" -setup { variable httpd [create_httpd] set logdata "" } -body { @@ -975,7 +975,7 @@ test http11-3.9 "close,identity no -handler but with -progress progressPause ent halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close {} {} 0 0 0} -test http11-4.0 "normal post request" -setup { +test http11-4.0.$ThreadLevel "normal post request" -setup { variable httpd [create_httpd] } -body { set query [http::formatQuery q 1 z 2] @@ -991,7 +991,7 @@ test http11-4.0 "normal post request" -setup { halt_httpd } -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 7} -test http11-4.1 "normal post request, check query length" -setup { +test http11-4.1.$ThreadLevel "normal post request, check query length" -setup { variable httpd [create_httpd] } -body { set query [http::formatQuery q 1 z 2] @@ -1008,7 +1008,7 @@ test http11-4.1 "normal post request, check query length" -setup { halt_httpd } -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 7} -test http11-4.2 "normal post request, check long query length" -setup { +test http11-4.2.$ThreadLevel "normal post request, check long query length" -setup { variable httpd [create_httpd] } -body { set query [string repeat a 24576] @@ -1025,7 +1025,7 @@ test http11-4.2 "normal post request, check long query length" -setup { halt_httpd } -result {status ok code {HTTP/1.1 200 OK} crc ok connection close query-length 24576} -test http11-4.3 "normal post request, check channel query length" -setup { +test http11-4.3.$ThreadLevel "normal post request, check channel query length" -setup { variable httpd [create_httpd] set chan [open [makeFile {} testfile.tmp] wb+] puts -nonewline $chan [string repeat [encoding convertto utf-8 "This is a test\n"] 8192] diff --git a/tests/lreplace.test b/tests/lreplace.test index 2952899..009170e 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -434,7 +434,7 @@ test ledit-4.4 {ledit edge case} { set l {1 2 3 4 5} list [ledit l 3 1] $l } {{1 2 3 4 5} {1 2 3 4 5}} -test lreplace-4.5 {lreplace edge case} { +test ledit-4.5 {ledit edge case} { lreplace {1 2 3 4 5} 3 0 _ } {1 2 3 _ 4 5} test ledit-4.6 {ledit end-x: bug a4cb3f06c4} { diff --git a/tests/scan.test b/tests/scan.test index c6e7922..03a5b46 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -605,7 +605,7 @@ test scan-6.8 {floating-point scanning} -setup { } -body { list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d } -result {2 4.6 5.2 {} {}} -test scan-6.8 {disallow diget separator in floating-point} -setup { +test scan-6.9 {disallow diget separator in floating-point} -setup { set a {}; set b {}; set c {}; } -body { list [scan "3.14_2.35_98.6" %f_%f_%f a b c ] $a $b $c -- cgit v0.12 From f87e100731a2d67fcbac3fa297934bbba91b7889 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 27 Oct 2022 21:19:36 +0000 Subject: try -> catch --- tests/http.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/http.test b/tests/http.test index eb2bf29..1ff570e 100644 --- a/tests/http.test +++ b/tests/http.test @@ -80,7 +80,7 @@ if {![info exists ThreadLevel]} { foreach ThreadLevel $ValueRange { source [info script] } - try [lpop threadStack] + catch {lpop threadStack} catch {unset ThreadLevel} catch {unset ValueRange} return -- cgit v0.12 From c0cffed37f1950c005805fe0b43a8993dad46f49 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 27 Oct 2022 21:58:38 +0000 Subject: backout [95cb836c8c]: "try [lpop threadStack]", that cannot be right --- tests/http.test | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/tests/http.test b/tests/http.test index 1ff570e..6826448 100644 --- a/tests/http.test +++ b/tests/http.test @@ -47,7 +47,6 @@ if {![file exists $httpdFile]} { catch {package require Thread 2.7-} if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { set httpthread [thread::create -preserved] - lappend threadStack [list thread::release $httpthread] thread::send $httpthread [list source $httpdFile] thread::send $httpthread [list set bindata $bindata] thread::send $httpthread {httpd_init 0; set port} port @@ -65,7 +64,6 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { catch {unset port} return } - set threadStack {} } if {![info exists ThreadLevel]} { @@ -80,7 +78,6 @@ if {![info exists ThreadLevel]} { foreach ThreadLevel $ValueRange { source [info script] } - catch {lpop threadStack} catch {unset ThreadLevel} catch {unset ValueRange} return @@ -1171,8 +1168,8 @@ catch {unset url} catch {unset badurl} catch {unset port} catch {unset data} -if {[llength $threadStack]} { - try [lpop threadStack] +if {[info exists httpthread]} { + thread::release $httpthread } else { close $listen } -- cgit v0.12 From 18fb3780723b2613640a274c1b76831ebceadfeb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 28 Oct 2022 11:18:53 +0000 Subject: TIP #646 correction: let "fconfigure $chan -eofchar" return a single character, not a list element --- ChangeLog.2000 | 2 +- changes | 2 +- generic/regc_locale.c | 2 +- generic/tclIO.c | 16 ++++++++-------- generic/tclIOUtil.c | 12 ++++++------ library/install.tcl | 6 +++--- tests/chan.test | 12 +++++++----- tests/chanio.test | 14 +++++++------- tests/io.test | 16 ++++++++-------- tools/regexpTestLib.tcl | 4 ++-- 10 files changed, 44 insertions(+), 42 deletions(-) diff --git a/ChangeLog.2000 b/ChangeLog.2000 index 7e78c19..8abe6c2 100644 --- a/ChangeLog.2000 +++ b/ChangeLog.2000 @@ -1356,7 +1356,7 @@ * doc/source.n: * doc/Eval.3: * tests/source.test: - * generic/tclIOUtil.c (Tcl_EvalFile): added explicit \32 (^Z) eofchar + * generic/tclIOUtil.c (Tcl_EvalFile): added explicit \x1A (^Z) eofchar (affects Tcl_EvalFile in C, "source" in Tcl). This was implicit on Windows already, and is now cross-platform to allow for scripted documents. diff --git a/changes b/changes index 286f30b..d6347f1 100644 --- a/changes +++ b/changes @@ -4976,7 +4976,7 @@ msgcat package (duperval, krone, nelson) trace {add|remove|list} {variable|command} name ops command (darley, melski) -2000-09-06 (cross-platform feature) Set ^Z (\32) as default EOF char. (hobbs) +2000-09-06 (cross-platform feature) Set ^Z (\x1A) as default EOF char. (hobbs) 2000-09-07 partial fix for bug 2460 to prevent exec mem leak on Windows for the common case (gravereaux) diff --git a/generic/regc_locale.c b/generic/regc_locale.c index 7252b88..7d182e4 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -110,7 +110,7 @@ static const struct cname { {"right-brace", '}'}, {"right-curly-bracket", '}'}, {"tilde", '~'}, - {"DEL", '\177'}, + {"DEL", '\x7F'}, {NULL, 0} }; diff --git a/generic/tclIO.c b/generic/tclIO.c index 374f770..b3b62ed 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -7930,20 +7930,18 @@ Tcl_GetChannelOption( } } if (len == 0 || HaveOpt(2, "-eofchar")) { + char buf[4] = ""; if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-eofchar"); } - if (!(flags & TCL_READABLE) || (statePtr->inEofChar == 0)) { - Tcl_DStringAppendElement(dsPtr, ""); - } else { - char buf[4]; - + if ((flags & TCL_READABLE) && (statePtr->inEofChar != 0)) { sprintf(buf, "%c", statePtr->inEofChar); - Tcl_DStringAppendElement(dsPtr, buf); } if (len > 0) { + Tcl_DStringAppend(dsPtr, buf, TCL_INDEX_NONE); return TCL_OK; } + Tcl_DStringAppendElement(dsPtr, buf); } if (len == 0 || HaveOpt(1, "-nocomplainencoding")) { if (len == 0) { @@ -8181,6 +8179,7 @@ Tcl_SetChannelOption( if (GotFlag(statePtr, TCL_READABLE)) { statePtr->inEofChar = newValue[0]; } +#ifndef TCL_NO_DEPRECATED } else if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; } else if (argc == 0) { @@ -8201,11 +8200,12 @@ Tcl_SetChannelOption( if (GotFlag(statePtr, TCL_READABLE)) { statePtr->inEofChar = inValue; } +#endif } else { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad value for -eofchar: should be a list of zero," - " one, or two elements", -1)); + "bad value for -eofchar: must be non-NUL ASCII" + " character", -1)); } Tcl_Free((void *)argv); return TCL_ERROR; diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index aa92754..470977e 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -1715,11 +1715,11 @@ Tcl_FSEvalFileEx( } /* - * The eof character is \32 (^Z). This is standard on Windows, and Tcl - * uses it on every platform to allow for scripted documents. [Bug: 2040] + * The eof character is \x1A (^Z). Tcl uses it on every platform to allow + * for scripted documents. [Bug: 2040] */ - Tcl_SetChannelOption(interp, chan, "-eofchar", "\32 {}"); + Tcl_SetChannelOption(interp, chan, "-eofchar", "\x1A"); /* * If the encoding is specified, set the channel to that encoding. @@ -1851,11 +1851,11 @@ TclNREvalFile( TclPkgFileSeen(interp, TclGetString(pathPtr)); /* - * The eof character is \32 (^Z). This is standard on Windows, and Tcl - * uses it on every platform to allow for scripted documents. [Bug: 2040] + * The eof character is \x1A (^Z). Tcl uses it on every platform to allow + * for scripted documents. [Bug: 2040] */ - Tcl_SetChannelOption(interp, chan, "-eofchar", "\32 {}"); + Tcl_SetChannelOption(interp, chan, "-eofchar", "\x1A"); /* * If the encoding is specified, set the channel to that encoding. diff --git a/library/install.tcl b/library/install.tcl index 50e40df..4abdead 100644 --- a/library/install.tcl +++ b/library/install.tcl @@ -35,7 +35,7 @@ proc ::practcl::_pkgindex_directory {path} { # Read the file, and override assumptions as needed ### set fin [open $file r] - fconfigure $fin -encoding utf-8 -eofchar "\x1A {}" + fconfigure $fin -encoding utf-8 -eofchar \x1A set dat [read $fin] close $fin # Look for a teapot style Package statement @@ -59,7 +59,7 @@ proc ::practcl::_pkgindex_directory {path} { foreach file [glob -nocomplain $path/*.tcl] { if { [file tail $file] == "version_info.tcl" } continue set fin [open $file r] - fconfigure $fin -encoding utf-8 -eofchar "\x1A {}" + fconfigure $fin -encoding utf-8 -eofchar \x1A set dat [read $fin] close $fin if {![regexp "package provide" $dat]} continue @@ -79,7 +79,7 @@ proc ::practcl::_pkgindex_directory {path} { return $buffer } set fin [open $pkgidxfile r] - fconfigure $fin -encoding utf-8 -eofchar "\x1A {}" + fconfigure $fin -encoding utf-8 -eofchar \x1A set dat [read $fin] close $fin set trace 0 diff --git a/tests/chan.test b/tests/chan.test index 280783f..946e424 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -12,6 +12,8 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +package require tcltests + # # Note: The tests for the chan methods "create" and "postevent" # currently reside in the file "ioCmd.test". @@ -49,19 +51,19 @@ test chan-4.1 {chan command: configure subcommand} -body { } -returnCodes error -result "wrong # args: should be \"chan configure channelId ?-option value ...?\"" test chan-4.2 {chan command: [Bug 800753]} -body { chan configure stdout -eofchar Ā -} -returnCodes error -match glob -result {bad value*} +} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character} test chan-4.3 {chan command: [Bug 800753]} -body { chan configure stdout -eofchar \x00 -} -returnCodes error -match glob -result {bad value*} -test chan-4.4 {chan command: check valid inValue, no outValue} -body { +} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character} +test chan-4.4 {chan command: check valid inValue, no outValue} -constraints deprecated -body { chan configure stdout -eofchar [list \x27 {}] } -result {} test chan-4.5 {chan command: check valid inValue, invalid outValue} -body { chan configure stdout -eofchar [list \x27 \x80] -} -returnCodes error -match glob -result {bad value for -eofchar:*} +} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character} test chan-4.6 {chan command: check no inValue, valid outValue} -body { chan configure stdout -eofchar [list {} \x27] -} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character} -cleanup {chan configure stdout -eofchar [list {} {}]} +} -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character} -cleanup {chan configure stdout -eofchar {}} test chan-5.1 {chan command: copy subcommand} -body { chan copy foo diff --git a/tests/chanio.test b/tests/chanio.test index c7cde60..91cfcd4 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -1889,13 +1889,13 @@ test chan-io-20.2 {Tcl_CreateChannel: initial settings} -constraints {win} -body list [chan configure $f -eofchar] [chan configure $f -translation] } -cleanup { chan close $f -} -result {{{}} {auto crlf}} +} -result {{} {auto crlf}} test chan-io-20.3 {Tcl_CreateChannel: initial settings} -constraints {unix} -body { set f [open $path(test1) w+] list [chan configure $f -eofchar] [chan configure $f -translation] } -cleanup { chan close $f -} -result {{{}} {auto lf}} +} -result {{} {auto lf}} test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} -setup { set path(stdout) [makeFile {} stdout] } -constraints {stdio notWinCI} -body { @@ -5285,7 +5285,7 @@ test chan-io-39.21 {Tcl_SetChannelOption, setting read mode independently} \ test chan-io-39.22 {Tcl_SetChannelOption, invariance} -setup { file delete $path(test1) set l "" -} -constraints {unix} -body { +} -constraints {unix deprecated} -body { set f1 [open $path(test1) w+] lappend l [chan configure $f1 -eofchar] chan configure $f1 -eofchar {O {}} @@ -5298,7 +5298,7 @@ test chan-io-39.22 {Tcl_SetChannelOption, invariance} -setup { test chan-io-39.22a {Tcl_SetChannelOption, invariance} -setup { file delete $path(test1) set l [list] -} -body { +} -constraints deprecated -body { set f1 [open $path(test1) w+] chan configure $f1 -eofchar {O {}} lappend l [chan configure $f1 -eofchar] @@ -5307,7 +5307,7 @@ test chan-io-39.22a {Tcl_SetChannelOption, invariance} -setup { lappend l [list [catch {chan configure $f1 -eofchar {1 2 3}} msg] $msg] } -cleanup { chan close $f1 -} -result {O D {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}} +} -result {O D {1 {bad value for -eofchar: must be non-NUL ASCII character}}} test chan-io-39.23 {Tcl_GetChannelOption, server socket is not readable or\ writeable, it should still have valid -eofchar and -translation options} -setup { set l [list] @@ -5317,7 +5317,7 @@ test chan-io-39.23 {Tcl_GetChannelOption, server socket is not readable or\ [chan configure $sock -translation] } -cleanup { chan close $sock -} -result {{{}} auto} +} -result {{} auto} test chan-io-39.24 {Tcl_SetChannelOption, server socket is not readable or\ writable so we can't change -eofchar or -translation} -setup { set l [list] @@ -5328,7 +5328,7 @@ test chan-io-39.24 {Tcl_SetChannelOption, server socket is not readable or\ [chan configure $sock -translation] } -cleanup { chan close $sock -} -result {{{}} auto} +} -result {{} auto} test chan-io-40.1 {POSIX open access modes: RDWR} -setup { file delete $path(test3) diff --git a/tests/io.test b/tests/io.test index 0db2e9a..04c9cd2 100644 --- a/tests/io.test +++ b/tests/io.test @@ -2093,13 +2093,13 @@ test io-20.2 {Tcl_CreateChannel: initial settings} {win} { set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] close $f set x -} {{{}} {auto crlf}} +} {{} {auto crlf}} test io-20.3 {Tcl_CreateChannel: initial settings} {unix} { set f [open $path(test1) w+] set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] close $f set x -} {{{}} {auto lf}} +} {{} {auto lf}} set path(stdout) [makeFile {} stdout] test io-20.5 {Tcl_CreateChannel: install channel in empty slot} stdio { set f [open $path(script) w] @@ -5756,7 +5756,7 @@ test io-39.21 {Tcl_SetChannelOption, setting read mode independently} \ close $s2 set modes } {auto crlf} -test io-39.22 {Tcl_SetChannelOption, invariance} {unix} { +test io-39.22 {Tcl_SetChannelOption, invariance} {unix deprecated} { file delete $path(test1) set f1 [open $path(test1) w+] set l "" @@ -5767,8 +5767,8 @@ test io-39.22 {Tcl_SetChannelOption, invariance} {unix} { lappend l [fconfigure $f1 -eofchar] close $f1 set l -} {{{}} O D} -test io-39.22a {Tcl_SetChannelOption, invariance} { +} {{} O D} +test io-39.22a {Tcl_SetChannelOption, invariance} deprecated { file delete $path(test1) set f1 [open $path(test1) w+] set l [list] @@ -5779,7 +5779,7 @@ test io-39.22a {Tcl_SetChannelOption, invariance} { lappend l [list [catch {fconfigure $f1 -eofchar {1 2 3}} msg] $msg] close $f1 set l -} {O D {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}} +} {O D {1 {bad value for -eofchar: must be non-NUL ASCII character}}} test io-39.23 {Tcl_GetChannelOption, server socket is not readable or writeable, it should still have valid -eofchar and -translation options } { set l [list] @@ -5787,7 +5787,7 @@ test io-39.23 {Tcl_GetChannelOption, server socket is not readable or lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation] close $sock set l -} {{{}} auto} +} {{} auto} test io-39.24 {Tcl_SetChannelOption, server socket is not readable or writable so we can't change -eofchar or -translation } { set l [list] @@ -5796,7 +5796,7 @@ test io-39.24 {Tcl_SetChannelOption, server socket is not readable or lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation] close $sock set l -} {{{}} auto} +} {{} auto} test io-40.1 {POSIX open access modes: RDWR} { file delete $path(test3) diff --git a/tools/regexpTestLib.tcl b/tools/regexpTestLib.tcl index 454a4e8..2687e67 100644 --- a/tools/regexpTestLib.tcl +++ b/tools/regexpTestLib.tcl @@ -183,9 +183,9 @@ proc convertTestLine {currentLine len lineNum srcLineNum} { set noBraces 0 if {[regexp {=|>} $flags] == 1} { regsub -all {_} $currentLine {\\ } currentLine - regsub -all {A} $currentLine {\\007} currentLine + regsub -all {A} $currentLine {\\x07} currentLine regsub -all {B} $currentLine {\\b} currentLine - regsub -all {E} $currentLine {\\033} currentLine + regsub -all {E} $currentLine {\\x1B} currentLine regsub -all {F} $currentLine {\\f} currentLine regsub -all {N} $currentLine {\\n} currentLine -- cgit v0.12 From 0b20d5aff1c281bc34289c99f781cf54817a60f8 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 28 Oct 2022 12:55:40 +0000 Subject: Restore test suite fix. If [try] is too confusing, then I will use [eval]. The stack is a stack of commands. Test hygiene. This was creating one more thread than it destroyed. In a -singleproc 1 test run, this caused tests in later test files to fail because the stray thread causes test results to be different. --- tests/http.test | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/tests/http.test b/tests/http.test index 6826448..b422b2a 100644 --- a/tests/http.test +++ b/tests/http.test @@ -47,6 +47,7 @@ if {![file exists $httpdFile]} { catch {package require Thread 2.7-} if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { set httpthread [thread::create -preserved] + lappend threadStack [list thread::release $httpthread] thread::send $httpthread [list source $httpdFile] thread::send $httpthread [list set bindata $bindata] thread::send $httpthread {httpd_init 0; set port} port @@ -64,6 +65,7 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { catch {unset port} return } + set threadStack {} } if {![info exists ThreadLevel]} { @@ -78,6 +80,7 @@ if {![info exists ThreadLevel]} { foreach ThreadLevel $ValueRange { source [info script] } + eval [lpop threadStack] catch {unset ThreadLevel} catch {unset ValueRange} return @@ -1168,8 +1171,8 @@ catch {unset url} catch {unset badurl} catch {unset port} catch {unset data} -if {[info exists httpthread]} { - thread::release $httpthread +if {[llength $threadStack]} { + eval [lpop threadStack] } else { close $listen } -- cgit v0.12 From 8fb4c52383acfa9fd7d0863185935cabf3614511 Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 28 Oct 2022 13:18:55 +0000 Subject: TIP 633 and TIP 346: add man page entry for fconfigure --- doc/fconfigure.n | 32 ++++++++++++++++++++++++++++++-- 1 file changed, 30 insertions(+), 2 deletions(-) diff --git a/doc/fconfigure.n b/doc/fconfigure.n index 617e82d..836bb5a 100644 --- a/doc/fconfigure.n +++ b/doc/fconfigure.n @@ -113,6 +113,34 @@ The acceptable range for \fB\-eofchar\fR values is \ex01 - \ex7F; attempting to set \fB\-eofchar\fR to a value outside of this range will generate an error. .TP +.VS "TCL9.0 TIP633" +\fB\-nocomplainencoding\fR \fIbool\fR +. +Reporting mode of encoding errors. +If set to a \fItrue\fR value, encoding errors are resolved by a replacement +character (output) or verbatim bytes (input). No error is thrown. +If set to a \fIfalse\fR value, errors are thrown in case of encoding errors. +.RS +.PP +The default value is \fIfalse\fR starting from TCL 9.0 and \fItrue\fR on TCL 8.7. +This option was introduced with TCL 8.7 and has the fix value \fItrue\fR. +.TP +See the \fI\-nocomplain\fR option of the \fBencoding\fR command for more information. +.RE +.TP +.VE "TCL9.0 TIP633" +.TP +.VS "TCL9.0 TIP346" +\fB\-strictencoding\fR \fIbool\fR +. +Activate additional stricter encoding application rules. +Default value is \fIfalse\fR. +.RS +.PP +See the \fI\-strict\fR option of the \fBencoding\fR command for more information. +.VE "TCL9.0 TIP346" +.RE +.TP \fB\-translation\fR \fImode\fR .TP \fB\-translation\fR \fB{\fIinMode outMode\fB}\fR @@ -268,10 +296,10 @@ set data [read $f $numDataBytes] close $f .CE .SH "SEE ALSO" -close(n), flush(n), gets(n), open(n), puts(n), read(n), socket(n), +close(n), encoding(n), flush(n), gets(n), open(n), puts(n), read(n), socket(n), Tcl_StandardChannels(3) .SH KEYWORDS -blocking, buffering, carriage return, end of line, flushing, linemode, +blocking, buffering, carriage return, end of line, encoding, flushing, linemode, newline, nonblocking, platform, translation, encoding, filter, byte array, binary '\" Local Variables: -- cgit v0.12 From d48c9ac13ee11d125c6b3739de5fec48ffbfa994 Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 28 Oct 2022 13:33:55 +0000 Subject: TIP 633 and TIP 346: add man page entry for fconfigure (TCL 8.7) --- doc/fconfigure.n | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) diff --git a/doc/fconfigure.n b/doc/fconfigure.n index 4bb9fc6..5b3de3d 100644 --- a/doc/fconfigure.n +++ b/doc/fconfigure.n @@ -123,6 +123,32 @@ The acceptable range for \fB\-eofchar\fR values is \ex01 - \ex7F; attempting to set \fB\-eofchar\fR to a value outside of this range will generate an error. .TP +.VS "TCL8.7 TIP633" +\fB\-nocomplainencoding\fR \fIbool\fR +. +Reporting mode of encoding errors. +If set to a \fItrue\fR value, encoding errors are resolved by a replacement +character (output) or verbatim bytes (input). No error is thrown. +This is the only available mode in Tcl 8.7. +.RS +.PP +Starting from TCL 9.0, this value may be set to a \fIfalse\fR value to throw errors +in case of encoding errors. +.RE +.TP +.VE "TCL8.7 TIP633" +.TP +.VS "TCL8.7 TIP346" +\fB\-strictencoding\fR \fIbool\fR +. +Activate additional stricter encoding application rules. +Default value is \fIfalse\fR. +.RS +.PP +See the \fI\-strict\fR option of the \fBencoding\fR command for more information. +.VE "TCL8.7 TIP346" +.RE +.TP \fB\-translation\fR \fImode\fR .TP \fB\-translation\fR \fB{\fIinMode outMode\fB}\fR -- cgit v0.12 From 008d15c04ecfdcf081d5476266626b4c62874205 Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 28 Oct 2022 13:36:21 +0000 Subject: fconfigure man: correct chapter syntax --- doc/fconfigure.n | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/fconfigure.n b/doc/fconfigure.n index 836bb5a..0e8b4a7 100644 --- a/doc/fconfigure.n +++ b/doc/fconfigure.n @@ -124,7 +124,7 @@ If set to a \fIfalse\fR value, errors are thrown in case of encoding errors. .PP The default value is \fIfalse\fR starting from TCL 9.0 and \fItrue\fR on TCL 8.7. This option was introduced with TCL 8.7 and has the fix value \fItrue\fR. -.TP +.PP See the \fI\-nocomplain\fR option of the \fBencoding\fR command for more information. .RE .TP -- cgit v0.12 From 9d428d86eb4c38c8a0d3c8e56ead50c81a1c9d77 Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 28 Oct 2022 13:50:46 +0000 Subject: Resolve tcltk-man2html.tcl errors in fconfigure.n --- doc/fconfigure.n | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/doc/fconfigure.n b/doc/fconfigure.n index 0e8b4a7..47906cf 100644 --- a/doc/fconfigure.n +++ b/doc/fconfigure.n @@ -112,8 +112,8 @@ string. The acceptable range for \fB\-eofchar\fR values is \ex01 - \ex7F; attempting to set \fB\-eofchar\fR to a value outside of this range will generate an error. -.TP .VS "TCL9.0 TIP633" +.TP \fB\-nocomplainencoding\fR \fIbool\fR . Reporting mode of encoding errors. @@ -127,10 +127,9 @@ This option was introduced with TCL 8.7 and has the fix value \fItrue\fR. .PP See the \fI\-nocomplain\fR option of the \fBencoding\fR command for more information. .RE -.TP .VE "TCL9.0 TIP633" -.TP .VS "TCL9.0 TIP346" +.TP \fB\-strictencoding\fR \fIbool\fR . Activate additional stricter encoding application rules. -- cgit v0.12 From 1f207f9a0d45f5de980a8058e79c38a618e2e874 Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 28 Oct 2022 13:51:18 +0000 Subject: Resolve tcltk-man2html.tcl errors in fconfigure.n --- doc/fconfigure.n | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/doc/fconfigure.n b/doc/fconfigure.n index 5b3de3d..9061161 100644 --- a/doc/fconfigure.n +++ b/doc/fconfigure.n @@ -122,8 +122,8 @@ reading and the empty string for writing. The acceptable range for \fB\-eofchar\fR values is \ex01 - \ex7F; attempting to set \fB\-eofchar\fR to a value outside of this range will generate an error. -.TP .VS "TCL8.7 TIP633" +.TP \fB\-nocomplainencoding\fR \fIbool\fR . Reporting mode of encoding errors. @@ -135,10 +135,9 @@ This is the only available mode in Tcl 8.7. Starting from TCL 9.0, this value may be set to a \fIfalse\fR value to throw errors in case of encoding errors. .RE -.TP .VE "TCL8.7 TIP633" -.TP .VS "TCL8.7 TIP346" +.TP \fB\-strictencoding\fR \fIbool\fR . Activate additional stricter encoding application rules. -- cgit v0.12 From 6db74fe6eb42e7f214f0c62038102374a22106be Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 28 Oct 2022 14:37:56 +0000 Subject: The file $(builddir)/tclUuid.h is not part of the source code distribution. The `make distclean` target should delete it. --- unix/Makefile.in | 2 +- win/Makefile.in | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index 340edbf..0a99998 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -765,7 +765,7 @@ clean: clean-packages distclean: distclean-packages clean rm -rf Makefile config.status config.cache config.log tclConfig.sh \ - tclConfig.h *.plist Tcl.framework tcl.pc + tclConfig.h *.plist Tcl.framework tcl.pc tclUuid.h (cd dltest ; $(MAKE) distclean) depend: diff --git a/win/Makefile.in b/win/Makefile.in index 8e15849..7d444a7 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -830,7 +830,7 @@ clean: cleanhelp clean-packages distclean: distclean-packages clean $(RM) Makefile config.status config.cache config.log tclConfig.sh \ - tcl.hpj config.status.lineno tclsh.exe.manifest + tcl.hpj config.status.lineno tclsh.exe.manifest tclUuid.h # # Bundled package targets -- cgit v0.12 From a333cf0f8e86a36b3c58dbff9936baffd90ac68b Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 28 Oct 2022 14:58:52 +0000 Subject: Correct issues in safe.n reported by tcltk-man2html.tcl --- doc/safe.n | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/doc/safe.n b/doc/safe.n index 6dd4033..6e0d948 100644 --- a/doc/safe.n +++ b/doc/safe.n @@ -468,7 +468,7 @@ Examples of use with "Sync Mode" off: any of these commands will set the safe::interpConfigure foo -accessPath {} .CE .RE -.TP +.PP Example of use with "Sync Mode" off: when initializing a safe interpreter with a non-empty access path, the ::auto_path will be set to {} unless its own value is also specified: @@ -506,7 +506,7 @@ own value is also specified: } .CE .RE -.TP +.PP Example of use with "Sync Mode" off: the command \fBsafe::interpAddToAccessPath\fR does not change the safe interpreter's ::auto_path, and so any necessary change must be made by the script: @@ -520,7 +520,6 @@ Example of use with "Sync Mode" off: the command safe::interpConfigure foo -autoPath $childAutoPath .CE .RE -.TP .SH "SEE ALSO" interp(n), library(n), load(n), package(n), pkg_mkIndex(n), source(n), tm(n), unknown(n) -- cgit v0.12 From 78241e0ee73910886647c69a7fbc43cb7812f18c Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 28 Oct 2022 15:53:09 +0000 Subject: TIP346, TIP607, TIP601: document encoding command --- doc/encoding.n | 102 +++++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 66 insertions(+), 36 deletions(-) diff --git a/doc/encoding.n b/doc/encoding.n index c1dbf27..eff4a13 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -28,30 +28,37 @@ formats. Performs one of several encoding related operations, depending on \fIoption\fR. The legal \fIoption\fRs are: .TP -\fBencoding convertfrom\fR ?\fB-nocomplain\fR? ?\fB-failindex var\fR? -?\fIencoding\fR? \fIdata\fR +\fBencoding convertfrom\fR ?\fB-nocomplain\fR? ?\fB-failindex var\fR? ?\fB-strict\fR? ?\fIencoding\fR? \fIdata\fR . Convert \fIdata\fR to a Unicode string from the specified \fIencoding\fR. The characters in \fIdata\fR are 8 bit binary data. The resulting sequence of bytes is a string created by applying the given \fIencoding\fR to the data. If \fIencoding\fR is not specified, the current system encoding is used. -. -The call fails on convertion errors, like an incomplete utf-8 sequence. -The option \fB-failindex\fR is followed by a variable name. The variable -is set to \fI-1\fR if no conversion error occured. It is set to the -first error location in \fIdata\fR in case of a conversion error. All data -until this error location is transformed and retured. This option may not -be used together with \fB-nocomplain\fR. -. -The call does not fail on conversion errors, if the option -\fB-nocomplain\fR is given. In this case, any error locations are replaced -by \fB?\fR. Incomplete sequences are written verbatim to the output string. -The purpose of this switch is to gain compatibility to prior versions of TCL. -It is not recommended for any other usage. +.VS "TCL8.7 TIP346, TIP607, TIP601" +.PP +.RS +If the option \fB-nocomplain\fR is given, the command does not fail on +encoding errors. Instead, any not convertable bytes (like incomplete UTF-8 + sequences, see example below) are put as byte values into the output stream. +If the option \fB-nocomplain\fR is not given, the command will fail with an +appropriate error message. +.PP +If the option \fB-failindex\fR with a variable name is given, the error reporting +is changed in the following manner: +in case of a conversion error, the position of the input byte causing the error +is returned in the given variable. The return value of the command are the +converted characters until the first error position. No error condition is raised. +In case of no error, the value \fI-1\fR is written to the variable. This option +may not be used together with \fB-nocomplain\fR. +.PP +The \fB-strict\fR option followes more strict rules in conversion. Currently, only +the sequence \fB\\xC0\\x80\fR in \fButf-8\fR encoding is disallowed. Additional rules +may follow. +.VE "TCL8.7 TIP346, TIP607, TIP601" +.RE .TP -\fBencoding convertto\fR ?\fB-nocomplain\fR? ?\fB-failindex var\fR? -?\fIencoding\fR? \fIstring\fR +\fBencoding convertto\fR ?\fB-nocomplain\fR? ?\fB-failindex var\fR? ?\fB-strict\fR? ?\fIencoding\fR? \fIstring\fR . Convert \fIstring\fR from Unicode to the specified \fIencoding\fR. The result is a sequence of bytes that represents the converted @@ -59,21 +66,28 @@ string. Each byte is stored in the lower 8-bits of a Unicode character (indeed, the resulting string is a binary string as far as Tcl is concerned, at least initially). If \fIencoding\fR is not specified, the current system encoding is used. -. -The call fails on convertion errors, like a Unicode character not representable -in the given \fIencoding\fR. -. -The option \fB-failindex\fR is followed by a variable name. The variable -is set to \fI-1\fR if no conversion error occured. It is set to the -first error location in \fIdata\fR in case of a conversion error. All data -until this error location is transformed and retured. This option may not -be used together with \fB-nocomplain\fR. -. -The call does not fail on conversion errors, if the option -\fB-nocomplain\fR is given. In this case, any error locations are replaced -by \fB?\fR. Incomplete sequences are written verbatim to the output string. -The purpose of this switch is to gain compatibility to prior versions of TCL. -It is not recommended for any other usage. +.VS "TCL8.7 TIP346, TIP607, TIP601" +.PP +.RS +If the option \fB-nocomplain\fR is given, the command does not fail on +encoding errors. Instead, the replacement character \fB?\fR is output +for any not representable character (like the dot \fB\\U2022\fR +in \fBiso-8859-1\fI encoding, see example below). +If the option \fB-nocomplain\fR is not given, the command will fail with an +appropriate error message. +.PP +If the option \fB-failindex\fR with a variable name is given, the error reporting +is changed in the following manner: +in case of a conversion error, the position of the input character causing the error +is returned in the given variable. The return value of the command are the +converted bytes until the first error position. No error condition is raised. +In case of no error, the value \fI-1\fR is written to the variable. This option +may not be used together with \fB-nocomplain\fR. +.PP +The \fB-strict\fR option followes more strict rules in conversion. Currently, it has +no effect but may be used in future to add additional encoding checks. +.VE "TCL8.7 TIP346, TIP607, TIP601" +.RE .TP \fBencoding dirs\fR ?\fIdirectoryList\fR? . @@ -104,7 +118,7 @@ omitted then the command returns the current system encoding. The system encoding is used whenever Tcl passes strings to system calls. .SH EXAMPLE .PP -The following example converts a byte sequence in Japanese euc-jp encoding to a TCL string: +Example 1: convert a byte sequence in Japanese euc-jp encoding to a TCL string: .PP .CS set s [\fBencoding convertfrom\fR euc-jp "\exA4\exCF"] @@ -113,8 +127,9 @@ set s [\fBencoding convertfrom\fR euc-jp "\exA4\exCF"] The result is the unicode codepoint: .QW "\eu306F" , which is the Hiragana letter HA. +.VS "TCL8.7 TIP346, TIP607, TIP601" .PP -The following example detects the error location in an incomplete UTF-8 sequence: +Example 2: detect the error location in an incomplete UTF-8 sequence: .PP .CS % set s [\fBencoding convertfrom\fR -failindex i utf-8 "A\exC3"] @@ -123,7 +138,14 @@ A 1 .CE .PP -The following example detects the error location while transforming to ISO8859-1 +Example 3: return the incomplete UTF-8 sequence by raw bytes: +.PP +.CS +% set s [\fBencoding convertfrom\fR -nocomplain utf-8 "A\exC3"] +.CE +The result is "A" followed by the byte \exC3. +.PP +Example 4: detect the error location while transforming to ISO8859-1 (ISO-Latin 1): .PP .CS @@ -133,8 +155,16 @@ A 1 .CE .PP +Example 5: replace a not representable character by the replacement character: +.PP +.CS +% set s [\fBencoding convertto\fR -nocomplain utf-8 "A\eu0141"] +A? +.CE +.VE "TCL8.7 TIP346, TIP607, TIP601" +.PP .SH "SEE ALSO" -Tcl_GetEncoding(3) +Tcl_GetEncoding(3), fconfigure(n) .SH KEYWORDS encoding, unicode .\" Local Variables: -- cgit v0.12 From 5ba7f2ce37c985a7db5220baafb301007fecadd6 Mon Sep 17 00:00:00 2001 From: oehhar Date: Fri, 28 Oct 2022 16:10:17 +0000 Subject: Document TCL 8.7 behaviour of TIP601 and TIP607. --- doc/encoding.n | 32 +++++++++++++++++++------------- 1 file changed, 19 insertions(+), 13 deletions(-) diff --git a/doc/encoding.n b/doc/encoding.n index eff4a13..bbe197d 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -38,20 +38,22 @@ system encoding is used. .VS "TCL8.7 TIP346, TIP607, TIP601" .PP .RS -If the option \fB-nocomplain\fR is given, the command does not fail on -encoding errors. Instead, any not convertable bytes (like incomplete UTF-8 - sequences, see example below) are put as byte values into the output stream. -If the option \fB-nocomplain\fR is not given, the command will fail with an -appropriate error message. +The command does not fail on encoding errors. Instead, any not convertable bytes +(like incomplete UTF-8 sequences, see example below) are put as byte values into +the output stream. .PP If the option \fB-failindex\fR with a variable name is given, the error reporting is changed in the following manner: in case of a conversion error, the position of the input byte causing the error is returned in the given variable. The return value of the command are the -converted characters until the first error position. No error condition is raised. +converted characters until the first error position. In case of no error, the value \fI-1\fR is written to the variable. This option may not be used together with \fB-nocomplain\fR. .PP +The option \fB-nocomplain\fR has no effect and is available for compatibility with +TCL 9. In TCL 9, the encoding command fails with an error on any encoding issue. +This switch restores the TCL8.7 behaviour. +.PP The \fB-strict\fR option followes more strict rules in conversion. Currently, only the sequence \fB\\xC0\\x80\fR in \fButf-8\fR encoding is disallowed. Additional rules may follow. @@ -69,12 +71,9 @@ specified, the current system encoding is used. .VS "TCL8.7 TIP346, TIP607, TIP601" .PP .RS -If the option \fB-nocomplain\fR is given, the command does not fail on -encoding errors. Instead, the replacement character \fB?\fR is output -for any not representable character (like the dot \fB\\U2022\fR -in \fBiso-8859-1\fI encoding, see example below). -If the option \fB-nocomplain\fR is not given, the command will fail with an -appropriate error message. +The command does not fail on encoding errors. Instead, the replacement character +\fB?\fR is output for any not representable character (like the dot \fB\\U2022\fR +in \fBiso-8859-1\fR encoding, see example below). .PP If the option \fB-failindex\fR with a variable name is given, the error reporting is changed in the following manner: @@ -84,6 +83,10 @@ converted bytes until the first error position. No error condition is raised. In case of no error, the value \fI-1\fR is written to the variable. This option may not be used together with \fB-nocomplain\fR. .PP +The option \fB-nocomplain\fR has no effect and is available for compatibility with +TCL 9. In TCL 9, the encoding command fails with an error on any encoding issue. +This switch restores the TCL8.7 behaviour. +.PP The \fB-strict\fR option followes more strict rules in conversion. Currently, it has no effect but may be used in future to add additional encoding checks. .VE "TCL8.7 TIP346, TIP607, TIP601" @@ -143,7 +146,8 @@ Example 3: return the incomplete UTF-8 sequence by raw bytes: .CS % set s [\fBencoding convertfrom\fR -nocomplain utf-8 "A\exC3"] .CE -The result is "A" followed by the byte \exC3. +The result is "A" followed by the byte \exC3. The option \fB-nocomplain\fR +has no effect, but assures to get the same result with TCL9. .PP Example 4: detect the error location while transforming to ISO8859-1 (ISO-Latin 1): @@ -161,6 +165,8 @@ Example 5: replace a not representable character by the replacement character: % set s [\fBencoding convertto\fR -nocomplain utf-8 "A\eu0141"] A? .CE +The option \fB-nocomplain\fR has no effect, but assures to get the same result +with TCL9. .VE "TCL8.7 TIP346, TIP607, TIP601" .PP .SH "SEE ALSO" -- cgit v0.12 From f8f170cfd384b83be557bde3f4dff1f974b09048 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 28 Oct 2022 16:18:29 +0000 Subject: Duplicate test names --- tests/http.test | 352 ++++++++++++++++++++++++------------------------ tests/http11.test | 2 +- tests/httpPipeline.test | 2 +- tests/httpProxy.test | 56 ++++---- 4 files changed, 206 insertions(+), 206 deletions(-) diff --git a/tests/http.test b/tests/http.test index b422b2a..742ff1c 100644 --- a/tests/http.test +++ b/tests/http.test @@ -89,17 +89,17 @@ if {![info exists ThreadLevel]} { catch {puts "==== Test with ThreadLevel $ThreadLevel ===="} http::config -threadlevel $ThreadLevel -test http-1.1 {http::config} { +test http-1.1.$ThreadLevel {http::config} { http::config -useragent UserAgent http::config } [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyauth {} -proxyfilter http::ProxyRequired -proxyhost {} -proxynot {} -proxyport {} -repost 0 -threadlevel $ThreadLevel -urlencoding utf-8 -useragent UserAgent -zip 1] -test http-1.2 {http::config} { +test http-1.2.$ThreadLevel {http::config} { http::config -proxyfilter } http::ProxyRequired -test http-1.3 {http::config} { +test http-1.3.$ThreadLevel {http::config} { catch {http::config -junk} } 1 -test http-1.4 {http::config} { +test http-1.4.$ThreadLevel {http::config} { set savedconf [http::config] http::config -proxyhost nowhere.come -proxyport 8080 \ -proxyfilter myFilter -useragent "Tcl Test Suite" \ @@ -108,10 +108,10 @@ test http-1.4 {http::config} { http::config {*}$savedconf set x } [list -accept */* -cookiejar {} -pipeline 1 -postfresh 0 -proxyauth {} -proxyfilter myFilter -proxyhost nowhere.come -proxynot {} -proxyport 8080 -repost 0 -threadlevel $ThreadLevel -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1] -test http-1.5 {http::config} -returnCodes error -body { +test http-1.5.$ThreadLevel {http::config} -returnCodes error -body { http::config -proxyhost {} -junk 8080 } -result {Unknown option -junk, must be: -accept, -cookiejar, -pipeline, -postfresh, -proxyauth, -proxyfilter, -proxyhost, -proxynot, -proxyport, -repost, -threadlevel, -urlencoding, -useragent, -zip} -test http-1.6 {http::config} -setup { +test http-1.6.$ThreadLevel {http::config} -setup { set oldenc [http::config -urlencoding] } -body { set enc [list [http::config -urlencoding]] @@ -121,42 +121,42 @@ test http-1.6 {http::config} -setup { http::config -urlencoding $oldenc } -result {utf-8 iso8859-1} -test http-2.1 {http::reset} { +test http-2.1.$ThreadLevel {http::reset} { catch {http::reset http#1} } 0 -test http-2.2 {http::CharsetToEncoding} { +test http-2.2.$ThreadLevel {http::CharsetToEncoding} { http::CharsetToEncoding iso-8859-11 } iso8859-11 -test http-2.3 {http::CharsetToEncoding} { +test http-2.3.$ThreadLevel {http::CharsetToEncoding} { http::CharsetToEncoding iso-2022-kr } iso2022-kr -test http-2.4 {http::CharsetToEncoding} { +test http-2.4.$ThreadLevel {http::CharsetToEncoding} { http::CharsetToEncoding shift-jis } shiftjis -test http-2.5 {http::CharsetToEncoding} { +test http-2.5.$ThreadLevel {http::CharsetToEncoding} { http::CharsetToEncoding windows-437 } cp437 -test http-2.6 {http::CharsetToEncoding} { +test http-2.6.$ThreadLevel {http::CharsetToEncoding} { http::CharsetToEncoding latin5 } iso8859-9 -test http-2.7 {http::CharsetToEncoding} { +test http-2.7.$ThreadLevel {http::CharsetToEncoding} { http::CharsetToEncoding latin1 } iso8859-1 -test http-2.8 {http::CharsetToEncoding} { +test http-2.8.$ThreadLevel {http::CharsetToEncoding} { http::CharsetToEncoding latin4 } binary -test http-3.1 {http::geturl} -returnCodes error -body { +test http-3.1.$ThreadLevel {http::geturl} -returnCodes error -body { http::geturl -bogus flag } -result {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -guesstype, -handler, -headers, -keepalive, -method, -myaddr, -progress, -protocol, -query, -queryblocksize, -querychannel, -queryprogress, -strict, -timeout, -type, -validate} -test http-3.2 {http::geturl} -returnCodes error -body { +test http-3.2.$ThreadLevel {http::geturl} -returnCodes error -body { http::geturl http:junk } -result {Unsupported URL: http:junk} set url //${::HOST}:$port set badurl //${::HOST}:[expr {$port+1}] -test http-3.3 {http::geturl} -body { +test http-3.3.$ThreadLevel {http::geturl} -body { set token [http::geturl $url] http::data $token } -cleanup { @@ -176,7 +176,7 @@ set badposturl //${::HOST}:$port/droppost set authorityurl //${::HOST}:$port set ipv6url http://\[::1\]:$port/ -test http-3.4 {http::geturl} -body { +test http-3.4.$ThreadLevel {http::geturl} -body { set token [http::geturl $url] http::data $token } -cleanup { @@ -189,7 +189,7 @@ proc selfproxy {host} { global port return [list ${::HOST} $port] } -test http-3.5 {http::geturl} -body { +test http-3.5.$ThreadLevel {http::geturl} -body { http::config -proxyfilter selfproxy set token [http::geturl $url] http::data $token @@ -200,7 +200,7 @@ test http-3.5 {http::geturl} -body {

Hello, World!

GET http:$url

" -test http-3.6 {http::geturl} -body { +test http-3.6.$ThreadLevel {http::geturl} -body { http::config -proxyfilter bogus set token [http::geturl $url] http::data $token @@ -211,7 +211,7 @@ test http-3.6 {http::geturl} -body {

Hello, World!

GET $tail

" -test http-3.7 {http::geturl} -body { +test http-3.7.$ThreadLevel {http::geturl} -body { set token [http::geturl $url -headers {Pragma no-cache}] http::data $token } -cleanup { @@ -220,7 +220,7 @@ test http-3.7 {http::geturl} -body {

Hello, World!

GET $tail

" -test http-3.8 {http::geturl} -body { +test http-3.8.$ThreadLevel {http::geturl} -body { set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 3000] http::data $token } -cleanup { @@ -234,13 +234,13 @@ test http-3.8 {http::geturl} -body {
Foo
Bar " -test http-3.9 {http::geturl} -body { +test http-3.9.$ThreadLevel {http::geturl} -body { set token [http::geturl $url -validate 1] http::code $token } -cleanup { http::cleanup $token } -result "HTTP/1.0 200 OK" -test http-3.10 {http::geturl queryprogress} -setup { +test http-3.10.$ThreadLevel {http::geturl queryprogress} -setup { set query foo=bar set sep "" set i 0 @@ -263,7 +263,7 @@ test http-3.10 {http::geturl queryprogress} -setup { } -cleanup { http::cleanup $t } -result {ok 122879 {16384 32768 49152 65536 81920 98304 114688 122879} {Got 122879 bytes}} -test http-3.11 {http::geturl querychannel with -command} -setup { +test http-3.11.$ThreadLevel {http::geturl querychannel with -command} -setup { set query foo=bar set sep "" set i 0 @@ -302,7 +302,7 @@ test http-3.11 {http::geturl querychannel with -command} -setup { # The status is "eof". # On Windows, the http::wait procedure gets a "connection reset by peer" error # while reading the reply. -test http-3.12 {http::geturl querychannel with aborted request} -setup { +test http-3.12.$ThreadLevel {http::geturl querychannel with aborted request} -setup { set query foo=bar set sep "" set i 0 @@ -340,7 +340,7 @@ test http-3.12 {http::geturl querychannel with aborted request} -setup { removeFile outdata http::cleanup $t } -result {ok {HTTP/1.0 200 Data follows}} -test http-3.13 {http::geturl socket leak test} { +test http-3.13.$ThreadLevel {http::geturl socket leak test} { set chanCount [llength [file channels]] for {set i 0} {$i < 3} {incr i} { catch {http::geturl $badurl -timeout 5000} @@ -348,43 +348,43 @@ test http-3.13 {http::geturl socket leak test} { # No extra channels should be taken expr {[llength [file channels]] == $chanCount} } 1 -test http-3.14 "http::geturl $fullurl" -body { +test http-3.14.$ThreadLevel "http::geturl $fullurl" -body { set token [http::geturl $fullurl -validate 1] http::code $token } -cleanup { http::cleanup $token } -result "HTTP/1.0 200 OK" -test http-3.15 {http::geturl parse failures} -body { +test http-3.15.$ThreadLevel {http::geturl parse failures} -body { http::geturl "{invalid}:url" } -returnCodes error -result {Unsupported URL: {invalid}:url} -test http-3.16 {http::geturl parse failures} -body { +test http-3.16.$ThreadLevel {http::geturl parse failures} -body { http::geturl http:relative/url } -returnCodes error -result {Unsupported URL: http:relative/url} -test http-3.17 {http::geturl parse failures} -body { +test http-3.17.$ThreadLevel {http::geturl parse failures} -body { http::geturl /absolute/url } -returnCodes error -result {Missing host part: /absolute/url} -test http-3.18 {http::geturl parse failures} -body { +test http-3.18.$ThreadLevel {http::geturl parse failures} -body { http::geturl http://somewhere:123456789/ } -returnCodes error -result {Invalid port number: 123456789} -test http-3.19 {http::geturl parse failures} -body { +test http-3.19.$ThreadLevel {http::geturl parse failures} -body { http::geturl http://{user}@somewhere } -returnCodes error -result {Illegal characters in URL user} -test http-3.20 {http::geturl parse failures} -body { +test http-3.20.$ThreadLevel {http::geturl parse failures} -body { http::geturl http://%user@somewhere } -returnCodes error -result {Illegal encoding character usage "%us" in URL user} -test http-3.21 {http::geturl parse failures} -body { +test http-3.21.$ThreadLevel {http::geturl parse failures} -body { http::geturl http://somewhere/{path} } -returnCodes error -result {Illegal characters in URL path} -test http-3.22 {http::geturl parse failures} -body { +test http-3.22.$ThreadLevel {http::geturl parse failures} -body { http::geturl http://somewhere/%path } -returnCodes error -result {Illegal encoding character usage "%pa" in URL path} -test http-3.23 {http::geturl parse failures} -body { +test http-3.23.$ThreadLevel {http::geturl parse failures} -body { http::geturl http://somewhere/path?{query}? } -returnCodes error -result {Illegal characters in URL path} -test http-3.24 {http::geturl parse failures} -body { +test http-3.24.$ThreadLevel {http::geturl parse failures} -body { http::geturl http://somewhere/path?%query } -returnCodes error -result {Illegal encoding character usage "%qu" in URL path} -test http-3.25 {http::meta} -setup { +test http-3.25.$ThreadLevel {http::meta} -setup { unset -nocomplain m token } -body { set token [http::geturl $url -timeout 3000] @@ -394,7 +394,7 @@ test http-3.25 {http::meta} -setup { http::cleanup $token unset -nocomplain m token } -result {content-length content-type date} -test http-3.26 {http::meta} -setup { +test http-3.26.$ThreadLevel {http::meta} -setup { unset -nocomplain m token } -body { set token [http::geturl $url -headers {X-Check 1} -timeout 3000] @@ -404,7 +404,7 @@ test http-3.26 {http::meta} -setup { http::cleanup $token unset -nocomplain m token } -result {content-length content-type date x-check} -test http-3.27 {http::geturl: -headers override -type} -body { +test http-3.27.$ThreadLevel {http::geturl: -headers override -type} -body { set token [http::geturl $url/headers -type "text/plain" -query dummy \ -headers [list "Content-Type" "text/plain;charset=utf-8"]] http::data $token @@ -417,7 +417,7 @@ Accept \*/\* Accept-Encoding .* Connection close Content-Length 5} -test http-3.28 {http::geturl: -headers override -type default} -body { +test http-3.28.$ThreadLevel {http::geturl: -headers override -type default} -body { set token [http::geturl $url/headers -query dummy \ -headers [list "Content-Type" "text/plain;charset=utf-8"]] http::data $token @@ -430,7 +430,7 @@ Accept \*/\* Accept-Encoding .* Connection close Content-Length 5} -test http-3.29 {http::geturl IPv6 address} -body { +test http-3.29.$ThreadLevel {http::geturl IPv6 address} -body { # We only want to see if the URL gets parsed correctly. This is # the case if http::geturl succeeds or returns a socket related # error. If the parsing is wrong, we'll get a parse error. @@ -444,20 +444,20 @@ test http-3.29 {http::geturl IPv6 address} -body { } -cleanup { catch { http::cleanup $token } } -result 0 -test http-3.30 {http::geturl query without path} -body { +test http-3.30.$ThreadLevel {http::geturl query without path} -body { set token [http::geturl $authorityurl?var=val] http::ncode $token } -cleanup { catch { http::cleanup $token } } -result 200 -test http-3.31 {http::geturl fragment without path} -body { +test http-3.31.$ThreadLevel {http::geturl fragment without path} -body { set token [http::geturl "$authorityurl#fragment42"] http::ncode $token } -cleanup { catch { http::cleanup $token } } -result 200 # Bug c11a51c482 -test http-3.32 {http::geturl: -headers override -accept default} -body { +test http-3.32.$ThreadLevel {http::geturl: -headers override -accept default} -body { set token [http::geturl $url/headers -query dummy \ -headers [list "Accept" "text/plain,application/tcl-test-value"]] http::data $token @@ -471,20 +471,20 @@ Connection close Content-Type application/x-www-form-urlencoded Content-Length 5} # Bug 838e99a76d -test http-3.33 {http::geturl application/xml is text} -body { +test http-3.33.$ThreadLevel {http::geturl application/xml is text} -body { set token [http::geturl "$xmlurl"] scan [http::data $token] "<%\[^>]>%c<%\[^>]>" } -cleanup { catch { http::cleanup $token } } -result {test 4660 /test} -test http-3.34 {http::geturl -headers not a list} -returnCodes error -body { +test http-3.34.$ThreadLevel {http::geturl -headers not a list} -returnCodes error -body { http::geturl http://test/t -headers \" } -result {Bad value for -headers ("), must be list} -test http-3.35 {http::geturl -headers not even number of elements} -returnCodes error -body { +test http-3.35.$ThreadLevel {http::geturl -headers not even number of elements} -returnCodes error -body { http::geturl http://test/t -headers {List Length 3} } -result {Bad value for -headers (List Length 3), number of list elements must be even} -test http-4.1 {http::Event} -body { +test http-4.1.$ThreadLevel {http::Event} -body { set token [http::geturl $url -keepalive 0] upvar #0 $token data array set meta $data(meta) @@ -492,7 +492,7 @@ test http-4.1 {http::Event} -body { } -cleanup { http::cleanup $token } -result 1 -test http-4.2 {http::Event} -body { +test http-4.2.$ThreadLevel {http::Event} -body { set token [http::geturl $url] upvar #0 $token data array set meta $data(meta) @@ -500,13 +500,13 @@ test http-4.2 {http::Event} -body { } -cleanup { http::cleanup $token } -result 0 -test http-4.3 {http::Event} -body { +test http-4.3.$ThreadLevel {http::Event} -body { set token [http::geturl $url] http::code $token } -cleanup { http::cleanup $token } -result {HTTP/1.0 200 Data follows} -test http-4.4 {http::Event} -setup { +test http-4.4.$ThreadLevel {http::Event} -setup { set testfile [makeFile "" testfile] } -body { set out [open $testfile w] @@ -523,7 +523,7 @@ test http-4.4 {http::Event} -setup {

Hello, World!

GET $tail

" -test http-4.5 {http::Event} -setup { +test http-4.5.$ThreadLevel {http::Event} -setup { set testfile [makeFile "" testfile] } -body { set out [open $testfile w] @@ -536,7 +536,7 @@ test http-4.5 {http::Event} -setup { removeFile $testfile http::cleanup $token } -result 1 -test http-4.6 {http::Event} -setup { +test http-4.6.$ThreadLevel {http::Event} -setup { set testfile [makeFile "" testfile] } -body { set out [open $testfile w] @@ -558,29 +558,29 @@ proc myProgress {token total current} { } set progress [list $total $current] } -test http-4.6.1 {http::Event} knownBug { +test http-4.6.1.$ThreadLevel {http::Event} knownBug { set token [http::geturl $url -blocksize 50 -progress myProgress] return $progress } {111 111} -test http-4.7 {http::Event} -body { +test http-4.7.$ThreadLevel {http::Event} -body { set token [http::geturl $url -keepalive 0 -progress myProgress] return $progress } -cleanup { http::cleanup $token } -result {111 111} -test http-4.8 {http::Event} -body { +test http-4.8.$ThreadLevel {http::Event} -body { set token [http::geturl $url] http::status $token } -cleanup { http::cleanup $token } -result {ok} -test http-4.9 {http::Event} -body { +test http-4.9.$ThreadLevel {http::Event} -body { set token [http::geturl $url -progress myProgress] http::code $token } -cleanup { http::cleanup $token } -result {HTTP/1.0 200 Data follows} -test http-4.10 {http::Event} -body { +test http-4.10.$ThreadLevel {http::Event} -body { set token [http::geturl $url -progress myProgress] http::size $token } -cleanup { @@ -590,7 +590,7 @@ test http-4.10 {http::Event} -body { # Timeout cases # Short timeout to working server (the test server). This lets us try a # reset during the connection. -test http-4.11 {http::Event} -body { +test http-4.11.$ThreadLevel {http::Event} -body { set token [http::geturl $url -timeout 1 -keepalive 0 -command \#] http::reset $token http::status $token @@ -599,7 +599,7 @@ test http-4.11 {http::Event} -body { } -result {reset} # Longer timeout with reset. -test http-4.12 {http::Event} -body { +test http-4.12.$ThreadLevel {http::Event} -body { set token [http::geturl $url/?timeout=10 -keepalive 0 -command \#] http::reset $token http::status $token @@ -609,7 +609,7 @@ test http-4.12 {http::Event} -body { # Medium timeout to working server that waits even longer. The timeout # hits while waiting for a reply. -test http-4.13 {http::Event} -body { +test http-4.13.$ThreadLevel {http::Event} -body { set token [http::geturl $url?timeout=30 -keepalive 0 -timeout 10 -command \#] http::wait $token http::status $token @@ -619,7 +619,7 @@ test http-4.13 {http::Event} -body { # Longer timeout to good host, bad port, gets an error after the # connection "completes" but the socket is bad. -test http-4.14 {http::Event} -body { +test http-4.14.$ThreadLevel {http::Event} -body { set token [http::geturl $badurl/?timeout=10 -timeout 10000 -command \#] if {$token eq ""} { error "bogus return from http::geturl" @@ -631,7 +631,7 @@ test http-4.14 {http::Event} -body { } -result {connect failed connection refused} # Bogus host -test http-4.15 {http::Event} -body { +test http-4.15.$ThreadLevel {http::Event} -body { # This test may fail if you use a proxy server. That is to be # expected and is not a problem with Tcl. # With http::config -threadlevel 1 or 2, the script enters the event loop @@ -645,7 +645,7 @@ test http-4.15 {http::Event} -body { catch {http::cleanup $token} } -match glob -result "error -- couldn't open socket*" -test http-4.16 {Leak with Close vs Keepalive (bug [6ca52aec14]} -setup { +test http-4.16.$ThreadLevel {Leak with Close vs Keepalive (bug [6ca52aec14]} -setup { proc list-difference {l1 l2} { lmap item $l2 {if {$item in $l1} continue; set item} } @@ -660,17 +660,17 @@ test http-4.16 {Leak with Close vs Keepalive (bug [6ca52aec14]} -setup { rename list-difference {} } -result {} -test http-5.1 {http::formatQuery} { +test http-5.1.$ThreadLevel {http::formatQuery} { http::formatQuery name1 value1 name2 "value two" } {name1=value1&name2=value%20two} # test http-5.2 obsoleted by 5.4 and 5.5 with http 2.5 -test http-5.3 {http::formatQuery} { +test http-5.3.$ThreadLevel {http::formatQuery} { http::formatQuery lines "line1\nline2\nline3" } {lines=line1%0D%0Aline2%0D%0Aline3} -test http-5.4 {http::formatQuery} { +test http-5.4.$ThreadLevel {http::formatQuery} { http::formatQuery name1 ~bwelch name2 ¡¢¢ } {name1=~bwelch&name2=%C2%A1%C2%A2%C2%A2} -test http-5.5 {http::formatQuery} { +test http-5.5.$ThreadLevel {http::formatQuery} { set enc [http::config -urlencoding] http::config -urlencoding iso8859-1 set res [http::formatQuery name1 ~bwelch name2 ¡¢¢] @@ -678,7 +678,7 @@ test http-5.5 {http::formatQuery} { set res } {name1=~bwelch&name2=%A1%A2%A2} -test http-6.1 {http::ProxyRequired} -body { +test http-6.1.$ThreadLevel {http::ProxyRequired} -body { http::config -proxyhost ${::HOST} -proxyport $port set token [http::geturl $url] http::wait $token @@ -692,15 +692,15 @@ test http-6.1 {http::ProxyRequired} -body {

GET http:$url

" -test http-7.1 {http::mapReply} { +test http-7.1.$ThreadLevel {http::mapReply} { http::mapReply "abc\$\[\]\"\\()\}\{" } {abc%24%5B%5D%22%5C%28%29%7D%7B} -test http-7.2 {http::mapReply} { +test http-7.2.$ThreadLevel {http::mapReply} { # RFC 2718 specifies that we pass urlencoding on utf-8 chars by default, # so make sure this gets converted to utf-8 then urlencoded. http::mapReply "∈" } {%E2%88%88} -test http-7.3 {http::formatQuery} -setup { +test http-7.3.$ThreadLevel {http::formatQuery} -setup { set enc [http::config -urlencoding] } -returnCodes error -body { # -urlencoding "" no longer supported. Use "iso8859-1". @@ -709,7 +709,7 @@ test http-7.3 {http::formatQuery} -setup { } -cleanup { http::config -urlencoding $enc } -result {unknown encoding ""} -test http-7.4 {http::formatQuery} -constraints deprecated -setup { +test http-7.4.$ThreadLevel {http::formatQuery} -constraints deprecated -setup { set enc [http::config -urlencoding] } -body { # this would be reverting to http <=2.4 behavior w/o errors @@ -723,113 +723,113 @@ test http-7.4 {http::formatQuery} -constraints deprecated -setup { package require tcl::idna 1.0 -test http-idna-1.1 {IDNA package: basics} -returnCodes error -body { +test http-idna-1.1.$ThreadLevel {IDNA package: basics} -returnCodes error -body { ::tcl::idna } -result {wrong # args: should be "::tcl::idna subcommand ?arg ...?"} -test http-idna-1.2 {IDNA package: basics} -returnCodes error -body { +test http-idna-1.2.$ThreadLevel {IDNA package: basics} -returnCodes error -body { ::tcl::idna ? } -result {unknown or ambiguous subcommand "?": must be decode, encode, puny, or version} -test http-idna-1.3 {IDNA package: basics} -body { +test http-idna-1.3.$ThreadLevel {IDNA package: basics} -body { ::tcl::idna version } -result 1.0.1 -test http-idna-1.4 {IDNA package: basics} -returnCodes error -body { +test http-idna-1.4.$ThreadLevel {IDNA package: basics} -returnCodes error -body { ::tcl::idna version what } -result {wrong # args: should be "::tcl::idna version"} -test http-idna-1.5 {IDNA package: basics} -returnCodes error -body { +test http-idna-1.5.$ThreadLevel {IDNA package: basics} -returnCodes error -body { ::tcl::idna puny } -result {wrong # args: should be "::tcl::idna puny subcommand ?arg ...?"} -test http-idna-1.6 {IDNA package: basics} -returnCodes error -body { +test http-idna-1.6.$ThreadLevel {IDNA package: basics} -returnCodes error -body { ::tcl::idna puny ? } -result {unknown or ambiguous subcommand "?": must be decode, or encode} -test http-idna-1.7 {IDNA package: basics} -returnCodes error -body { +test http-idna-1.7.$ThreadLevel {IDNA package: basics} -returnCodes error -body { ::tcl::idna puny encode } -result {wrong # args: should be "::tcl::idna puny encode string ?case?"} -test http-idna-1.8 {IDNA package: basics} -returnCodes error -body { +test http-idna-1.8.$ThreadLevel {IDNA package: basics} -returnCodes error -body { ::tcl::idna puny encode a b c } -result {wrong # args: should be "::tcl::idna puny encode string ?case?"} -test http-idna-1.9 {IDNA package: basics} -returnCodes error -body { +test http-idna-1.9.$ThreadLevel {IDNA package: basics} -returnCodes error -body { ::tcl::idna puny decode } -result {wrong # args: should be "::tcl::idna puny decode string ?case?"} -test http-idna-1.10 {IDNA package: basics} -returnCodes error -body { +test http-idna-1.10.$ThreadLevel {IDNA package: basics} -returnCodes error -body { ::tcl::idna puny decode a b c } -result {wrong # args: should be "::tcl::idna puny decode string ?case?"} -test http-idna-1.11 {IDNA package: basics} -returnCodes error -body { +test http-idna-1.11.$ThreadLevel {IDNA package: basics} -returnCodes error -body { ::tcl::idna decode } -result {wrong # args: should be "::tcl::idna decode hostname"} -test http-idna-1.12 {IDNA package: basics} -returnCodes error -body { +test http-idna-1.12.$ThreadLevel {IDNA package: basics} -returnCodes error -body { ::tcl::idna encode } -result {wrong # args: should be "::tcl::idna encode hostname"} -test http-idna-2.1 {puny encode: functional test} { +test http-idna-2.1.$ThreadLevel {puny encode: functional test} { ::tcl::idna puny encode abc } abc- -test http-idna-2.2 {puny encode: functional test} { +test http-idna-2.2.$ThreadLevel {puny encode: functional test} { ::tcl::idna puny encode a€b€c } abc-k50ab -test http-idna-2.3 {puny encode: functional test} { +test http-idna-2.3.$ThreadLevel {puny encode: functional test} { ::tcl::idna puny encode ABC } ABC- -test http-idna-2.4 {puny encode: functional test} { +test http-idna-2.4.$ThreadLevel {puny encode: functional test} { ::tcl::idna puny encode A€B€C } ABC-k50ab -test http-idna-2.5 {puny encode: functional test} { +test http-idna-2.5.$ThreadLevel {puny encode: functional test} { ::tcl::idna puny encode ABC 0 } abc- -test http-idna-2.6 {puny encode: functional test} { +test http-idna-2.6.$ThreadLevel {puny encode: functional test} { ::tcl::idna puny encode A€B€C 0 } abc-k50ab -test http-idna-2.7 {puny encode: functional test} { +test http-idna-2.7.$ThreadLevel {puny encode: functional test} { ::tcl::idna puny encode ABC 1 } ABC- -test http-idna-2.8 {puny encode: functional test} { +test http-idna-2.8.$ThreadLevel {puny encode: functional test} { ::tcl::idna puny encode A€B€C 1 } ABC-k50ab -test http-idna-2.9 {puny encode: functional test} { +test http-idna-2.9.$ThreadLevel {puny encode: functional test} { ::tcl::idna puny encode abc 0 } abc- -test http-idna-2.10 {puny encode: functional test} { +test http-idna-2.10.$ThreadLevel {puny encode: functional test} { ::tcl::idna puny encode a€b€c 0 } abc-k50ab -test http-idna-2.11 {puny encode: functional test} { +test http-idna-2.11.$ThreadLevel {puny encode: functional test} { ::tcl::idna puny encode abc 1 } ABC- -test http-idna-2.12 {puny encode: functional test} { +test http-idna-2.12.$ThreadLevel {puny encode: functional test} { ::tcl::idna puny encode a€b€c 1 } ABC-k50ab -test http-idna-2.13 {puny encode: edge cases} { +test http-idna-2.13.$ThreadLevel {puny encode: edge cases} { ::tcl::idna puny encode "" } "" -test http-idna-2.14-A {puny encode: examples from RFC 3492} { +test http-idna-2.14-A.$ThreadLevel {puny encode: examples from RFC 3492} { ::tcl::idna puny encode [join [subst [string map {u+ \\u} { u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644 u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F }]] ""] } egbpdaj6bu4bxfgehfvwxn -test http-idna-2.14-B {puny encode: examples from RFC 3492} { +test http-idna-2.14-B.$ThreadLevel {puny encode: examples from RFC 3492} { ::tcl::idna puny encode [join [subst [string map {u+ \\u} { u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587 }]] ""] } ihqwcrb4cv8a8dqg056pqjye -test http-idna-2.14-C {puny encode: examples from RFC 3492} { +test http-idna-2.14-C.$ThreadLevel {puny encode: examples from RFC 3492} { ::tcl::idna puny encode [join [subst [string map {u+ \\u} { u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587 }]] ""] } ihqwctvzc91f659drss3x8bo0yb -test http-idna-2.14-D {puny encode: examples from RFC 3492} { +test http-idna-2.14-D.$ThreadLevel {puny encode: examples from RFC 3492} { ::tcl::idna puny encode [join [subst [string map {u+ \\u} { u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074 u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D u+0065 u+0073 u+006B u+0079 }]] ""] } Proprostnemluvesky-uyb24dma41a -test http-idna-2.14-E {puny encode: examples from RFC 3492} { +test http-idna-2.14-E.$ThreadLevel {puny encode: examples from RFC 3492} { ::tcl::idna puny encode [join [subst [string map {u+ \\u} { u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8 u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2 u+05D1 u+05E8 u+05D9 u+05EA }]] ""] } 4dbcagdahymbxekheh6e0a7fei0b -test http-idna-2.14-F {puny encode: examples from RFC 3492} { +test http-idna-2.14-F.$ThreadLevel {puny encode: examples from RFC 3492} { ::tcl::idna puny encode [join [subst [string map {u+ \\u} { u+092F u+0939 u+0932 u+094B u+0917 u+0939 u+093F u+0928 u+094D u+0926 u+0940 u+0915 u+094D u+092F u+094B u+0902 u+0928 u+0939 @@ -837,20 +837,20 @@ test http-idna-2.14-F {puny encode: examples from RFC 3492} { u+0939 u+0948 u+0902 }]] ""] } i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd -test http-idna-2.14-G {puny encode: examples from RFC 3492} { +test http-idna-2.14-G.$ThreadLevel {puny encode: examples from RFC 3492} { ::tcl::idna puny encode [join [subst [string map {u+ \\u} { u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092 u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B }]] ""] } n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa -test http-idna-2.14-H {puny encode: examples from RFC 3492} { +test http-idna-2.14-H.$ThreadLevel {puny encode: examples from RFC 3492} { ::tcl::idna puny encode [join [subst [string map {u+ \\u} { u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774 u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74 u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C }]] ""] } 989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c -test http-idna-2.14-I {puny encode: examples from RFC 3492} { +test http-idna-2.14-I.$ThreadLevel {puny encode: examples from RFC 3492} { ::tcl::idna puny encode [join [subst [string map {u+ \\u} { u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E u+043D u+0438 u+043D u+0435 u+0433 u+043E u+0432 u+043E u+0440 @@ -858,7 +858,7 @@ test http-idna-2.14-I {puny encode: examples from RFC 3492} { u+0438 }]] ""] } b1abfaaepdrnnbgefbadotcwatmq2g4l -test http-idna-2.14-J {puny encode: examples from RFC 3492} { +test http-idna-2.14-J.$ThreadLevel {puny encode: examples from RFC 3492} { ::tcl::idna puny encode [join [subst [string map {u+ \\u} { u+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070 u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070 @@ -867,7 +867,7 @@ test http-idna-2.14-J {puny encode: examples from RFC 3492} { u+0061 u+00F1 u+006F u+006C }]] ""] } PorqunopuedensimplementehablarenEspaol-fmd56a -test http-idna-2.14-K {puny encode: examples from RFC 3492} { +test http-idna-2.14-K.$ThreadLevel {puny encode: examples from RFC 3492} { ::tcl::idna puny encode [join [subst [string map {u+ \\u} { u+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068 @@ -875,135 +875,135 @@ test http-idna-2.14-K {puny encode: examples from RFC 3492} { u+0056 u+0069 u+1EC7 u+0074 }]] ""] } TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g -test http-idna-2.14-L {puny encode: examples from RFC 3492} { +test http-idna-2.14-L.$ThreadLevel {puny encode: examples from RFC 3492} { ::tcl::idna puny encode [join [subst [string map {u+ \\u} { u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F }]] ""] } 3B-ww4c5e180e575a65lsy2b -test http-idna-2.14-M {puny encode: examples from RFC 3492} { +test http-idna-2.14-M.$ThreadLevel {puny encode: examples from RFC 3492} { ::tcl::idna puny encode [join [subst [string map {u+ \\u} { u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074 u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D u+004F u+004E u+004B u+0045 u+0059 u+0053 }]] ""] } -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n -test http-idna-2.14-N {puny encode: examples from RFC 3492} { +test http-idna-2.14-N.$ThreadLevel {puny encode: examples from RFC 3492} { ::tcl::idna puny encode [join [subst [string map {u+ \\u} { u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D u+305D u+308C u+305E u+308C u+306E u+5834 u+6240 }]] ""] } Hello-Another-Way--fc4qua05auwb3674vfr0b -test http-idna-2.14-O {puny encode: examples from RFC 3492} { +test http-idna-2.14-O.$ThreadLevel {puny encode: examples from RFC 3492} { ::tcl::idna puny encode [join [subst [string map {u+ \\u} { u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032 }]] ""] } 2-u9tlzr9756bt3uc0v -test http-idna-2.14-P {puny encode: examples from RFC 3492} { +test http-idna-2.14-P.$ThreadLevel {puny encode: examples from RFC 3492} { ::tcl::idna puny encode [join [subst [string map {u+ \\u} { u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059 u+308B u+0035 u+79D2 u+524D }]] ""] } MajiKoi5-783gue6qz075azm5e -test http-idna-2.14-Q {puny encode: examples from RFC 3492} { +test http-idna-2.14-Q.$ThreadLevel {puny encode: examples from RFC 3492} { ::tcl::idna puny encode [join [subst [string map {u+ \\u} { u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0 }]] ""] } de-jg4avhby1noc0d -test http-idna-2.14-R {puny encode: examples from RFC 3492} { +test http-idna-2.14-R.$ThreadLevel {puny encode: examples from RFC 3492} { ::tcl::idna puny encode [join [subst [string map {u+ \\u} { u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067 }]] ""] } d9juau41awczczp -test http-idna-2.14-S {puny encode: examples from RFC 3492} { +test http-idna-2.14-S.$ThreadLevel {puny encode: examples from RFC 3492} { ::tcl::idna puny encode {-> $1.00 <-} } {-> $1.00 <--} -test http-idna-3.1 {puny decode: functional test} { +test http-idna-3.1.$ThreadLevel {puny decode: functional test} { ::tcl::idna puny decode abc- } abc -test http-idna-3.2 {puny decode: functional test} { +test http-idna-3.2.$ThreadLevel {puny decode: functional test} { ::tcl::idna puny decode abc-k50ab } a€b€c -test http-idna-3.3 {puny decode: functional test} { +test http-idna-3.3.$ThreadLevel {puny decode: functional test} { ::tcl::idna puny decode ABC- } ABC -test http-idna-3.4 {puny decode: functional test} { +test http-idna-3.4.$ThreadLevel {puny decode: functional test} { ::tcl::idna puny decode ABC-k50ab } A€B€C -test http-idna-3.5 {puny decode: functional test} { +test http-idna-3.5.$ThreadLevel {puny decode: functional test} { ::tcl::idna puny decode ABC-K50AB } A€B€C -test http-idna-3.6 {puny decode: functional test} { +test http-idna-3.6.$ThreadLevel {puny decode: functional test} { ::tcl::idna puny decode abc-K50AB } a€b€c -test http-idna-3.7 {puny decode: functional test} { +test http-idna-3.7.$ThreadLevel {puny decode: functional test} { ::tcl::idna puny decode ABC- 0 } abc -test http-idna-3.8 {puny decode: functional test} { +test http-idna-3.8.$ThreadLevel {puny decode: functional test} { ::tcl::idna puny decode ABC-K50AB 0 } a€b€c -test http-idna-3.9 {puny decode: functional test} { +test http-idna-3.9.$ThreadLevel {puny decode: functional test} { ::tcl::idna puny decode ABC- 1 } ABC -test http-idna-3.10 {puny decode: functional test} { +test http-idna-3.10.$ThreadLevel {puny decode: functional test} { ::tcl::idna puny decode ABC-K50AB 1 } A€B€C -test http-idna-3.11 {puny decode: functional test} { +test http-idna-3.11.$ThreadLevel {puny decode: functional test} { ::tcl::idna puny decode abc- 0 } abc -test http-idna-3.12 {puny decode: functional test} { +test http-idna-3.12.$ThreadLevel {puny decode: functional test} { ::tcl::idna puny decode abc-k50ab 0 } a€b€c -test http-idna-3.13 {puny decode: functional test} { +test http-idna-3.13.$ThreadLevel {puny decode: functional test} { ::tcl::idna puny decode abc- 1 } ABC -test http-idna-3.14 {puny decode: functional test} { +test http-idna-3.14.$ThreadLevel {puny decode: functional test} { ::tcl::idna puny decode abc-k50ab 1 } A€B€C -test http-idna-3.15 {puny decode: edge cases and errors} { +test http-idna-3.15.$ThreadLevel {puny decode: edge cases and errors} { # Is this case actually correct? binary encode hex [encoding convertto utf-8 [::tcl::idna puny decode abc]] } c282c281c280 -test http-idna-3.16 {puny decode: edge cases and errors} -returnCodes error -body { +test http-idna-3.16.$ThreadLevel {puny decode: edge cases and errors} -returnCodes error -body { ::tcl::idna puny decode abc! } -result {bad decode character "!"} -test http-idna-3.17 {puny decode: edge cases and errors} { +test http-idna-3.17.$ThreadLevel {puny decode: edge cases and errors} { catch {::tcl::idna puny decode abc!} -> opt dict get $opt -errorcode } {PUNYCODE BAD_INPUT CHAR} -test http-idna-3.18 {puny decode: edge cases and errors} { +test http-idna-3.18.$ThreadLevel {puny decode: edge cases and errors} { ::tcl::idna puny decode "" } {} # A helper so we don't get lots of crap in failures proc hexify s {lmap c [split $s ""] {format u+%04X [scan $c %c]}} -test http-idna-3.19-A {puny decode: examples from RFC 3492} { +test http-idna-3.19-A.$ThreadLevel {puny decode: examples from RFC 3492} { hexify [::tcl::idna puny decode egbpdaj6bu4bxfgehfvwxn] } [list {*}{ u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644 u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F }] -test http-idna-3.19-B {puny decode: examples from RFC 3492} { +test http-idna-3.19-B.$ThreadLevel {puny decode: examples from RFC 3492} { hexify [::tcl::idna puny decode ihqwcrb4cv8a8dqg056pqjye] } {u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587} -test http-idna-3.19-C {puny decode: examples from RFC 3492} { +test http-idna-3.19-C.$ThreadLevel {puny decode: examples from RFC 3492} { hexify [::tcl::idna puny decode ihqwctvzc91f659drss3x8bo0yb] } {u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587} -test http-idna-3.19-D {puny decode: examples from RFC 3492} { +test http-idna-3.19-D.$ThreadLevel {puny decode: examples from RFC 3492} { hexify [::tcl::idna puny decode Proprostnemluvesky-uyb24dma41a] } [list {*}{ u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074 u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D u+0065 u+0073 u+006B u+0079 }] -test http-idna-3.19-E {puny decode: examples from RFC 3492} { +test http-idna-3.19-E.$ThreadLevel {puny decode: examples from RFC 3492} { hexify [::tcl::idna puny decode 4dbcagdahymbxekheh6e0a7fei0b] } [list {*}{ u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8 u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2 u+05D1 u+05E8 u+05D9 u+05EA }] -test http-idna-3.19-F {puny decode: examples from RFC 3492} { +test http-idna-3.19-F.$ThreadLevel {puny decode: examples from RFC 3492} { hexify [::tcl::idna puny decode \ i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd] } [list {*}{ @@ -1012,13 +1012,13 @@ test http-idna-3.19-F {puny decode: examples from RFC 3492} { u+0940 u+0902 u+092C u+094B u+0932 u+0938 u+0915 u+0924 u+0947 u+0939 u+0948 u+0902 }] -test http-idna-3.19-G {puny decode: examples from RFC 3492} { +test http-idna-3.19-G.$ThreadLevel {puny decode: examples from RFC 3492} { hexify [::tcl::idna puny decode n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa] } [list {*}{ u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092 u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B }] -test http-idna-3.19-H {puny decode: examples from RFC 3492} { +test http-idna-3.19-H.$ThreadLevel {puny decode: examples from RFC 3492} { hexify [::tcl::idna puny decode \ 989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c] } [list {*}{ @@ -1026,7 +1026,7 @@ test http-idna-3.19-H {puny decode: examples from RFC 3492} { u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74 u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C }] -test http-idna-3.19-I {puny decode: examples from RFC 3492} { +test http-idna-3.19-I.$ThreadLevel {puny decode: examples from RFC 3492} { hexify [::tcl::idna puny decode b1abfaaepdrnnbgefbadotcwatmq2g4l] } [list {*}{ u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E @@ -1034,7 +1034,7 @@ test http-idna-3.19-I {puny decode: examples from RFC 3492} { u+044F u+0442 u+043F u+043E u+0440 u+0443 u+0441 u+0441 u+043A u+0438 }] -test http-idna-3.19-J {puny decode: examples from RFC 3492} { +test http-idna-3.19-J.$ThreadLevel {puny decode: examples from RFC 3492} { hexify [::tcl::idna puny decode \ PorqunopuedensimplementehablarenEspaol-fmd56a] } [list {*}{ @@ -1044,7 +1044,7 @@ test http-idna-3.19-J {puny decode: examples from RFC 3492} { u+0062 u+006C u+0061 u+0072 u+0065 u+006E u+0045 u+0073 u+0070 u+0061 u+00F1 u+006F u+006C }] -test http-idna-3.19-K {puny decode: examples from RFC 3492} { +test http-idna-3.19-K.$ThreadLevel {puny decode: examples from RFC 3492} { hexify [::tcl::idna puny decode \ TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g] } [list {*}{ @@ -1053,70 +1053,70 @@ test http-idna-3.19-K {puny decode: examples from RFC 3492} { u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067 u+0056 u+0069 u+1EC7 u+0074 }] -test http-idna-3.19-L {puny decode: examples from RFC 3492} { +test http-idna-3.19-L.$ThreadLevel {puny decode: examples from RFC 3492} { hexify [::tcl::idna puny decode 3B-ww4c5e180e575a65lsy2b] } {u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F} -test http-idna-3.19-M {puny decode: examples from RFC 3492} { +test http-idna-3.19-M.$ThreadLevel {puny decode: examples from RFC 3492} { hexify [::tcl::idna puny decode -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n] } [list {*}{ u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074 u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D u+004F u+004E u+004B u+0045 u+0059 u+0053 }] -test http-idna-3.19-N {puny decode: examples from RFC 3492} { +test http-idna-3.19-N.$ThreadLevel {puny decode: examples from RFC 3492} { hexify [::tcl::idna puny decode Hello-Another-Way--fc4qua05auwb3674vfr0b] } [list {*}{ u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D u+305D u+308C u+305E u+308C u+306E u+5834 u+6240 }] -test http-idna-3.19-O {puny decode: examples from RFC 3492} { +test http-idna-3.19-O.$ThreadLevel {puny decode: examples from RFC 3492} { hexify [::tcl::idna puny decode 2-u9tlzr9756bt3uc0v] } {u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032} -test http-idna-3.19-P {puny decode: examples from RFC 3492} { +test http-idna-3.19-P.$ThreadLevel {puny decode: examples from RFC 3492} { hexify [::tcl::idna puny decode MajiKoi5-783gue6qz075azm5e] } [list {*}{ u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059 u+308B u+0035 u+79D2 u+524D }] -test http-idna-3.19-Q {puny decode: examples from RFC 3492} { +test http-idna-3.19-Q.$ThreadLevel {puny decode: examples from RFC 3492} { hexify [::tcl::idna puny decode de-jg4avhby1noc0d] } {u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0} -test http-idna-3.19-R {puny decode: examples from RFC 3492} { +test http-idna-3.19-R.$ThreadLevel {puny decode: examples from RFC 3492} { hexify [::tcl::idna puny decode d9juau41awczczp] } {u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067} -test http-idna-3.19-S {puny decode: examples from RFC 3492} { +test http-idna-3.19-S.$ThreadLevel {puny decode: examples from RFC 3492} { ::tcl::idna puny decode {-> $1.00 <--} } {-> $1.00 <-} rename hexify "" -test http-idna-4.1 {IDNA encoding} { +test http-idna-4.1.$ThreadLevel {IDNA encoding} { ::tcl::idna encode abc.def } abc.def -test http-idna-4.2 {IDNA encoding} { +test http-idna-4.2.$ThreadLevel {IDNA encoding} { ::tcl::idna encode a€b€c.def } xn--abc-k50ab.def -test http-idna-4.3 {IDNA encoding} { +test http-idna-4.3.$ThreadLevel {IDNA encoding} { ::tcl::idna encode def.a€b€c } def.xn--abc-k50ab -test http-idna-4.4 {IDNA encoding} { +test http-idna-4.4.$ThreadLevel {IDNA encoding} { ::tcl::idna encode ABC.DEF } ABC.DEF -test http-idna-4.5 {IDNA encoding} { +test http-idna-4.5.$ThreadLevel {IDNA encoding} { ::tcl::idna encode A€B€C.def } xn--ABC-k50ab.def -test http-idna-4.6 {IDNA encoding: invalid edge case} { +test http-idna-4.6.$ThreadLevel {IDNA encoding: invalid edge case} { # Should this be an error? ::tcl::idna encode abc..def } abc..def -test http-idna-4.7 {IDNA encoding: invalid char} -returnCodes error -body { +test http-idna-4.7.$ThreadLevel {IDNA encoding: invalid char} -returnCodes error -body { ::tcl::idna encode abc.$.def } -result {bad character "$" in DNS name} -test http-idna-4.7.1 {IDNA encoding: invalid char} { +test http-idna-4.7.1.$ThreadLevel {IDNA encoding: invalid char} { catch {::tcl::idna encode abc.$.def} -> opt dict get $opt -errorcode } {IDNA INVALID_NAME_CHARACTER {$}} -test http-idna-4.8 {IDNA encoding: empty} { +test http-idna-4.8.$ThreadLevel {IDNA encoding: empty} { ::tcl::idna encode "" } {} set overlong www.[join [subst [string map {u+ \\u} { @@ -1124,44 +1124,44 @@ set overlong www.[join [subst [string map {u+ \\u} { u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74 u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C }]] ""].com -test http-idna-4.9 {IDNA encoding: max lengths from RFC 5890} -body { +test http-idna-4.9.$ThreadLevel {IDNA encoding: max lengths from RFC 5890} -body { ::tcl::idna encode $overlong } -returnCodes error -result "hostname part too long" -test http-idna-4.9.1 {IDNA encoding: max lengths from RFC 5890} { +test http-idna-4.9.1.$ThreadLevel {IDNA encoding: max lengths from RFC 5890} { catch {::tcl::idna encode $overlong} -> opt dict get $opt -errorcode } {IDNA OVERLONG_PART xn--989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c} unset overlong -test http-idna-4.10 {IDNA encoding: edge cases} { +test http-idna-4.10.$ThreadLevel {IDNA encoding: edge cases} { ::tcl::idna encode passé.example.com } xn--pass-epa.example.com -test http-idna-5.1 {IDNA decoding} { +test http-idna-5.1.$ThreadLevel {IDNA decoding} { ::tcl::idna decode abc.def } abc.def -test http-idna-5.2 {IDNA decoding} { +test http-idna-5.2.$ThreadLevel {IDNA decoding} { # Invalid entry that's just a wrapper ::tcl::idna decode xn--abc-.def } abc.def -test http-idna-5.3 {IDNA decoding} { +test http-idna-5.3.$ThreadLevel {IDNA decoding} { # Invalid entry that's just a wrapper ::tcl::idna decode xn--abc-.xn--def- } abc.def -test http-idna-5.4 {IDNA decoding} { +test http-idna-5.4.$ThreadLevel {IDNA decoding} { # Invalid entry that's just a wrapper ::tcl::idna decode XN--abc-.XN--def- } abc.def -test http-idna-5.5 {IDNA decoding: error cases} -returnCodes error -body { +test http-idna-5.5.$ThreadLevel {IDNA decoding: error cases} -returnCodes error -body { ::tcl::idna decode xn--$$$.example.com } -result {bad decode character "$"} -test http-idna-5.5.1 {IDNA decoding: error cases} { +test http-idna-5.5.1.$ThreadLevel {IDNA decoding: error cases} { catch {::tcl::idna decode xn--$$$.example.com} -> opt dict get $opt -errorcode } {PUNYCODE BAD_INPUT CHAR} -test http-idna-5.6 {IDNA decoding: error cases} -returnCodes error -body { +test http-idna-5.6.$ThreadLevel {IDNA decoding: error cases} -returnCodes error -body { ::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def } -result {exceeded input data} -test http-idna-5.6.1 {IDNA decoding: error cases} { +test http-idna-5.6.1.$ThreadLevel {IDNA decoding: error cases} { catch {::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def} -> opt dict get $opt -errorcode } {PUNYCODE BAD_INPUT LENGTH} diff --git a/tests/http11.test b/tests/http11.test index ef1f40c..55e7d39 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -954,7 +954,7 @@ test http11-3.8.$ThreadLevel "close,identity no -handler but with -progress" -se halt_httpd } -result {ok {HTTP/1.1 200 OK} ok close {} {} 0 0 0} -test http11-3.9 "close,identity no -handler but with -progress progressPause enters event loop" -setup { +test http11-3.9.$ThreadLevel "close,identity no -handler but with -progress progressPause enters event loop" -setup { variable httpd [create_httpd] set logdata "" } -body { diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test index 161519f..491aae0 100644 --- a/tests/httpPipeline.test +++ b/tests/httpPipeline.test @@ -839,7 +839,7 @@ for {set header 1} {$header <= 4} {incr header} { # Here's the test: - test httpPipeline-${header}.${footer}${label}-${tag} $name \ + test httpPipeline-${header}.${footer}${label}-${tag}-$ThreadLevel $name \ -constraints $cons \ -setup [string map [list TE $te] { # Restore default values for tests: diff --git a/tests/httpProxy.test b/tests/httpProxy.test index 42ad574..90fe828 100644 --- a/tests/httpProxy.test +++ b/tests/httpProxy.test @@ -81,7 +81,7 @@ set aliceCreds {Basic YWxpY2U6YWxpY2lh} # concat Basic [base64::encode intruder:intruder] set badCreds {Basic aW50cnVkZXI6aW50cnVkZXI=} -test httpProxy-1.1 {squid is running - ipv4 noauth} -constraints {needsSquid} -setup { +test httpProxy-1.1.$ThreadLevel {squid is running - ipv4 noauth} -constraints {needsSquid} -setup { } -body { set token [http::geturl http://$n4host:$n4port/] set ri [http::responseInfo $token] @@ -91,7 +91,7 @@ test httpProxy-1.1 {squid is running - ipv4 noauth} -constraints {needsSquid} -s unset -nocomplain ri res } -test httpProxy-1.2 {squid is running - ipv6 noauth} -constraints {needsSquid} -setup { +test httpProxy-1.2.$ThreadLevel {squid is running - ipv6 noauth} -constraints {needsSquid} -setup { } -body { set token [http::geturl http://\[$n6host\]:$n6port/] set ri [http::responseInfo $token] @@ -101,7 +101,7 @@ test httpProxy-1.2 {squid is running - ipv6 noauth} -constraints {needsSquid} -s unset -nocomplain ri res } -test httpProxy-1.3 {squid is running - ipv4 auth} -constraints {needsSquid} -setup { +test httpProxy-1.3.$ThreadLevel {squid is running - ipv4 auth} -constraints {needsSquid} -setup { } -body { set token [http::geturl http://$a4host:$a4port/] set ri [http::responseInfo $token] @@ -111,7 +111,7 @@ test httpProxy-1.3 {squid is running - ipv4 auth} -constraints {needsSquid} -set unset -nocomplain ri res } -test httpProxy-1.4 {squid is running - ipv6 auth} -constraints {needsSquid} -setup { +test httpProxy-1.4.$ThreadLevel {squid is running - ipv6 auth} -constraints {needsSquid} -setup { } -body { set token [http::geturl http://\[$a6host\]:$a6port/] set ri [http::responseInfo $token] @@ -121,7 +121,7 @@ test httpProxy-1.4 {squid is running - ipv6 auth} -constraints {needsSquid} -set unset -nocomplain ri res } -test httpProxy-2.1 {http no-proxy no-auth} -constraints {needsSquid} -setup { +test httpProxy-2.1.$ThreadLevel {http no-proxy no-auth} -constraints {needsSquid} -setup { http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -body { set token [http::geturl http://www.google.com/] @@ -132,7 +132,7 @@ test httpProxy-2.1 {http no-proxy no-auth} -constraints {needsSquid} -setup { unset -nocomplain ri res } -test httpProxy-2.2 {https no-proxy no-auth} -constraints {needsSquid needsTls} -setup { +test httpProxy-2.2.$ThreadLevel {https no-proxy no-auth} -constraints {needsSquid needsTls} -setup { http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -body { set token [http::geturl https://www.google.com/] @@ -143,7 +143,7 @@ test httpProxy-2.2 {https no-proxy no-auth} -constraints {needsSquid needsTls} - unset -nocomplain ri res } -test httpProxy-2.3 {http with-proxy ipv4 no-auth} -constraints {needsSquid} -setup { +test httpProxy-2.3.$ThreadLevel {http with-proxy ipv4 no-auth} -constraints {needsSquid} -setup { http::config -proxyhost $n4host -proxyport $n4port -proxynot {127.0.0.1 localhost} -proxyauth {} } -body { set token [http::geturl http://www.google.com/] @@ -155,7 +155,7 @@ test httpProxy-2.3 {http with-proxy ipv4 no-auth} -constraints {needsSquid} -set http::config -proxyhost {} -proxyport {} -proxynot {} } -test httpProxy-2.4 {https with-proxy ipv4 no-auth} -constraints {needsSquid needsTls} -setup { +test httpProxy-2.4.$ThreadLevel {https with-proxy ipv4 no-auth} -constraints {needsSquid needsTls} -setup { http::config -proxyhost $n4host -proxyport $n4port -proxynot {127.0.0.1 localhost} -proxyauth {} } -body { set token [http::geturl https://www.google.com/] @@ -167,7 +167,7 @@ test httpProxy-2.4 {https with-proxy ipv4 no-auth} -constraints {needsSquid need http::config -proxyhost {} -proxyport {} -proxynot {} } -test httpProxy-2.5 {http with-proxy ipv6 no-auth} -constraints {needsSquid} -setup { +test httpProxy-2.5.$ThreadLevel {http with-proxy ipv6 no-auth} -constraints {needsSquid} -setup { http::config -proxyhost $n6host -proxyport $n6port -proxynot {127.0.0.1 localhost} -proxyauth {} } -body { set token [http::geturl http://www.google.com/] @@ -179,7 +179,7 @@ test httpProxy-2.5 {http with-proxy ipv6 no-auth} -constraints {needsSquid} -set http::config -proxyhost {} -proxyport {} -proxynot {} } -test httpProxy-2.6 {https with-proxy ipv6 no-auth} -constraints {needsSquid needsTls} -setup { +test httpProxy-2.6.$ThreadLevel {https with-proxy ipv6 no-auth} -constraints {needsSquid needsTls} -setup { http::config -proxyhost $n6host -proxyport $n6port -proxynot {127.0.0.1 localhost} -proxyauth {} } -body { set token [http::geturl https://www.google.com/] @@ -191,7 +191,7 @@ test httpProxy-2.6 {https with-proxy ipv6 no-auth} -constraints {needsSquid need http::config -proxyhost {} -proxyport {} -proxynot {} } -test httpProxy-3.1 {http no-proxy with-auth valid-creds-provided} -constraints {needsSquid} -setup { +test httpProxy-3.1.$ThreadLevel {http no-proxy with-auth valid-creds-provided} -constraints {needsSquid} -setup { http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds } -body { set token [http::geturl http://www.google.com/] @@ -205,7 +205,7 @@ test httpProxy-3.1 {http no-proxy with-auth valid-creds-provided} -constraints { http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -test httpProxy-3.2 {https no-proxy with-auth valid-creds-provided} -constraints {needsSquid needsTls} -setup { +test httpProxy-3.2.$ThreadLevel {https no-proxy with-auth valid-creds-provided} -constraints {needsSquid needsTls} -setup { http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds } -body { set token [http::geturl https://www.google.com/] @@ -219,7 +219,7 @@ test httpProxy-3.2 {https no-proxy with-auth valid-creds-provided} -constraints http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -test httpProxy-3.3 {http with-proxy ipv4 with-auth valid-creds-provided} -constraints {needsSquid} -setup { +test httpProxy-3.3.$ThreadLevel {http with-proxy ipv4 with-auth valid-creds-provided} -constraints {needsSquid} -setup { http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds } -body { set token [http::geturl http://www.google.com/] @@ -233,7 +233,7 @@ test httpProxy-3.3 {http with-proxy ipv4 with-auth valid-creds-provided} -constr http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -test httpProxy-3.4 {https with-proxy ipv4 with-auth valid-creds-provided} -constraints {needsSquid needsTls} -setup { +test httpProxy-3.4.$ThreadLevel {https with-proxy ipv4 with-auth valid-creds-provided} -constraints {needsSquid needsTls} -setup { http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds } -body { set token [http::geturl https://www.google.com/] @@ -247,7 +247,7 @@ test httpProxy-3.4 {https with-proxy ipv4 with-auth valid-creds-provided} -const http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -test httpProxy-3.5 {http with-proxy ipv6 with-auth valid-creds-provided} -constraints {needsSquid} -setup { +test httpProxy-3.5.$ThreadLevel {http with-proxy ipv6 with-auth valid-creds-provided} -constraints {needsSquid} -setup { http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds } -body { set token [http::geturl http://www.google.com/] @@ -261,7 +261,7 @@ test httpProxy-3.5 {http with-proxy ipv6 with-auth valid-creds-provided} -constr http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -test httpProxy-3.6 {https with-proxy ipv6 with-auth valid-creds-provided} -constraints {needsSquid needsTls} -setup { +test httpProxy-3.6.$ThreadLevel {https with-proxy ipv6 with-auth valid-creds-provided} -constraints {needsSquid needsTls} -setup { http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds } -body { set token [http::geturl https://www.google.com/] @@ -275,7 +275,7 @@ test httpProxy-3.6 {https with-proxy ipv6 with-auth valid-creds-provided} -const http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -test httpProxy-4.1 {http no-proxy with-auth no-creds-provided} -constraints {needsSquid} -setup { +test httpProxy-4.1.$ThreadLevel {http no-proxy with-auth no-creds-provided} -constraints {needsSquid} -setup { http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} } -body { set token [http::geturl http://www.google.com/] @@ -289,7 +289,7 @@ test httpProxy-4.1 {http no-proxy with-auth no-creds-provided} -constraints {nee http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -test httpProxy-4.2 {https no-proxy with-auth no-creds-provided} -constraints {needsSquid needsTls} -setup { +test httpProxy-4.2.$ThreadLevel {https no-proxy with-auth no-creds-provided} -constraints {needsSquid needsTls} -setup { http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} } -body { set token [http::geturl https://www.google.com/] @@ -303,7 +303,7 @@ test httpProxy-4.2 {https no-proxy with-auth no-creds-provided} -constraints {ne http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -test httpProxy-4.3 {http with-proxy ipv4 with-auth no-creds-provided} -constraints {needsSquid} -setup { +test httpProxy-4.3.$ThreadLevel {http with-proxy ipv4 with-auth no-creds-provided} -constraints {needsSquid} -setup { http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} } -body { set token [http::geturl http://www.google.com/] @@ -317,7 +317,7 @@ test httpProxy-4.3 {http with-proxy ipv4 with-auth no-creds-provided} -constrain http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -test httpProxy-4.4 {https with-proxy ipv4 with-auth no-creds-provided} -constraints {needsSquid needsTls} -setup { +test httpProxy-4.4.$ThreadLevel {https with-proxy ipv4 with-auth no-creds-provided} -constraints {needsSquid needsTls} -setup { http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} } -body { set token [http::geturl https://www.google.com/] @@ -331,7 +331,7 @@ test httpProxy-4.4 {https with-proxy ipv4 with-auth no-creds-provided} -constrai http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -test httpProxy-4.5 {http with-proxy ipv6 with-auth no-creds-provided} -constraints {needsSquid} -setup { +test httpProxy-4.5.$ThreadLevel {http with-proxy ipv6 with-auth no-creds-provided} -constraints {needsSquid} -setup { http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth {} } -body { set token [http::geturl http://www.google.com/] @@ -345,7 +345,7 @@ test httpProxy-4.5 {http with-proxy ipv6 with-auth no-creds-provided} -constrain http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -test httpProxy-4.6 {https with-proxy ipv6 with-auth no-creds-provided} -constraints {needsSquid needsTls} -setup { +test httpProxy-4.6.$ThreadLevel {https with-proxy ipv6 with-auth no-creds-provided} -constraints {needsSquid needsTls} -setup { http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth {} } -body { set token [http::geturl https://www.google.com/] @@ -359,7 +359,7 @@ test httpProxy-4.6 {https with-proxy ipv6 with-auth no-creds-provided} -constrai http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -test httpProxy-5.1 {http no-proxy with-auth bad-creds-provided} -constraints {needsSquid} -setup { +test httpProxy-5.1.$ThreadLevel {http no-proxy with-auth bad-creds-provided} -constraints {needsSquid} -setup { http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds } -body { set token [http::geturl http://www.google.com/] @@ -373,7 +373,7 @@ test httpProxy-5.1 {http no-proxy with-auth bad-creds-provided} -constraints {ne http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -test httpProxy-5.2 {https no-proxy with-auth bad-creds-provided} -constraints {needsSquid needsTls} -setup { +test httpProxy-5.2.$ThreadLevel {https no-proxy with-auth bad-creds-provided} -constraints {needsSquid needsTls} -setup { http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds } -body { set token [http::geturl https://www.google.com/] @@ -387,7 +387,7 @@ test httpProxy-5.2 {https no-proxy with-auth bad-creds-provided} -constraints {n http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -test httpProxy-5.3 {http with-proxy ipv4 with-auth bad-creds-provided} -constraints {needsSquid} -setup { +test httpProxy-5.3.$ThreadLevel {http with-proxy ipv4 with-auth bad-creds-provided} -constraints {needsSquid} -setup { http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds } -body { set token [http::geturl http://www.google.com/] @@ -401,7 +401,7 @@ test httpProxy-5.3 {http with-proxy ipv4 with-auth bad-creds-provided} -constrai http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -test httpProxy-5.4 {https with-proxy ipv4 with-auth bad-creds-provided} -constraints {needsSquid needsTls} -setup { +test httpProxy-5.4.$ThreadLevel {https with-proxy ipv4 with-auth bad-creds-provided} -constraints {needsSquid needsTls} -setup { http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds } -body { set token [http::geturl https://www.google.com/] @@ -415,7 +415,7 @@ test httpProxy-5.4 {https with-proxy ipv4 with-auth bad-creds-provided} -constra http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -test httpProxy-5.5 {http with-proxy ipv6 with-auth bad-creds-provided} -constraints {needsSquid} -setup { +test httpProxy-5.5.$ThreadLevel {http with-proxy ipv6 with-auth bad-creds-provided} -constraints {needsSquid} -setup { http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds } -body { set token [http::geturl http://www.google.com/] @@ -429,7 +429,7 @@ test httpProxy-5.5 {http with-proxy ipv6 with-auth bad-creds-provided} -constrai http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -test httpProxy-5.6 {https with-proxy ipv6 with-auth bad-creds-provided} -constraints {needsSquid needsTls} -setup { +test httpProxy-5.6.$ThreadLevel {https with-proxy ipv6 with-auth bad-creds-provided} -constraints {needsSquid needsTls} -setup { http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds } -body { set token [http::geturl https://www.google.com/] -- cgit v0.12 From f27f0773c49d7e8ebf1d5f69d16bcb80906c659d Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 28 Oct 2022 17:50:50 +0000 Subject: Update test result --- tests/chanio.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/chanio.test b/tests/chanio.test index 91cfcd4..41c0ef7 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -5294,7 +5294,7 @@ test chan-io-39.22 {Tcl_SetChannelOption, invariance} -setup { lappend l [chan configure $f1 -eofchar] } -cleanup { chan close $f1 -} -result {{{}} O D} +} -result {{} O D} test chan-io-39.22a {Tcl_SetChannelOption, invariance} -setup { file delete $path(test1) set l [list] -- cgit v0.12 From 41c34da9dabc6763d9e66c7329841dfcac77127d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 29 Oct 2022 14:08:52 +0000 Subject: Simplify -eofchar parsing (just check for " {}" at the end, in stead of full list parsing) --- generic/tclIO.c | 28 +++++----------------------- 1 file changed, 5 insertions(+), 23 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index b3b62ed..bf3f543 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8175,32 +8175,14 @@ Tcl_SetChannelOption( UpdateInterest(chanPtr); return TCL_OK; } else if (HaveOpt(2, "-eofchar")) { - if (!newValue[0] || (!(newValue[0] & 0x80) && !newValue[1])) { - if (GotFlag(statePtr, TCL_READABLE)) { - statePtr->inEofChar = newValue[0]; - } + if (!newValue[0] || (!(newValue[0] & 0x80) && (!newValue[1] #ifndef TCL_NO_DEPRECATED - } else if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { - return TCL_ERROR; - } else if (argc == 0) { - statePtr->inEofChar = 0; - } else if (argc == 1 || argc == 2) { - int inValue = (int) argv[0][0]; - int outValue = (argc == 2) ? (int) argv[1][0] : 0; - - if (inValue & 0x80 || (inValue && argv[0][1]) || outValue) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad value for -eofchar: must be non-NUL ASCII" - " character", -1)); - } - Tcl_Free((void *)argv); - return TCL_ERROR; - } + || !strcmp(newValue+1, " {}") +#endif + ))) { if (GotFlag(statePtr, TCL_READABLE)) { - statePtr->inEofChar = inValue; + statePtr->inEofChar = newValue[0]; } -#endif } else { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( -- cgit v0.12 From 60da2df16ccc0c150d362cf5d0eda5d0b83a0869 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 29 Oct 2022 16:35:11 +0000 Subject: [c7f3977380] Balance stack operations in the mode with no Thread package. --- tests/http.test | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tests/http.test b/tests/http.test index 742ff1c..08195a6 100644 --- a/tests/http.test +++ b/tests/http.test @@ -80,7 +80,9 @@ if {![info exists ThreadLevel]} { foreach ThreadLevel $ValueRange { source [info script] } - eval [lpop threadStack] + if {[llength $threadStack]} { + eval [lpop threadStack] + } catch {unset ThreadLevel} catch {unset ValueRange} return -- cgit v0.12 From 61814ba324f4652c444ecb2776f2cf8eb799dac7 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 30 Oct 2022 03:04:11 +0000 Subject: Implement lreplace4 BCC instruction --- generic/tclBasic.c | 1 + generic/tclCompCmdsGR.c | 69 +++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclCompile.c | 2 ++ generic/tclCompile.h | 6 +++-- generic/tclExecute.c | 66 ++++++++++++++++++++++++++++++++++++++++++---- generic/tclInt.h | 3 +++ 6 files changed, 140 insertions(+), 7 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 13715f8..c9697d2 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -312,6 +312,7 @@ static const CmdInfo builtInCmds[] = { {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE}, {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE}, {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE}, + {"xx", Tcl_LinsertObjCmd, TclCompileXxCmd, NULL, CMD_IS_SAFE}, {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE}, {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE}, diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index bce71dc..4aa454b 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -3024,6 +3024,75 @@ TclCompileObjectSelfCmd( } /* + *---------------------------------------------------------------------- + * + * TclCompileXxCmd -- + * + * How to compile the "linsert2" command. We only bother with the case + * where the index is constant. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileXxCmd( + Tcl_Interp *interp, /* Tcl interpreter for context. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + TCL_UNUSED(Command *), + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr, *listTokenPtr; + int idx, i; + + if (parsePtr->numWords < 3) { + return TCL_ERROR; + } + listTokenPtr = TokenAfter(parsePtr->tokenPtr); + + /* + * Parse the index. Will only compile if it is constant and not an + * _integer_ less than zero (since we reserve negative indices here for + * end-relative indexing) or an end-based index greater than 'end' itself. + */ + + tokenPtr = TokenAfter(listTokenPtr); + + /* + * NOTE: This command treats all inserts at indices before the list + * the same as inserts at the start of the list, and all inserts + * after the list the same as inserts at the end of the list. We + * make that transformation here so we can use the optimized bytecode + * as much as possible. + */ + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_END, + &idx) != TCL_OK) { + return TCL_ERROR; + } + + /* + * There are four main cases. If there are no values to insert, this is + * just a confirm-listiness check. If the index is '0', this is a prepend. + * If the index is 'end' (== TCL_INDEX_END), this is an append. Otherwise, + * this is a splice (== split, insert values as list, concat-3). + */ + + CompileWord(envPtr, listTokenPtr, interp, 1); + + for (i=3 ; inumWords ; i++) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, i); + } + + TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 2, envPtr); + TclEmitInt4(idx, envPtr); + TclEmitInt4(idx-1, envPtr); + + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 2d22dc1..2535167 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -675,6 +675,8 @@ InstructionDesc const tclInstructionTable[] = { /* String Less or equal: push (stknext <= stktop) */ {"strge", 1, -1, 0, {OPERAND_NONE}}, /* String Greater or equal: push (stknext >= stktop) */ + {"lreplace4", 13, INT_MIN, 3, {OPERAND_UINT4, OPERAND_INT4, OPERAND_INT4}}, + /* Stack: ... listobj num_elems first last new1 ... newN => ... newlistobj */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 2843ef5..c82dc6e 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -848,8 +848,10 @@ typedef struct ByteCode { #define INST_STR_LE 193 #define INST_STR_GE 194 +#define INST_LREPLACE4 195 + /* The last opcode */ -#define LAST_INST_OPCODE 194 +#define LAST_INST_OPCODE 195 /* * Table describing the Tcl bytecode instructions: their name (for displaying @@ -860,7 +862,7 @@ typedef struct ByteCode { * instruction. */ -#define MAX_INSTRUCTION_OPERANDS 2 +#define MAX_INSTRUCTION_OPERANDS 3 typedef enum InstOperandType { OPERAND_NONE, diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 408032b..629df59 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5244,11 +5244,67 @@ TEBCresume( NEXT_INST_F(1, 1, 0); } - /* - * End of INST_LIST and related instructions. - * ----------------------------------------------------------------- - * Start of string-related instructions. - */ + case INST_LREPLACE4: + { + int firstIdx, lastIdx, numToDelete, numNewElems; + opnd = TclGetInt4AtPtr(pc + 1); + firstIdx = TclGetInt4AtPtr(pc + 5); /* First delete position */ + lastIdx = TclGetInt4AtPtr(pc + 9); /* Last delete position */ + numNewElems = opnd - 1; + valuePtr = OBJ_AT_DEPTH(numNewElems); + if (Tcl_ListObjLength(interp, valuePtr, &length) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + firstIdx = TclIndexDecode(firstIdx, length-1); + if (firstIdx == TCL_INDEX_NONE) { + firstIdx = 0; + } else if (firstIdx > length) { + firstIdx = length; + } + numToDelete = 0; + if (lastIdx != TCL_INDEX_NONE) { + lastIdx = TclIndexDecode(lastIdx, length - 1); + if (lastIdx >= firstIdx) { + numToDelete = lastIdx - firstIdx + 1; + } + } + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_DuplicateObj(valuePtr); + if (Tcl_ListObjReplace(interp, + objResultPtr, + firstIdx, + numToDelete, + numNewElems, + &OBJ_AT_DEPTH(numNewElems-1)) + != TCL_OK) { + TRACE_ERROR(interp); + Tcl_DecrRefCount(objResultPtr); + goto gotError; + } + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + NEXT_INST_V(13, opnd, 1); + } else { + if (Tcl_ListObjReplace(interp, + valuePtr, + firstIdx, + numToDelete, + numNewElems, + &OBJ_AT_DEPTH(numNewElems-1)) + != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); + NEXT_INST_V(13, opnd-1, 0); + } + } + + /* + * End of INST_LIST and related instructions. + * ----------------------------------------------------------------- + * Start of string-related instructions. + */ case INST_STR_EQ: case INST_STR_NEQ: /* String (in)equality check */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 40cf10c..a67c8f9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3954,6 +3954,9 @@ MODULE_SCOPE int TclCompileBasicMin1ArgCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileBasicMin2ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileXxCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE Tcl_ObjCmdProc TclInvertOpCmd; MODULE_SCOPE int TclCompileInvertOpCmd(Tcl_Interp *interp, -- cgit v0.12 From 5da6b8e3c356a3786e96336ea19a8c4fabcb17fa Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 30 Oct 2022 04:27:03 +0000 Subject: New bytecode for linsert --- generic/tclCompCmdsGR.c | 41 +++++------------------------------------ generic/tclCompile.c | 8 ++++++-- generic/tclCompile.h | 2 +- generic/tclExecute.c | 15 ++++++++------- 4 files changed, 20 insertions(+), 46 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 4aa454b..ddb9746 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -1391,48 +1391,16 @@ TclCompileLinsertCmd( */ CompileWord(envPtr, listTokenPtr, interp, 1); - if (parsePtr->numWords == 3) { - TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( (int)TCL_INDEX_END, envPtr); - return TCL_OK; - } for (i=3 ; inumWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } - TclEmitInstInt4( INST_LIST, i - 3, envPtr); - if (idx == (int)TCL_INDEX_START) { - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } else if (idx == (int)TCL_INDEX_END) { - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } else { - /* - * Here we handle two ranges for idx. First when idx > 0, we - * want the first half of the split to end at index idx-1 and - * the second half to start at index idx. - * Second when idx < TCL_INDEX_END, indicating "end-N" indexing, - * we want the first half of the split to end at index end-N and - * the second half to start at index end-N+1. We accomplish this - * with a pre-adjustment of the end-N value. - * The root of this is that the commands [lrange] and [linsert] - * differ in their interpretation of the "end" index. - */ - - if (idx < (int)TCL_INDEX_END) { - idx++; - } - TclEmitInstInt4( INST_OVER, 1, envPtr); - TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( idx - 1, envPtr); - TclEmitInstInt4( INST_REVERSE, 3, envPtr); - TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( (int)TCL_INDEX_END, envPtr); - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } + TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 2, envPtr); + TclEmitInt4(0, envPtr); + TclEmitInt4(idx, envPtr); + TclEmitInt4(idx-1, envPtr); return TCL_OK; } @@ -3086,6 +3054,7 @@ TclCompileXxCmd( } TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 2, envPtr); + TclEmitInt4(0, envPtr); TclEmitInt4(idx, envPtr); TclEmitInt4(idx-1, envPtr); diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 2535167..c01ddb8 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -675,8 +675,12 @@ InstructionDesc const tclInstructionTable[] = { /* String Less or equal: push (stknext <= stktop) */ {"strge", 1, -1, 0, {OPERAND_NONE}}, /* String Greater or equal: push (stknext >= stktop) */ - {"lreplace4", 13, INT_MIN, 3, {OPERAND_UINT4, OPERAND_INT4, OPERAND_INT4}}, - /* Stack: ... listobj num_elems first last new1 ... newN => ... newlistobj */ + {"lreplace4", 17, INT_MIN, 4, {OPERAND_UINT4, OPERAND_UINT4, OPERAND_INT4, OPERAND_INT4}}, + /* Operands: number of arguments, end_indicator, firstIdx, lastIdx + * end_indicator: 0 if "end" is treated as index of last element, + * 1 if "end" is position after last element + * firstIdx,lastIdx: range of elements to delete + * Stack: ... listobj new1 ... newN => ... newlistobj */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index c82dc6e..9633050 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -862,7 +862,7 @@ typedef struct ByteCode { * instruction. */ -#define MAX_INSTRUCTION_OPERANDS 3 +#define MAX_INSTRUCTION_OPERANDS 4 typedef enum InstOperandType { OPERAND_NONE, diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 629df59..2713093 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5246,17 +5246,18 @@ TEBCresume( case INST_LREPLACE4: { - int firstIdx, lastIdx, numToDelete, numNewElems; + int firstIdx, lastIdx, numToDelete, numNewElems, end_indicator; opnd = TclGetInt4AtPtr(pc + 1); - firstIdx = TclGetInt4AtPtr(pc + 5); /* First delete position */ - lastIdx = TclGetInt4AtPtr(pc + 9); /* Last delete position */ + end_indicator = TclGetInt4AtPtr(pc + 5); + firstIdx = TclGetInt4AtPtr(pc + 9); + lastIdx = TclGetInt4AtPtr(pc + 13); numNewElems = opnd - 1; valuePtr = OBJ_AT_DEPTH(numNewElems); if (Tcl_ListObjLength(interp, valuePtr, &length) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } - firstIdx = TclIndexDecode(firstIdx, length-1); + firstIdx = TclIndexDecode(firstIdx, length-end_indicator); if (firstIdx == TCL_INDEX_NONE) { firstIdx = 0; } else if (firstIdx > length) { @@ -5264,7 +5265,7 @@ TEBCresume( } numToDelete = 0; if (lastIdx != TCL_INDEX_NONE) { - lastIdx = TclIndexDecode(lastIdx, length - 1); + lastIdx = TclIndexDecode(lastIdx, length - end_indicator); if (lastIdx >= firstIdx) { numToDelete = lastIdx - firstIdx + 1; } @@ -5283,7 +5284,7 @@ TEBCresume( goto gotError; } TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_V(13, opnd, 1); + NEXT_INST_V(17, opnd, 1); } else { if (Tcl_ListObjReplace(interp, valuePtr, @@ -5296,7 +5297,7 @@ TEBCresume( goto gotError; } TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); - NEXT_INST_V(13, opnd-1, 0); + NEXT_INST_V(17, opnd-1, 0); } } -- cgit v0.12 From b2223e8eaf55dad117f1f99bc23ead87a30a7db3 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 30 Oct 2022 10:43:58 +0000 Subject: New bytecode implementation for lreplace --- generic/tclCompCmdsGR.c | 191 ++++++++++++++---------------------------------- generic/tclCompile.c | 4 +- 2 files changed, 55 insertions(+), 140 deletions(-) diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index ddb9746..72716a4 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -1363,33 +1363,21 @@ TclCompileLinsertCmd( } listTokenPtr = TokenAfter(parsePtr->tokenPtr); - /* - * Parse the index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing) or an end-based index greater than 'end' itself. - */ - tokenPtr = TokenAfter(listTokenPtr); /* - * NOTE: This command treats all inserts at indices before the list + * This command treats all inserts at indices before the list * the same as inserts at the start of the list, and all inserts * after the list the same as inserts at the end of the list. We * make that transformation here so we can use the optimized bytecode * as much as possible. */ - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_END, - &idx) != TCL_OK) { + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_END, &idx) + != TCL_OK) { + /* Not a constant index. */ return TCL_ERROR; } - /* - * There are four main cases. If there are no values to insert, this is - * just a confirm-listiness check. If the index is '0', this is a prepend. - * If the index is 'end' (== TCL_INDEX_END), this is an append. Otherwise, - * this is a splice (== split, insert values as list, concat-3). - */ - CompileWord(envPtr, listTokenPtr, interp, 1); for (i=3 ; inumWords ; i++) { @@ -1397,10 +1385,12 @@ TclCompileLinsertCmd( CompileWord(envPtr, tokenPtr, interp, i); } + /* First operand is count of new elements */ TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 2, envPtr); - TclEmitInt4(0, envPtr); - TclEmitInt4(idx, envPtr); - TclEmitInt4(idx-1, envPtr); + TclEmitInt4(0, envPtr); /* "end" refers to position AFTER last element */ + TclEmitInt4(idx, envPtr);/* Insertion point (also start of range to delete) */ + TclEmitInt4(TCL_INDEX_NONE, envPtr); /* End of range to delete. + TCL_INDEX_NONE => no deletions */ return TCL_OK; } @@ -1426,8 +1416,7 @@ TclCompileLreplaceCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr, *listTokenPtr; - int idx1, idx2, i; - int emptyPrefix=1, suffixStart = 0; + int first, last, i, end_indicator; if (parsePtr->numWords < 4) { return TCL_ERROR; @@ -1436,108 +1425,35 @@ TclCompileLreplaceCmd( tokenPtr = TokenAfter(listTokenPtr); if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE, - &idx1) != TCL_OK) { + &first) != TCL_OK) { return TCL_ERROR; } tokenPtr = TokenAfter(tokenPtr); if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_NONE, TCL_INDEX_END, - &idx2) != TCL_OK) { + &last) != TCL_OK) { return TCL_ERROR; } - - /* - * General structure of the [lreplace] result is - * prefix replacement suffix - * In a few cases we can predict various parts will be empty and - * take advantage. - * - * The proper suffix begins with the greater of indices idx1 or - * idx2 + 1. If we cannot tell at compile time which is greater, - * we must defer to direct evaluation. - */ - - if (idx1 == (int)TCL_INDEX_NONE) { - suffixStart = (int)TCL_INDEX_NONE; - } else if (idx2 == (int)TCL_INDEX_NONE) { - suffixStart = idx1; - } else if (idx2 == (int)TCL_INDEX_END) { - suffixStart = (int)TCL_INDEX_NONE; - } else if (((idx2 < (int)TCL_INDEX_END) && (idx1 <= (int)TCL_INDEX_END)) - || ((idx2 >= (int)TCL_INDEX_START) && (idx1 >= (int)TCL_INDEX_START))) { - suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1; - } else { - return TCL_ERROR; + end_indicator = 1; /* "end" means last element by default */ + if (first == (int)TCL_INDEX_NONE) { + /* Special case: first == TCL_INDEX_NONE => Range after last element. */ + first = TCL_INDEX_END; /* Insert at end where ... */ + end_indicator = 0; /* ... end means AFTER last element */ + last = TCL_INDEX_NONE; /* Informs lreplace, nothing to replace */ } - /* All paths start with computing/pushing the original value. */ CompileWord(envPtr, listTokenPtr, interp, 1); - /* - * Push all the replacement values next so any errors raised in - * creating them get raised first. - */ - if (parsePtr->numWords > 4) { - /* Push the replacement arguments */ + for (i=4 ; inumWords ; i++) { tokenPtr = TokenAfter(tokenPtr); - for (i=4 ; inumWords ; i++) { - CompileWord(envPtr, tokenPtr, interp, i); - tokenPtr = TokenAfter(tokenPtr); - } - - /* Make a list of them... */ - TclEmitInstInt4( INST_LIST, i - 4, envPtr); - - emptyPrefix = 0; - } - - if ((idx1 == suffixStart) && (parsePtr->numWords == 4)) { - /* - * This is a "no-op". Example: [lreplace {a b c} 2 0] - * We still do a list operation to get list-verification - * and canonicalization side effects. - */ - TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( (int)TCL_INDEX_END, envPtr); - return TCL_OK; - } - - if (idx1 != (int)TCL_INDEX_START) { - /* Prefix may not be empty; generate bytecode to push it */ - if (emptyPrefix) { - TclEmitOpcode( INST_DUP, envPtr); - } else { - TclEmitInstInt4( INST_OVER, 1, envPtr); - } - TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( idx1 - 1, envPtr); - if (!emptyPrefix) { - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } - emptyPrefix = 0; - } - - if (!emptyPrefix) { - TclEmitInstInt4( INST_REVERSE, 2, envPtr); - } - - if (suffixStart == (int)TCL_INDEX_NONE) { - TclEmitOpcode( INST_POP, envPtr); - if (emptyPrefix) { - PushStringLiteral(envPtr, ""); - } - } else { - /* Suffix may not be empty; generate bytecode to push it */ - TclEmitInstInt4( INST_LIST_RANGE_IMM, suffixStart, envPtr); - TclEmitInt4( (int)TCL_INDEX_END, envPtr); - if (!emptyPrefix) { - TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } + CompileWord(envPtr, tokenPtr, interp, i); } - return TCL_OK; -} + TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 3, envPtr); + TclEmitInt4(end_indicator, envPtr); + TclEmitInt4(first, envPtr); + TclEmitInt4(last, envPtr); + return TCL_OK;} /* *---------------------------------------------------------------------- @@ -3012,52 +2928,51 @@ TclCompileXxCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr, *listTokenPtr; - int idx, i; + int first, last, i, end_indicator; - if (parsePtr->numWords < 3) { + if (parsePtr->numWords < 4) { return TCL_ERROR; } listTokenPtr = TokenAfter(parsePtr->tokenPtr); - /* - * Parse the index. Will only compile if it is constant and not an - * _integer_ less than zero (since we reserve negative indices here for - * end-relative indexing) or an end-based index greater than 'end' itself. - */ - tokenPtr = TokenAfter(listTokenPtr); + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE, + &first) != TCL_OK) { + return TCL_ERROR; + } - /* - * NOTE: This command treats all inserts at indices before the list - * the same as inserts at the start of the list, and all inserts - * after the list the same as inserts at the end of the list. We - * make that transformation here so we can use the optimized bytecode - * as much as possible. - */ - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_END, - &idx) != TCL_OK) { + tokenPtr = TokenAfter(tokenPtr); + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_NONE, TCL_INDEX_END, + &last) != TCL_OK) { return TCL_ERROR; } + end_indicator = 1; /* "end" means last element by default */ + if (first == (int)TCL_INDEX_NONE) { + /* first == TCL_INDEX_NONE => Range after last element. */ + first = TCL_INDEX_END; /* Insert at end where ... */ + end_indicator = 0; /* ... end means AFTER last element */ + last = TCL_INDEX_NONE; /* Informs lreplace, nothing to replace */ + } else if (last == TCL_INDEX_NONE) { + /* + * last == TCL_INDEX_NONE => last precedes first element + * lreplace4 will treat this as nothing to delete + * Nought to do, just here for clarity, will be optimized away + */ + } else { - /* - * There are four main cases. If there are no values to insert, this is - * just a confirm-listiness check. If the index is '0', this is a prepend. - * If the index is 'end' (== TCL_INDEX_END), this is an append. Otherwise, - * this is a splice (== split, insert values as list, concat-3). - */ + } CompileWord(envPtr, listTokenPtr, interp, 1); - for (i=3 ; inumWords ; i++) { + for (i=4 ; inumWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } - TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 2, envPtr); - TclEmitInt4(0, envPtr); - TclEmitInt4(idx, envPtr); - TclEmitInt4(idx-1, envPtr); - + TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 3, envPtr); + TclEmitInt4(end_indicator, envPtr); + TclEmitInt4(first, envPtr); + TclEmitInt4(last, envPtr); return TCL_OK; } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index c01ddb8..57e2d71 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -677,8 +677,8 @@ InstructionDesc const tclInstructionTable[] = { /* String Greater or equal: push (stknext >= stktop) */ {"lreplace4", 17, INT_MIN, 4, {OPERAND_UINT4, OPERAND_UINT4, OPERAND_INT4, OPERAND_INT4}}, /* Operands: number of arguments, end_indicator, firstIdx, lastIdx - * end_indicator: 0 if "end" is treated as index of last element, - * 1 if "end" is position after last element + * end_indicator: 1 if "end" is treated as index of last element, + * 0 if "end" is position after last element * firstIdx,lastIdx: range of elements to delete * Stack: ... listobj new1 ... newN => ... newlistobj */ -- cgit v0.12 From e2ee6601c9ae82a358e3e6e46d4b594a403d4468 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 30 Oct 2022 12:51:57 +0000 Subject: One more unused stub entry --- generic/tcl.decls | 52 ++++++++++++++++++++++-------------------- generic/tclDecls.h | 61 ++++++++++++++++++++++++++------------------------ generic/tclPlatDecls.h | 13 +++++++++++ generic/tclStubInit.c | 5 ++++- 4 files changed, 77 insertions(+), 54 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 9716b32..a933d95 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -136,11 +136,11 @@ declare 30 { void TclFreeObj(Tcl_Obj *objPtr) } declare 31 { - int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *boolPtr) + int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *intPtr) } declare 32 { int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - int *boolPtr) + int *intPtr) } declare 33 { unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *lengthPtr) @@ -199,7 +199,7 @@ declare 48 { int count, int objc, Tcl_Obj *const objv[]) } declare 49 { - Tcl_Obj *Tcl_NewBooleanObj(int boolValue) + Tcl_Obj *Tcl_NewBooleanObj(int intValue) } declare 50 { Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, int length) @@ -223,14 +223,14 @@ declare 56 { Tcl_Obj *Tcl_NewStringObj(const char *bytes, int length) } declare 57 { - void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue) + void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int intValue) } declare 58 { - unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length) + unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int numBytes) } declare 59 { void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes, - int length) + int numBytes) } declare 60 { void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue) @@ -316,12 +316,12 @@ declare 85 { int flags) } declare 86 { - int Tcl_CreateAlias(Tcl_Interp *slave, const char *slaveCmd, + int Tcl_CreateAlias(Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int argc, CONST84 char *const *argv) } declare 87 { - int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd, + int Tcl_CreateAliasObj(Tcl_Interp *childInterp, const char *childCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]) } @@ -364,7 +364,7 @@ declare 96 { Tcl_CmdDeleteProc *deleteProc) } declare 97 { - Tcl_Interp *Tcl_CreateSlave(Tcl_Interp *interp, const char *slaveName, + Tcl_Interp *Tcl_CreateSlave(Tcl_Interp *interp, const char *name, int isSafe) } declare 98 { @@ -582,7 +582,7 @@ declare 162 { CONST84_RETURN char *Tcl_GetHostName(void) } declare 163 { - int Tcl_GetInterpPath(Tcl_Interp *askInterp, Tcl_Interp *slaveInterp) + int Tcl_GetInterpPath(Tcl_Interp *interp, Tcl_Interp *childInterp) } declare 164 { Tcl_Interp *Tcl_GetMaster(Tcl_Interp *interp) @@ -712,7 +712,7 @@ declare 198 { } declare 199 { Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port, - const char *address, const char *myaddr, int myport, int async) + const char *address, const char *myaddr, int myport, int flags) } declare 200 { Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port, @@ -1123,8 +1123,8 @@ declare 312 { int Tcl_NumUtfChars(const char *src, int length) } declare 313 { - int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, - int appendFlag) + int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, + int charsToRead, int appendFlag) } declare 314 { void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) @@ -1277,16 +1277,17 @@ declare 359 { const char *command, int length) } declare 360 { - int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, int numBytes, - Tcl_Parse *parsePtr, int append, CONST84 char **termPtr) + int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, + int numBytes, Tcl_Parse *parsePtr, int append, + CONST84 char **termPtr) } declare 361 { - int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, int numBytes, - int nested, Tcl_Parse *parsePtr) + int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, + int numBytes, int nested, Tcl_Parse *parsePtr) } declare 362 { - int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, int numBytes, - Tcl_Parse *parsePtr) + int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, + int numBytes, Tcl_Parse *parsePtr) } declare 363 { int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start, @@ -1294,8 +1295,8 @@ declare 363 { CONST84 char **termPtr) } declare 364 { - int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, int numBytes, - Tcl_Parse *parsePtr, int append) + int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, + int numBytes, Tcl_Parse *parsePtr, int append) } # These 4 functions are obsolete, use Tcl_FSGetCwd, Tcl_FSChdir, # Tcl_FSAccess and Tcl_FSStat @@ -2091,8 +2092,8 @@ declare 574 { void Tcl_AppendObjToErrorInfo(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 575 { - void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, const char *bytes, int length, - int limit, const char *ellipsis) + void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, const char *bytes, + int length, int limit, const char *ellipsis) } declare 576 { Tcl_Obj *Tcl_Format(Tcl_Interp *interp, const char *format, int objc, @@ -2111,7 +2112,7 @@ declare 579 { # ----- BASELINE -- FOR -- 8.5.0 ----- # -declare 682 { +declare 683 { void TclUnusedStubEntry(void) } @@ -2137,6 +2138,9 @@ declare 0 win { declare 1 win { char *Tcl_WinTCharToUtf(const TCHAR *str, int len, Tcl_DString *dsPtr) } +declare 3 win { + void TclUnusedStubEntry(void) +} ################################ # Mac OS X specific functions diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 6d7a8a3..d8ec374 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -236,13 +236,13 @@ EXTERN void TclFreeObj(Tcl_Obj *objPtr); #define Tcl_GetBoolean_TCL_DECLARED /* 31 */ EXTERN int Tcl_GetBoolean(Tcl_Interp *interp, CONST char *src, - int *boolPtr); + int *intPtr); #endif #ifndef Tcl_GetBooleanFromObj_TCL_DECLARED #define Tcl_GetBooleanFromObj_TCL_DECLARED /* 32 */ EXTERN int Tcl_GetBooleanFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, int *boolPtr); + Tcl_Obj *objPtr, int *intPtr); #endif #ifndef Tcl_GetByteArrayFromObj_TCL_DECLARED #define Tcl_GetByteArrayFromObj_TCL_DECLARED @@ -344,7 +344,7 @@ EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp, #ifndef Tcl_NewBooleanObj_TCL_DECLARED #define Tcl_NewBooleanObj_TCL_DECLARED /* 49 */ -EXTERN Tcl_Obj * Tcl_NewBooleanObj(int boolValue); +EXTERN Tcl_Obj * Tcl_NewBooleanObj(int intValue); #endif #ifndef Tcl_NewByteArrayObj_TCL_DECLARED #define Tcl_NewByteArrayObj_TCL_DECLARED @@ -385,18 +385,18 @@ EXTERN Tcl_Obj * Tcl_NewStringObj(CONST char *bytes, int length); #ifndef Tcl_SetBooleanObj_TCL_DECLARED #define Tcl_SetBooleanObj_TCL_DECLARED /* 57 */ -EXTERN void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue); +EXTERN void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int intValue); #endif #ifndef Tcl_SetByteArrayLength_TCL_DECLARED #define Tcl_SetByteArrayLength_TCL_DECLARED /* 58 */ -EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length); +EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int numBytes); #endif #ifndef Tcl_SetByteArrayObj_TCL_DECLARED #define Tcl_SetByteArrayObj_TCL_DECLARED /* 59 */ EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, - CONST unsigned char *bytes, int length); + CONST unsigned char *bytes, int numBytes); #endif #ifndef Tcl_SetDoubleObj_TCL_DECLARED #define Tcl_SetDoubleObj_TCL_DECLARED @@ -544,16 +544,16 @@ EXTERN int Tcl_ConvertCountedElement(CONST char *src, #ifndef Tcl_CreateAlias_TCL_DECLARED #define Tcl_CreateAlias_TCL_DECLARED /* 86 */ -EXTERN int Tcl_CreateAlias(Tcl_Interp *slave, - CONST char *slaveCmd, Tcl_Interp *target, +EXTERN int Tcl_CreateAlias(Tcl_Interp *childInterp, + CONST char *childCmd, Tcl_Interp *target, CONST char *targetCmd, int argc, CONST84 char *CONST *argv); #endif #ifndef Tcl_CreateAliasObj_TCL_DECLARED #define Tcl_CreateAliasObj_TCL_DECLARED /* 87 */ -EXTERN int Tcl_CreateAliasObj(Tcl_Interp *slave, - CONST char *slaveCmd, Tcl_Interp *target, +EXTERN int Tcl_CreateAliasObj(Tcl_Interp *childInterp, + CONST char *childCmd, Tcl_Interp *target, CONST char *targetCmd, int objc, Tcl_Obj *CONST objv[]); #endif @@ -621,8 +621,8 @@ EXTERN Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, #ifndef Tcl_CreateSlave_TCL_DECLARED #define Tcl_CreateSlave_TCL_DECLARED /* 97 */ -EXTERN Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp, - CONST char *slaveName, int isSafe); +EXTERN Tcl_Interp * Tcl_CreateSlave(Tcl_Interp *interp, CONST char *name, + int isSafe); #endif #ifndef Tcl_CreateTimerHandler_TCL_DECLARED #define Tcl_CreateTimerHandler_TCL_DECLARED @@ -999,8 +999,8 @@ EXTERN CONST84_RETURN char * Tcl_GetHostName(void); #ifndef Tcl_GetInterpPath_TCL_DECLARED #define Tcl_GetInterpPath_TCL_DECLARED /* 163 */ -EXTERN int Tcl_GetInterpPath(Tcl_Interp *askInterp, - Tcl_Interp *slaveInterp); +EXTERN int Tcl_GetInterpPath(Tcl_Interp *interp, + Tcl_Interp *childInterp); #endif #ifndef Tcl_GetMaster_TCL_DECLARED #define Tcl_GetMaster_TCL_DECLARED @@ -1208,7 +1208,7 @@ EXTERN Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, /* 199 */ EXTERN Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port, CONST char *address, CONST char *myaddr, - int myport, int async); + int myport, int flags); #endif #ifndef Tcl_OpenTcpServer_TCL_DECLARED #define Tcl_OpenTcpServer_TCL_DECLARED @@ -3514,9 +3514,10 @@ EXTERN void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, /* Slot 679 is reserved */ /* Slot 680 is reserved */ /* Slot 681 is reserved */ +/* Slot 682 is reserved */ #ifndef TclUnusedStubEntry_TCL_DECLARED #define TclUnusedStubEntry_TCL_DECLARED -/* 682 */ +/* 683 */ EXTERN void TclUnusedStubEntry(void); #endif @@ -3577,8 +3578,8 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_DbNewStringObj) (CONST char *bytes, int length, CONST char *file, int line); /* 28 */ Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */ void (*tclFreeObj) (Tcl_Obj *objPtr); /* 30 */ - int (*tcl_GetBoolean) (Tcl_Interp *interp, CONST char *src, int *boolPtr); /* 31 */ - int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *boolPtr); /* 32 */ + int (*tcl_GetBoolean) (Tcl_Interp *interp, CONST char *src, int *intPtr); /* 31 */ + int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 32 */ unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 33 */ int (*tcl_GetDouble) (Tcl_Interp *interp, CONST char *src, double *doublePtr); /* 34 */ int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */ @@ -3595,7 +3596,7 @@ typedef struct TclStubs { int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj **objPtrPtr); /* 46 */ int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */ int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *CONST objv[]); /* 48 */ - Tcl_Obj * (*tcl_NewBooleanObj) (int boolValue); /* 49 */ + Tcl_Obj * (*tcl_NewBooleanObj) (int intValue); /* 49 */ Tcl_Obj * (*tcl_NewByteArrayObj) (CONST unsigned char *bytes, int length); /* 50 */ Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */ Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */ @@ -3603,9 +3604,9 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */ Tcl_Obj * (*tcl_NewObj) (void); /* 55 */ Tcl_Obj * (*tcl_NewStringObj) (CONST char *bytes, int length); /* 56 */ - void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int boolValue); /* 57 */ - unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, int length); /* 58 */ - void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, CONST unsigned char *bytes, int length); /* 59 */ + void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int intValue); /* 57 */ + unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, int numBytes); /* 58 */ + void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, CONST unsigned char *bytes, int numBytes); /* 59 */ void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */ void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */ void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *CONST objv[]); /* 62 */ @@ -3632,8 +3633,8 @@ typedef struct TclStubs { char * (*tcl_Concat) (int argc, CONST84 char *CONST *argv); /* 83 */ int (*tcl_ConvertElement) (CONST char *src, char *dst, int flags); /* 84 */ int (*tcl_ConvertCountedElement) (CONST char *src, int length, char *dst, int flags); /* 85 */ - int (*tcl_CreateAlias) (Tcl_Interp *slave, CONST char *slaveCmd, Tcl_Interp *target, CONST char *targetCmd, int argc, CONST84 char *CONST *argv); /* 86 */ - int (*tcl_CreateAliasObj) (Tcl_Interp *slave, CONST char *slaveCmd, Tcl_Interp *target, CONST char *targetCmd, int objc, Tcl_Obj *CONST objv[]); /* 87 */ + int (*tcl_CreateAlias) (Tcl_Interp *childInterp, CONST char *childCmd, Tcl_Interp *target, CONST char *targetCmd, int argc, CONST84 char *CONST *argv); /* 86 */ + int (*tcl_CreateAliasObj) (Tcl_Interp *childInterp, CONST char *childCmd, Tcl_Interp *target, CONST char *targetCmd, int objc, Tcl_Obj *CONST objv[]); /* 87 */ Tcl_Channel (*tcl_CreateChannel) (Tcl_ChannelType *typePtr, CONST char *chanName, ClientData instanceData, int mask); /* 88 */ void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, ClientData clientData); /* 89 */ void (*tcl_CreateCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData); /* 90 */ @@ -3643,7 +3644,7 @@ typedef struct TclStubs { Tcl_Interp * (*tcl_CreateInterp) (void); /* 94 */ void (*tcl_CreateMathFunc) (Tcl_Interp *interp, CONST char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */ Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, CONST char *cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */ - Tcl_Interp * (*tcl_CreateSlave) (Tcl_Interp *interp, CONST char *slaveName, int isSafe); /* 97 */ + Tcl_Interp * (*tcl_CreateSlave) (Tcl_Interp *interp, CONST char *name, int isSafe); /* 97 */ Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, ClientData clientData); /* 98 */ Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, ClientData clientData); /* 99 */ void (*tcl_DeleteAssocData) (Tcl_Interp *interp, CONST char *name); /* 100 */ @@ -3709,7 +3710,7 @@ typedef struct TclStubs { CONST84_RETURN char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */ int (*tcl_GetErrno) (void); /* 161 */ CONST84_RETURN char * (*tcl_GetHostName) (void); /* 162 */ - int (*tcl_GetInterpPath) (Tcl_Interp *askInterp, Tcl_Interp *slaveInterp); /* 163 */ + int (*tcl_GetInterpPath) (Tcl_Interp *interp, Tcl_Interp *childInterp); /* 163 */ Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */ CONST char * (*tcl_GetNameOfExecutable) (void); /* 165 */ Tcl_Obj * (*tcl_GetObjResult) (Tcl_Interp *interp); /* 166 */ @@ -3753,7 +3754,7 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_ObjSetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 196 */ Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, int argc, CONST84 char **argv, int flags); /* 197 */ Tcl_Channel (*tcl_OpenFileChannel) (Tcl_Interp *interp, CONST char *fileName, CONST char *modeString, int permissions); /* 198 */ - Tcl_Channel (*tcl_OpenTcpClient) (Tcl_Interp *interp, int port, CONST char *address, CONST char *myaddr, int myport, int async); /* 199 */ + Tcl_Channel (*tcl_OpenTcpClient) (Tcl_Interp *interp, int port, CONST char *address, CONST char *myaddr, int myport, int flags); /* 199 */ Tcl_Channel (*tcl_OpenTcpServer) (Tcl_Interp *interp, int port, CONST char *host, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 200 */ void (*tcl_Preserve) (ClientData data); /* 201 */ void (*tcl_PrintDouble) (Tcl_Interp *interp, double value, char *dst); /* 202 */ @@ -4236,7 +4237,8 @@ typedef struct TclStubs { VOID *reserved679; VOID *reserved680; VOID *reserved681; - void (*tclUnusedStubEntry) (void); /* 682 */ + VOID *reserved682; + void (*tclUnusedStubEntry) (void); /* 683 */ } TclStubs; extern TclStubs *tclStubsPtr; @@ -6691,9 +6693,10 @@ extern TclStubs *tclStubsPtr; /* Slot 679 is reserved */ /* Slot 680 is reserved */ /* Slot 681 is reserved */ +/* Slot 682 is reserved */ #ifndef TclUnusedStubEntry #define TclUnusedStubEntry \ - (tclStubsPtr->tclUnusedStubEntry) /* 682 */ + (tclStubsPtr->tclUnusedStubEntry) /* 683 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index 16e8af0..e8dde22 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -57,6 +57,12 @@ EXTERN TCHAR * Tcl_WinUtfToTChar(CONST char *str, int len, EXTERN char * Tcl_WinTCharToUtf(CONST TCHAR *str, int len, Tcl_DString *dsPtr); #endif +/* Slot 2 is reserved */ +#ifndef TclUnusedStubEntry_TCL_DECLARED +#define TclUnusedStubEntry_TCL_DECLARED +/* 3 */ +EXTERN void TclUnusedStubEntry(void); +#endif #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ #ifndef Tcl_MacOSXOpenBundleResources_TCL_DECLARED @@ -89,6 +95,8 @@ typedef struct TclPlatStubs { #if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ TCHAR * (*tcl_WinUtfToTChar) (CONST char *str, int len, Tcl_DString *dsPtr); /* 0 */ char * (*tcl_WinTCharToUtf) (CONST TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */ + VOID *reserved2; + void (*tclUnusedStubEntry) (void); /* 3 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, CONST char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath); /* 0 */ @@ -118,6 +126,11 @@ extern TclPlatStubs *tclPlatStubsPtr; #define Tcl_WinTCharToUtf \ (tclPlatStubsPtr->tcl_WinTCharToUtf) /* 1 */ #endif +/* Slot 2 is reserved */ +#ifndef TclUnusedStubEntry +#define TclUnusedStubEntry \ + (tclPlatStubsPtr->tclUnusedStubEntry) /* 3 */ +#endif #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ #ifndef Tcl_MacOSXOpenBundleResources diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index f1cf6a2..9502ba2 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -672,6 +672,8 @@ TclPlatStubs tclPlatStubs = { #if defined(__WIN32__) || defined(__CYGWIN__) /* WIN */ Tcl_WinUtfToTChar, /* 0 */ Tcl_WinTCharToUtf, /* 1 */ + NULL, /* 2 */ + TclUnusedStubEntry, /* 3 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ Tcl_MacOSXOpenBundleResources, /* 0 */ @@ -1481,7 +1483,8 @@ TclStubs tclStubs = { NULL, /* 679 */ NULL, /* 680 */ NULL, /* 681 */ - TclUnusedStubEntry, /* 682 */ + NULL, /* 682 */ + TclUnusedStubEntry, /* 683 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 1e2cce6389bfdb6ed696f3fdd427fc971485c967 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 30 Oct 2022 12:52:39 +0000 Subject: Update to tzdata 2022f --- library/tzdata/America/Bahia_Banderas | 154 ------------------- library/tzdata/America/Chihuahua | 156 +------------------ library/tzdata/America/Mazatlan | 154 ------------------- library/tzdata/America/Merida | 154 ------------------- library/tzdata/America/Mexico_City | 154 ------------------- library/tzdata/America/Monterrey | 154 ------------------- library/tzdata/America/Nipigon | 265 +-------------------------------- library/tzdata/America/Ojinaga | 156 +------------------ library/tzdata/America/Rainy_River | 265 +-------------------------------- library/tzdata/America/Thunder_Bay | 273 +--------------------------------- library/tzdata/Pacific/Fiji | 155 ------------------- 11 files changed, 11 insertions(+), 2029 deletions(-) diff --git a/library/tzdata/America/Bahia_Banderas b/library/tzdata/America/Bahia_Banderas index f06141e..cdcc4b3 100644 --- a/library/tzdata/America/Bahia_Banderas +++ b/library/tzdata/America/Bahia_Banderas @@ -65,158 +65,4 @@ set TZData(:America/Bahia_Banderas) { {1635663600 -21600 0 CST} {1648972800 -18000 1 CDT} {1667113200 -21600 0 CST} - {1680422400 -18000 1 CDT} - {1698562800 -21600 0 CST} - {1712476800 -18000 1 CDT} - {1730012400 -21600 0 CST} - {1743926400 -18000 1 CDT} - {1761462000 -21600 0 CST} - {1775376000 -18000 1 CDT} - {1792911600 -21600 0 CST} - {1806825600 -18000 1 CDT} - {1824966000 -21600 0 CST} - {1838275200 -18000 1 CDT} - {1856415600 -21600 0 CST} - {1869724800 -18000 1 CDT} - {1887865200 -21600 0 CST} - {1901779200 -18000 1 CDT} - {1919314800 -21600 0 CST} - {1933228800 -18000 1 CDT} - {1950764400 -21600 0 CST} - {1964678400 -18000 1 CDT} - {1982818800 -21600 0 CST} - {1996128000 -18000 1 CDT} - {2014268400 -21600 0 CST} - {2027577600 -18000 1 CDT} - {2045718000 -21600 0 CST} - {2059027200 -18000 1 CDT} - {2077167600 -21600 0 CST} - {2091081600 -18000 1 CDT} - {2108617200 -21600 0 CST} - {2122531200 -18000 1 CDT} - {2140066800 -21600 0 CST} - {2153980800 -18000 1 CDT} - {2172121200 -21600 0 CST} - {2185430400 -18000 1 CDT} - {2203570800 -21600 0 CST} - {2216880000 -18000 1 CDT} - {2235020400 -21600 0 CST} - {2248934400 -18000 1 CDT} - {2266470000 -21600 0 CST} - {2280384000 -18000 1 CDT} - {2297919600 -21600 0 CST} - {2311833600 -18000 1 CDT} - {2329369200 -21600 0 CST} - {2343283200 -18000 1 CDT} - {2361423600 -21600 0 CST} - {2374732800 -18000 1 CDT} - {2392873200 -21600 0 CST} - {2406182400 -18000 1 CDT} - {2424322800 -21600 0 CST} - {2438236800 -18000 1 CDT} - {2455772400 -21600 0 CST} - {2469686400 -18000 1 CDT} - {2487222000 -21600 0 CST} - {2501136000 -18000 1 CDT} - {2519276400 -21600 0 CST} - {2532585600 -18000 1 CDT} - {2550726000 -21600 0 CST} - {2564035200 -18000 1 CDT} - {2582175600 -21600 0 CST} - {2596089600 -18000 1 CDT} - {2613625200 -21600 0 CST} - {2627539200 -18000 1 CDT} - {2645074800 -21600 0 CST} - {2658988800 -18000 1 CDT} - {2676524400 -21600 0 CST} - {2690438400 -18000 1 CDT} - {2708578800 -21600 0 CST} - {2721888000 -18000 1 CDT} - {2740028400 -21600 0 CST} - {2753337600 -18000 1 CDT} - {2771478000 -21600 0 CST} - {2785392000 -18000 1 CDT} - {2802927600 -21600 0 CST} - {2816841600 -18000 1 CDT} - {2834377200 -21600 0 CST} - {2848291200 -18000 1 CDT} - {2866431600 -21600 0 CST} - {2879740800 -18000 1 CDT} - {2897881200 -21600 0 CST} - {2911190400 -18000 1 CDT} - {2929330800 -21600 0 CST} - {2942640000 -18000 1 CDT} - {2960780400 -21600 0 CST} - {2974694400 -18000 1 CDT} - {2992230000 -21600 0 CST} - {3006144000 -18000 1 CDT} - {3023679600 -21600 0 CST} - {3037593600 -18000 1 CDT} - {3055734000 -21600 0 CST} - {3069043200 -18000 1 CDT} - {3087183600 -21600 0 CST} - {3100492800 -18000 1 CDT} - {3118633200 -21600 0 CST} - {3132547200 -18000 1 CDT} - {3150082800 -21600 0 CST} - {3163996800 -18000 1 CDT} - {3181532400 -21600 0 CST} - {3195446400 -18000 1 CDT} - {3212982000 -21600 0 CST} - {3226896000 -18000 1 CDT} - {3245036400 -21600 0 CST} - {3258345600 -18000 1 CDT} - {3276486000 -21600 0 CST} - {3289795200 -18000 1 CDT} - {3307935600 -21600 0 CST} - {3321849600 -18000 1 CDT} - {3339385200 -21600 0 CST} - {3353299200 -18000 1 CDT} - {3370834800 -21600 0 CST} - {3384748800 -18000 1 CDT} - {3402889200 -21600 0 CST} - {3416198400 -18000 1 CDT} - {3434338800 -21600 0 CST} - {3447648000 -18000 1 CDT} - {3465788400 -21600 0 CST} - {3479702400 -18000 1 CDT} - {3497238000 -21600 0 CST} - {3511152000 -18000 1 CDT} - {3528687600 -21600 0 CST} - {3542601600 -18000 1 CDT} - {3560137200 -21600 0 CST} - {3574051200 -18000 1 CDT} - {3592191600 -21600 0 CST} - {3605500800 -18000 1 CDT} - {3623641200 -21600 0 CST} - {3636950400 -18000 1 CDT} - {3655090800 -21600 0 CST} - {3669004800 -18000 1 CDT} - {3686540400 -21600 0 CST} - {3700454400 -18000 1 CDT} - {3717990000 -21600 0 CST} - {3731904000 -18000 1 CDT} - {3750044400 -21600 0 CST} - {3763353600 -18000 1 CDT} - {3781494000 -21600 0 CST} - {3794803200 -18000 1 CDT} - {3812943600 -21600 0 CST} - {3826252800 -18000 1 CDT} - {3844393200 -21600 0 CST} - {3858307200 -18000 1 CDT} - {3875842800 -21600 0 CST} - {3889756800 -18000 1 CDT} - {3907292400 -21600 0 CST} - {3921206400 -18000 1 CDT} - {3939346800 -21600 0 CST} - {3952656000 -18000 1 CDT} - {3970796400 -21600 0 CST} - {3984105600 -18000 1 CDT} - {4002246000 -21600 0 CST} - {4016160000 -18000 1 CDT} - {4033695600 -21600 0 CST} - {4047609600 -18000 1 CDT} - {4065145200 -21600 0 CST} - {4079059200 -18000 1 CDT} - {4096594800 -21600 0 CST} } diff --git a/library/tzdata/America/Chihuahua b/library/tzdata/America/Chihuahua index fc38542..50cb9de 100644 --- a/library/tzdata/America/Chihuahua +++ b/library/tzdata/America/Chihuahua @@ -63,159 +63,5 @@ set TZData(:America/Chihuahua) { {1617526800 -21600 1 MDT} {1635667200 -25200 0 MST} {1648976400 -21600 1 MDT} - {1667116800 -25200 0 MST} - {1680426000 -21600 1 MDT} - {1698566400 -25200 0 MST} - {1712480400 -21600 1 MDT} - {1730016000 -25200 0 MST} - {1743930000 -21600 1 MDT} - {1761465600 -25200 0 MST} - {1775379600 -21600 1 MDT} - {1792915200 -25200 0 MST} - {1806829200 -21600 1 MDT} - {1824969600 -25200 0 MST} - {1838278800 -21600 1 MDT} - {1856419200 -25200 0 MST} - {1869728400 -21600 1 MDT} - {1887868800 -25200 0 MST} - {1901782800 -21600 1 MDT} - {1919318400 -25200 0 MST} - {1933232400 -21600 1 MDT} - {1950768000 -25200 0 MST} - {1964682000 -21600 1 MDT} - {1982822400 -25200 0 MST} - {1996131600 -21600 1 MDT} - {2014272000 -25200 0 MST} - {2027581200 -21600 1 MDT} - {2045721600 -25200 0 MST} - {2059030800 -21600 1 MDT} - {2077171200 -25200 0 MST} - {2091085200 -21600 1 MDT} - {2108620800 -25200 0 MST} - {2122534800 -21600 1 MDT} - {2140070400 -25200 0 MST} - {2153984400 -21600 1 MDT} - {2172124800 -25200 0 MST} - {2185434000 -21600 1 MDT} - {2203574400 -25200 0 MST} - {2216883600 -21600 1 MDT} - {2235024000 -25200 0 MST} - {2248938000 -21600 1 MDT} - {2266473600 -25200 0 MST} - {2280387600 -21600 1 MDT} - {2297923200 -25200 0 MST} - {2311837200 -21600 1 MDT} - {2329372800 -25200 0 MST} - {2343286800 -21600 1 MDT} - {2361427200 -25200 0 MST} - {2374736400 -21600 1 MDT} - {2392876800 -25200 0 MST} - {2406186000 -21600 1 MDT} - {2424326400 -25200 0 MST} - {2438240400 -21600 1 MDT} - {2455776000 -25200 0 MST} - {2469690000 -21600 1 MDT} - {2487225600 -25200 0 MST} - {2501139600 -21600 1 MDT} - {2519280000 -25200 0 MST} - {2532589200 -21600 1 MDT} - {2550729600 -25200 0 MST} - {2564038800 -21600 1 MDT} - {2582179200 -25200 0 MST} - {2596093200 -21600 1 MDT} - {2613628800 -25200 0 MST} - {2627542800 -21600 1 MDT} - {2645078400 -25200 0 MST} - {2658992400 -21600 1 MDT} - {2676528000 -25200 0 MST} - {2690442000 -21600 1 MDT} - {2708582400 -25200 0 MST} - {2721891600 -21600 1 MDT} - {2740032000 -25200 0 MST} - {2753341200 -21600 1 MDT} - {2771481600 -25200 0 MST} - {2785395600 -21600 1 MDT} - {2802931200 -25200 0 MST} - {2816845200 -21600 1 MDT} - {2834380800 -25200 0 MST} - {2848294800 -21600 1 MDT} - {2866435200 -25200 0 MST} - {2879744400 -21600 1 MDT} - {2897884800 -25200 0 MST} - {2911194000 -21600 1 MDT} - {2929334400 -25200 0 MST} - {2942643600 -21600 1 MDT} - {2960784000 -25200 0 MST} - {2974698000 -21600 1 MDT} - {2992233600 -25200 0 MST} - {3006147600 -21600 1 MDT} - {3023683200 -25200 0 MST} - {3037597200 -21600 1 MDT} - {3055737600 -25200 0 MST} - {3069046800 -21600 1 MDT} - {3087187200 -25200 0 MST} - {3100496400 -21600 1 MDT} - {3118636800 -25200 0 MST} - {3132550800 -21600 1 MDT} - {3150086400 -25200 0 MST} - {3164000400 -21600 1 MDT} - {3181536000 -25200 0 MST} - {3195450000 -21600 1 MDT} - {3212985600 -25200 0 MST} - {3226899600 -21600 1 MDT} - {3245040000 -25200 0 MST} - {3258349200 -21600 1 MDT} - {3276489600 -25200 0 MST} - {3289798800 -21600 1 MDT} - {3307939200 -25200 0 MST} - {3321853200 -21600 1 MDT} - {3339388800 -25200 0 MST} - {3353302800 -21600 1 MDT} - {3370838400 -25200 0 MST} - {3384752400 -21600 1 MDT} - {3402892800 -25200 0 MST} - {3416202000 -21600 1 MDT} - {3434342400 -25200 0 MST} - {3447651600 -21600 1 MDT} - {3465792000 -25200 0 MST} - {3479706000 -21600 1 MDT} - {3497241600 -25200 0 MST} - {3511155600 -21600 1 MDT} - {3528691200 -25200 0 MST} - {3542605200 -21600 1 MDT} - {3560140800 -25200 0 MST} - {3574054800 -21600 1 MDT} - {3592195200 -25200 0 MST} - {3605504400 -21600 1 MDT} - {3623644800 -25200 0 MST} - {3636954000 -21600 1 MDT} - {3655094400 -25200 0 MST} - {3669008400 -21600 1 MDT} - {3686544000 -25200 0 MST} - {3700458000 -21600 1 MDT} - {3717993600 -25200 0 MST} - {3731907600 -21600 1 MDT} - {3750048000 -25200 0 MST} - {3763357200 -21600 1 MDT} - {3781497600 -25200 0 MST} - {3794806800 -21600 1 MDT} - {3812947200 -25200 0 MST} - {3826256400 -21600 1 MDT} - {3844396800 -25200 0 MST} - {3858310800 -21600 1 MDT} - {3875846400 -25200 0 MST} - {3889760400 -21600 1 MDT} - {3907296000 -25200 0 MST} - {3921210000 -21600 1 MDT} - {3939350400 -25200 0 MST} - {3952659600 -21600 1 MDT} - {3970800000 -25200 0 MST} - {3984109200 -21600 1 MDT} - {4002249600 -25200 0 MST} - {4016163600 -21600 1 MDT} - {4033699200 -25200 0 MST} - {4047613200 -21600 1 MDT} - {4065148800 -25200 0 MST} - {4079062800 -21600 1 MDT} - {4096598400 -25200 0 MST} + {1667120400 -21600 0 CST} } diff --git a/library/tzdata/America/Mazatlan b/library/tzdata/America/Mazatlan index 5547d3f..d9da09f 100644 --- a/library/tzdata/America/Mazatlan +++ b/library/tzdata/America/Mazatlan @@ -65,158 +65,4 @@ set TZData(:America/Mazatlan) { {1635667200 -25200 0 MST} {1648976400 -21600 1 MDT} {1667116800 -25200 0 MST} - {1680426000 -21600 1 MDT} - {1698566400 -25200 0 MST} - {1712480400 -21600 1 MDT} - {1730016000 -25200 0 MST} - {1743930000 -21600 1 MDT} - {1761465600 -25200 0 MST} - {1775379600 -21600 1 MDT} - {1792915200 -25200 0 MST} - {1806829200 -21600 1 MDT} - {1824969600 -25200 0 MST} - {1838278800 -21600 1 MDT} - {1856419200 -25200 0 MST} - {1869728400 -21600 1 MDT} - {1887868800 -25200 0 MST} - {1901782800 -21600 1 MDT} - {1919318400 -25200 0 MST} - {1933232400 -21600 1 MDT} - {1950768000 -25200 0 MST} - {1964682000 -21600 1 MDT} - {1982822400 -25200 0 MST} - {1996131600 -21600 1 MDT} - {2014272000 -25200 0 MST} - {2027581200 -21600 1 MDT} - {2045721600 -25200 0 MST} - {2059030800 -21600 1 MDT} - {2077171200 -25200 0 MST} - {2091085200 -21600 1 MDT} - {2108620800 -25200 0 MST} - {2122534800 -21600 1 MDT} - {2140070400 -25200 0 MST} - {2153984400 -21600 1 MDT} - {2172124800 -25200 0 MST} - {2185434000 -21600 1 MDT} - {2203574400 -25200 0 MST} - {2216883600 -21600 1 MDT} - {2235024000 -25200 0 MST} - {2248938000 -21600 1 MDT} - {2266473600 -25200 0 MST} - {2280387600 -21600 1 MDT} - {2297923200 -25200 0 MST} - {2311837200 -21600 1 MDT} - {2329372800 -25200 0 MST} - {2343286800 -21600 1 MDT} - {2361427200 -25200 0 MST} - {2374736400 -21600 1 MDT} - {2392876800 -25200 0 MST} - {2406186000 -21600 1 MDT} - {2424326400 -25200 0 MST} - {2438240400 -21600 1 MDT} - {2455776000 -25200 0 MST} - {2469690000 -21600 1 MDT} - {2487225600 -25200 0 MST} - {2501139600 -21600 1 MDT} - {2519280000 -25200 0 MST} - {2532589200 -21600 1 MDT} - {2550729600 -25200 0 MST} - {2564038800 -21600 1 MDT} - {2582179200 -25200 0 MST} - {2596093200 -21600 1 MDT} - {2613628800 -25200 0 MST} - {2627542800 -21600 1 MDT} - {2645078400 -25200 0 MST} - {2658992400 -21600 1 MDT} - {2676528000 -25200 0 MST} - {2690442000 -21600 1 MDT} - {2708582400 -25200 0 MST} - {2721891600 -21600 1 MDT} - {2740032000 -25200 0 MST} - {2753341200 -21600 1 MDT} - {2771481600 -25200 0 MST} - {2785395600 -21600 1 MDT} - {2802931200 -25200 0 MST} - {2816845200 -21600 1 MDT} - {2834380800 -25200 0 MST} - {2848294800 -21600 1 MDT} - {2866435200 -25200 0 MST} - {2879744400 -21600 1 MDT} - {2897884800 -25200 0 MST} - {2911194000 -21600 1 MDT} - {2929334400 -25200 0 MST} - {2942643600 -21600 1 MDT} - {2960784000 -25200 0 MST} - {2974698000 -21600 1 MDT} - {2992233600 -25200 0 MST} - {3006147600 -21600 1 MDT} - {3023683200 -25200 0 MST} - {3037597200 -21600 1 MDT} - {3055737600 -25200 0 MST} - {3069046800 -21600 1 MDT} - {3087187200 -25200 0 MST} - {3100496400 -21600 1 MDT} - {3118636800 -25200 0 MST} - {3132550800 -21600 1 MDT} - {3150086400 -25200 0 MST} - {3164000400 -21600 1 MDT} - {3181536000 -25200 0 MST} - {3195450000 -21600 1 MDT} - {3212985600 -25200 0 MST} - {3226899600 -21600 1 MDT} - {3245040000 -25200 0 MST} - {3258349200 -21600 1 MDT} - {3276489600 -25200 0 MST} - {3289798800 -21600 1 MDT} - {3307939200 -25200 0 MST} - {3321853200 -21600 1 MDT} - {3339388800 -25200 0 MST} - {3353302800 -21600 1 MDT} - {3370838400 -25200 0 MST} - {3384752400 -21600 1 MDT} - {3402892800 -25200 0 MST} - {3416202000 -21600 1 MDT} - {3434342400 -25200 0 MST} - {3447651600 -21600 1 MDT} - {3465792000 -25200 0 MST} - {3479706000 -21600 1 MDT} - {3497241600 -25200 0 MST} - {3511155600 -21600 1 MDT} - {3528691200 -25200 0 MST} - {3542605200 -21600 1 MDT} - {3560140800 -25200 0 MST} - {3574054800 -21600 1 MDT} - {3592195200 -25200 0 MST} - {3605504400 -21600 1 MDT} - {3623644800 -25200 0 MST} - {3636954000 -21600 1 MDT} - {3655094400 -25200 0 MST} - {3669008400 -21600 1 MDT} - {3686544000 -25200 0 MST} - {3700458000 -21600 1 MDT} - {3717993600 -25200 0 MST} - {3731907600 -21600 1 MDT} - {3750048000 -25200 0 MST} - {3763357200 -21600 1 MDT} - {3781497600 -25200 0 MST} - {3794806800 -21600 1 MDT} - {3812947200 -25200 0 MST} - {3826256400 -21600 1 MDT} - {3844396800 -25200 0 MST} - {3858310800 -21600 1 MDT} - {3875846400 -25200 0 MST} - {3889760400 -21600 1 MDT} - {3907296000 -25200 0 MST} - {3921210000 -21600 1 MDT} - {3939350400 -25200 0 MST} - {3952659600 -21600 1 MDT} - {3970800000 -25200 0 MST} - {3984109200 -21600 1 MDT} - {4002249600 -25200 0 MST} - {4016163600 -21600 1 MDT} - {4033699200 -25200 0 MST} - {4047613200 -21600 1 MDT} - {4065148800 -25200 0 MST} - {4079062800 -21600 1 MDT} - {4096598400 -25200 0 MST} } diff --git a/library/tzdata/America/Merida b/library/tzdata/America/Merida index ebf5927..d17431d 100644 --- a/library/tzdata/America/Merida +++ b/library/tzdata/America/Merida @@ -59,158 +59,4 @@ set TZData(:America/Merida) { {1635663600 -21600 0 CST} {1648972800 -18000 1 CDT} {1667113200 -21600 0 CST} - {1680422400 -18000 1 CDT} - {1698562800 -21600 0 CST} - {1712476800 -18000 1 CDT} - {1730012400 -21600 0 CST} - {1743926400 -18000 1 CDT} - {1761462000 -21600 0 CST} - {1775376000 -18000 1 CDT} - {1792911600 -21600 0 CST} - {1806825600 -18000 1 CDT} - {1824966000 -21600 0 CST} - {1838275200 -18000 1 CDT} - {1856415600 -21600 0 CST} - {1869724800 -18000 1 CDT} - {1887865200 -21600 0 CST} - {1901779200 -18000 1 CDT} - {1919314800 -21600 0 CST} - {1933228800 -18000 1 CDT} - {1950764400 -21600 0 CST} - {1964678400 -18000 1 CDT} - {1982818800 -21600 0 CST} - {1996128000 -18000 1 CDT} - {2014268400 -21600 0 CST} - {2027577600 -18000 1 CDT} - {2045718000 -21600 0 CST} - {2059027200 -18000 1 CDT} - {2077167600 -21600 0 CST} - {2091081600 -18000 1 CDT} - {2108617200 -21600 0 CST} - {2122531200 -18000 1 CDT} - {2140066800 -21600 0 CST} - {2153980800 -18000 1 CDT} - {2172121200 -21600 0 CST} - {2185430400 -18000 1 CDT} - {2203570800 -21600 0 CST} - {2216880000 -18000 1 CDT} - {2235020400 -21600 0 CST} - {2248934400 -18000 1 CDT} - {2266470000 -21600 0 CST} - {2280384000 -18000 1 CDT} - {2297919600 -21600 0 CST} - {2311833600 -18000 1 CDT} - {2329369200 -21600 0 CST} - {2343283200 -18000 1 CDT} - {2361423600 -21600 0 CST} - {2374732800 -18000 1 CDT} - {2392873200 -21600 0 CST} - {2406182400 -18000 1 CDT} - {2424322800 -21600 0 CST} - {2438236800 -18000 1 CDT} - {2455772400 -21600 0 CST} - {2469686400 -18000 1 CDT} - {2487222000 -21600 0 CST} - {2501136000 -18000 1 CDT} - {2519276400 -21600 0 CST} - {2532585600 -18000 1 CDT} - {2550726000 -21600 0 CST} - {2564035200 -18000 1 CDT} - {2582175600 -21600 0 CST} - {2596089600 -18000 1 CDT} - {2613625200 -21600 0 CST} - {2627539200 -18000 1 CDT} - {2645074800 -21600 0 CST} - {2658988800 -18000 1 CDT} - {2676524400 -21600 0 CST} - {2690438400 -18000 1 CDT} - {2708578800 -21600 0 CST} - {2721888000 -18000 1 CDT} - {2740028400 -21600 0 CST} - {2753337600 -18000 1 CDT} - {2771478000 -21600 0 CST} - {2785392000 -18000 1 CDT} - {2802927600 -21600 0 CST} - {2816841600 -18000 1 CDT} - {2834377200 -21600 0 CST} - {2848291200 -18000 1 CDT} - {2866431600 -21600 0 CST} - {2879740800 -18000 1 CDT} - {2897881200 -21600 0 CST} - {2911190400 -18000 1 CDT} - {2929330800 -21600 0 CST} - {2942640000 -18000 1 CDT} - {2960780400 -21600 0 CST} - {2974694400 -18000 1 CDT} - {2992230000 -21600 0 CST} - {3006144000 -18000 1 CDT} - {3023679600 -21600 0 CST} - {3037593600 -18000 1 CDT} - {3055734000 -21600 0 CST} - {3069043200 -18000 1 CDT} - {3087183600 -21600 0 CST} - {3100492800 -18000 1 CDT} - {3118633200 -21600 0 CST} - {3132547200 -18000 1 CDT} - {3150082800 -21600 0 CST} - {3163996800 -18000 1 CDT} - {3181532400 -21600 0 CST} - {3195446400 -18000 1 CDT} - {3212982000 -21600 0 CST} - {3226896000 -18000 1 CDT} - {3245036400 -21600 0 CST} - {3258345600 -18000 1 CDT} - {3276486000 -21600 0 CST} - {3289795200 -18000 1 CDT} - {3307935600 -21600 0 CST} - {3321849600 -18000 1 CDT} - {3339385200 -21600 0 CST} - {3353299200 -18000 1 CDT} - {3370834800 -21600 0 CST} - {3384748800 -18000 1 CDT} - {3402889200 -21600 0 CST} - {3416198400 -18000 1 CDT} - {3434338800 -21600 0 CST} - {3447648000 -18000 1 CDT} - {3465788400 -21600 0 CST} - {3479702400 -18000 1 CDT} - {3497238000 -21600 0 CST} - {3511152000 -18000 1 CDT} - {3528687600 -21600 0 CST} - {3542601600 -18000 1 CDT} - {3560137200 -21600 0 CST} - {3574051200 -18000 1 CDT} - {3592191600 -21600 0 CST} - {3605500800 -18000 1 CDT} - {3623641200 -21600 0 CST} - {3636950400 -18000 1 CDT} - {3655090800 -21600 0 CST} - {3669004800 -18000 1 CDT} - {3686540400 -21600 0 CST} - {3700454400 -18000 1 CDT} - {3717990000 -21600 0 CST} - {3731904000 -18000 1 CDT} - {3750044400 -21600 0 CST} - {3763353600 -18000 1 CDT} - {3781494000 -21600 0 CST} - {3794803200 -18000 1 CDT} - {3812943600 -21600 0 CST} - {3826252800 -18000 1 CDT} - {3844393200 -21600 0 CST} - {3858307200 -18000 1 CDT} - {3875842800 -21600 0 CST} - {3889756800 -18000 1 CDT} - {3907292400 -21600 0 CST} - {3921206400 -18000 1 CDT} - {3939346800 -21600 0 CST} - {3952656000 -18000 1 CDT} - {3970796400 -21600 0 CST} - {3984105600 -18000 1 CDT} - {4002246000 -21600 0 CST} - {4016160000 -18000 1 CDT} - {4033695600 -21600 0 CST} - {4047609600 -18000 1 CDT} - {4065145200 -21600 0 CST} - {4079059200 -18000 1 CDT} - {4096594800 -21600 0 CST} } diff --git a/library/tzdata/America/Mexico_City b/library/tzdata/America/Mexico_City index 66e273f..2a0a5a8 100644 --- a/library/tzdata/America/Mexico_City +++ b/library/tzdata/America/Mexico_City @@ -71,158 +71,4 @@ set TZData(:America/Mexico_City) { {1635663600 -21600 0 CST} {1648972800 -18000 1 CDT} {1667113200 -21600 0 CST} - {1680422400 -18000 1 CDT} - {1698562800 -21600 0 CST} - {1712476800 -18000 1 CDT} - {1730012400 -21600 0 CST} - {1743926400 -18000 1 CDT} - {1761462000 -21600 0 CST} - {1775376000 -18000 1 CDT} - {1792911600 -21600 0 CST} - {1806825600 -18000 1 CDT} - {1824966000 -21600 0 CST} - {1838275200 -18000 1 CDT} - {1856415600 -21600 0 CST} - {1869724800 -18000 1 CDT} - {1887865200 -21600 0 CST} - {1901779200 -18000 1 CDT} - {1919314800 -21600 0 CST} - {1933228800 -18000 1 CDT} - {1950764400 -21600 0 CST} - {1964678400 -18000 1 CDT} - {1982818800 -21600 0 CST} - {1996128000 -18000 1 CDT} - {2014268400 -21600 0 CST} - {2027577600 -18000 1 CDT} - {2045718000 -21600 0 CST} - {2059027200 -18000 1 CDT} - {2077167600 -21600 0 CST} - {2091081600 -18000 1 CDT} - {2108617200 -21600 0 CST} - {2122531200 -18000 1 CDT} - {2140066800 -21600 0 CST} - {2153980800 -18000 1 CDT} - {2172121200 -21600 0 CST} - {2185430400 -18000 1 CDT} - {2203570800 -21600 0 CST} - {2216880000 -18000 1 CDT} - {2235020400 -21600 0 CST} - {2248934400 -18000 1 CDT} - {2266470000 -21600 0 CST} - {2280384000 -18000 1 CDT} - {2297919600 -21600 0 CST} - {2311833600 -18000 1 CDT} - {2329369200 -21600 0 CST} - {2343283200 -18000 1 CDT} - {2361423600 -21600 0 CST} - {2374732800 -18000 1 CDT} - {2392873200 -21600 0 CST} - {2406182400 -18000 1 CDT} - {2424322800 -21600 0 CST} - {2438236800 -18000 1 CDT} - {2455772400 -21600 0 CST} - {2469686400 -18000 1 CDT} - {2487222000 -21600 0 CST} - {2501136000 -18000 1 CDT} - {2519276400 -21600 0 CST} - {2532585600 -18000 1 CDT} - {2550726000 -21600 0 CST} - {2564035200 -18000 1 CDT} - {2582175600 -21600 0 CST} - {2596089600 -18000 1 CDT} - {2613625200 -21600 0 CST} - {2627539200 -18000 1 CDT} - {2645074800 -21600 0 CST} - {2658988800 -18000 1 CDT} - {2676524400 -21600 0 CST} - {2690438400 -18000 1 CDT} - {2708578800 -21600 0 CST} - {2721888000 -18000 1 CDT} - {2740028400 -21600 0 CST} - {2753337600 -18000 1 CDT} - {2771478000 -21600 0 CST} - {2785392000 -18000 1 CDT} - {2802927600 -21600 0 CST} - {2816841600 -18000 1 CDT} - {2834377200 -21600 0 CST} - {2848291200 -18000 1 CDT} - {2866431600 -21600 0 CST} - {2879740800 -18000 1 CDT} - {2897881200 -21600 0 CST} - {2911190400 -18000 1 CDT} - {2929330800 -21600 0 CST} - {2942640000 -18000 1 CDT} - {2960780400 -21600 0 CST} - {2974694400 -18000 1 CDT} - {2992230000 -21600 0 CST} - {3006144000 -18000 1 CDT} - {3023679600 -21600 0 CST} - {3037593600 -18000 1 CDT} - {3055734000 -21600 0 CST} - {3069043200 -18000 1 CDT} - {3087183600 -21600 0 CST} - {3100492800 -18000 1 CDT} - {3118633200 -21600 0 CST} - {3132547200 -18000 1 CDT} - {3150082800 -21600 0 CST} - {3163996800 -18000 1 CDT} - {3181532400 -21600 0 CST} - {3195446400 -18000 1 CDT} - {3212982000 -21600 0 CST} - {3226896000 -18000 1 CDT} - {3245036400 -21600 0 CST} - {3258345600 -18000 1 CDT} - {3276486000 -21600 0 CST} - {3289795200 -18000 1 CDT} - {3307935600 -21600 0 CST} - {3321849600 -18000 1 CDT} - {3339385200 -21600 0 CST} - {3353299200 -18000 1 CDT} - {3370834800 -21600 0 CST} - {3384748800 -18000 1 CDT} - {3402889200 -21600 0 CST} - {3416198400 -18000 1 CDT} - {3434338800 -21600 0 CST} - {3447648000 -18000 1 CDT} - {3465788400 -21600 0 CST} - {3479702400 -18000 1 CDT} - {3497238000 -21600 0 CST} - {3511152000 -18000 1 CDT} - {3528687600 -21600 0 CST} - {3542601600 -18000 1 CDT} - {3560137200 -21600 0 CST} - {3574051200 -18000 1 CDT} - {3592191600 -21600 0 CST} - {3605500800 -18000 1 CDT} - {3623641200 -21600 0 CST} - {3636950400 -18000 1 CDT} - {3655090800 -21600 0 CST} - {3669004800 -18000 1 CDT} - {3686540400 -21600 0 CST} - {3700454400 -18000 1 CDT} - {3717990000 -21600 0 CST} - {3731904000 -18000 1 CDT} - {3750044400 -21600 0 CST} - {3763353600 -18000 1 CDT} - {3781494000 -21600 0 CST} - {3794803200 -18000 1 CDT} - {3812943600 -21600 0 CST} - {3826252800 -18000 1 CDT} - {3844393200 -21600 0 CST} - {3858307200 -18000 1 CDT} - {3875842800 -21600 0 CST} - {3889756800 -18000 1 CDT} - {3907292400 -21600 0 CST} - {3921206400 -18000 1 CDT} - {3939346800 -21600 0 CST} - {3952656000 -18000 1 CDT} - {3970796400 -21600 0 CST} - {3984105600 -18000 1 CDT} - {4002246000 -21600 0 CST} - {4016160000 -18000 1 CDT} - {4033695600 -21600 0 CST} - {4047609600 -18000 1 CDT} - {4065145200 -21600 0 CST} - {4079059200 -18000 1 CDT} - {4096594800 -21600 0 CST} } diff --git a/library/tzdata/America/Monterrey b/library/tzdata/America/Monterrey index 4135884..7471c6a 100644 --- a/library/tzdata/America/Monterrey +++ b/library/tzdata/America/Monterrey @@ -61,158 +61,4 @@ set TZData(:America/Monterrey) { {1635663600 -21600 0 CST} {1648972800 -18000 1 CDT} {1667113200 -21600 0 CST} - {1680422400 -18000 1 CDT} - {1698562800 -21600 0 CST} - {1712476800 -18000 1 CDT} - {1730012400 -21600 0 CST} - {1743926400 -18000 1 CDT} - {1761462000 -21600 0 CST} - {1775376000 -18000 1 CDT} - {1792911600 -21600 0 CST} - {1806825600 -18000 1 CDT} - {1824966000 -21600 0 CST} - {1838275200 -18000 1 CDT} - {1856415600 -21600 0 CST} - {1869724800 -18000 1 CDT} - {1887865200 -21600 0 CST} - {1901779200 -18000 1 CDT} - {1919314800 -21600 0 CST} - {1933228800 -18000 1 CDT} - {1950764400 -21600 0 CST} - {1964678400 -18000 1 CDT} - {1982818800 -21600 0 CST} - {1996128000 -18000 1 CDT} - {2014268400 -21600 0 CST} - {2027577600 -18000 1 CDT} - {2045718000 -21600 0 CST} - {2059027200 -18000 1 CDT} - {2077167600 -21600 0 CST} - {2091081600 -18000 1 CDT} - {2108617200 -21600 0 CST} - {2122531200 -18000 1 CDT} - {2140066800 -21600 0 CST} - {2153980800 -18000 1 CDT} - {2172121200 -21600 0 CST} - {2185430400 -18000 1 CDT} - {2203570800 -21600 0 CST} - {2216880000 -18000 1 CDT} - {2235020400 -21600 0 CST} - {2248934400 -18000 1 CDT} - {2266470000 -21600 0 CST} - {2280384000 -18000 1 CDT} - {2297919600 -21600 0 CST} - {2311833600 -18000 1 CDT} - {2329369200 -21600 0 CST} - {2343283200 -18000 1 CDT} - {2361423600 -21600 0 CST} - {2374732800 -18000 1 CDT} - {2392873200 -21600 0 CST} - {2406182400 -18000 1 CDT} - {2424322800 -21600 0 CST} - {2438236800 -18000 1 CDT} - {2455772400 -21600 0 CST} - {2469686400 -18000 1 CDT} - {2487222000 -21600 0 CST} - {2501136000 -18000 1 CDT} - {2519276400 -21600 0 CST} - {2532585600 -18000 1 CDT} - {2550726000 -21600 0 CST} - {2564035200 -18000 1 CDT} - {2582175600 -21600 0 CST} - {2596089600 -18000 1 CDT} - {2613625200 -21600 0 CST} - {2627539200 -18000 1 CDT} - {2645074800 -21600 0 CST} - {2658988800 -18000 1 CDT} - {2676524400 -21600 0 CST} - {2690438400 -18000 1 CDT} - {2708578800 -21600 0 CST} - {2721888000 -18000 1 CDT} - {2740028400 -21600 0 CST} - {2753337600 -18000 1 CDT} - {2771478000 -21600 0 CST} - {2785392000 -18000 1 CDT} - {2802927600 -21600 0 CST} - {2816841600 -18000 1 CDT} - {2834377200 -21600 0 CST} - {2848291200 -18000 1 CDT} - {2866431600 -21600 0 CST} - {2879740800 -18000 1 CDT} - {2897881200 -21600 0 CST} - {2911190400 -18000 1 CDT} - {2929330800 -21600 0 CST} - {2942640000 -18000 1 CDT} - {2960780400 -21600 0 CST} - {2974694400 -18000 1 CDT} - {2992230000 -21600 0 CST} - {3006144000 -18000 1 CDT} - {3023679600 -21600 0 CST} - {3037593600 -18000 1 CDT} - {3055734000 -21600 0 CST} - {3069043200 -18000 1 CDT} - {3087183600 -21600 0 CST} - {3100492800 -18000 1 CDT} - {3118633200 -21600 0 CST} - {3132547200 -18000 1 CDT} - {3150082800 -21600 0 CST} - {3163996800 -18000 1 CDT} - {3181532400 -21600 0 CST} - {3195446400 -18000 1 CDT} - {3212982000 -21600 0 CST} - {3226896000 -18000 1 CDT} - {3245036400 -21600 0 CST} - {3258345600 -18000 1 CDT} - {3276486000 -21600 0 CST} - {3289795200 -18000 1 CDT} - {3307935600 -21600 0 CST} - {3321849600 -18000 1 CDT} - {3339385200 -21600 0 CST} - {3353299200 -18000 1 CDT} - {3370834800 -21600 0 CST} - {3384748800 -18000 1 CDT} - {3402889200 -21600 0 CST} - {3416198400 -18000 1 CDT} - {3434338800 -21600 0 CST} - {3447648000 -18000 1 CDT} - {3465788400 -21600 0 CST} - {3479702400 -18000 1 CDT} - {3497238000 -21600 0 CST} - {3511152000 -18000 1 CDT} - {3528687600 -21600 0 CST} - {3542601600 -18000 1 CDT} - {3560137200 -21600 0 CST} - {3574051200 -18000 1 CDT} - {3592191600 -21600 0 CST} - {3605500800 -18000 1 CDT} - {3623641200 -21600 0 CST} - {3636950400 -18000 1 CDT} - {3655090800 -21600 0 CST} - {3669004800 -18000 1 CDT} - {3686540400 -21600 0 CST} - {3700454400 -18000 1 CDT} - {3717990000 -21600 0 CST} - {3731904000 -18000 1 CDT} - {3750044400 -21600 0 CST} - {3763353600 -18000 1 CDT} - {3781494000 -21600 0 CST} - {3794803200 -18000 1 CDT} - {3812943600 -21600 0 CST} - {3826252800 -18000 1 CDT} - {3844393200 -21600 0 CST} - {3858307200 -18000 1 CDT} - {3875842800 -21600 0 CST} - {3889756800 -18000 1 CDT} - {3907292400 -21600 0 CST} - {3921206400 -18000 1 CDT} - {3939346800 -21600 0 CST} - {3952656000 -18000 1 CDT} - {3970796400 -21600 0 CST} - {3984105600 -18000 1 CDT} - {4002246000 -21600 0 CST} - {4016160000 -18000 1 CDT} - {4033695600 -21600 0 CST} - {4047609600 -18000 1 CDT} - {4065145200 -21600 0 CST} - {4079059200 -18000 1 CDT} - {4096594800 -21600 0 CST} } diff --git a/library/tzdata/America/Nipigon b/library/tzdata/America/Nipigon index 30690aa..785a3a3 100644 --- a/library/tzdata/America/Nipigon +++ b/library/tzdata/America/Nipigon @@ -1,264 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Nipigon) { - {-9223372036854775808 -21184 0 LMT} - {-2366734016 -18000 0 EST} - {-1632070800 -14400 1 EDT} - {-1615140000 -18000 0 EST} - {-923252400 -14400 1 EDT} - {-880218000 -14400 0 EWT} - {-769395600 -14400 1 EPT} - {-765396000 -18000 0 EST} - {136364400 -14400 1 EDT} - {152085600 -18000 0 EST} - {167814000 -14400 1 EDT} - {183535200 -18000 0 EST} - {199263600 -14400 1 EDT} - {215589600 -18000 0 EST} - {230713200 -14400 1 EDT} - {247039200 -18000 0 EST} - {262767600 -14400 1 EDT} - {278488800 -18000 0 EST} - {294217200 -14400 1 EDT} - {309938400 -18000 0 EST} - {325666800 -14400 1 EDT} - {341388000 -18000 0 EST} - {357116400 -14400 1 EDT} - {372837600 -18000 0 EST} - {388566000 -14400 1 EDT} - {404892000 -18000 0 EST} - {420015600 -14400 1 EDT} - {436341600 -18000 0 EST} - {452070000 -14400 1 EDT} - {467791200 -18000 0 EST} - {483519600 -14400 1 EDT} - {499240800 -18000 0 EST} - {514969200 -14400 1 EDT} - {530690400 -18000 0 EST} - {544604400 -14400 1 EDT} - {562140000 -18000 0 EST} - {576054000 -14400 1 EDT} - {594194400 -18000 0 EST} - {607503600 -14400 1 EDT} - {625644000 -18000 0 EST} - {638953200 -14400 1 EDT} - {657093600 -18000 0 EST} - {671007600 -14400 1 EDT} - {688543200 -18000 0 EST} - {702457200 -14400 1 EDT} - {719992800 -18000 0 EST} - {733906800 -14400 1 EDT} - {752047200 -18000 0 EST} - {765356400 -14400 1 EDT} - {783496800 -18000 0 EST} - {796806000 -14400 1 EDT} - {814946400 -18000 0 EST} - {828860400 -14400 1 EDT} - {846396000 -18000 0 EST} - {860310000 -14400 1 EDT} - {877845600 -18000 0 EST} - {891759600 -14400 1 EDT} - {909295200 -18000 0 EST} - {923209200 -14400 1 EDT} - {941349600 -18000 0 EST} - {954658800 -14400 1 EDT} - {972799200 -18000 0 EST} - {986108400 -14400 1 EDT} - {1004248800 -18000 0 EST} - {1018162800 -14400 1 EDT} - {1035698400 -18000 0 EST} - {1049612400 -14400 1 EDT} - {1067148000 -18000 0 EST} - {1081062000 -14400 1 EDT} - {1099202400 -18000 0 EST} - {1112511600 -14400 1 EDT} - {1130652000 -18000 0 EST} - {1143961200 -14400 1 EDT} - {1162101600 -18000 0 EST} - {1173596400 -14400 1 EDT} - {1194156000 -18000 0 EST} - {1205046000 -14400 1 EDT} - {1225605600 -18000 0 EST} - {1236495600 -14400 1 EDT} - {1257055200 -18000 0 EST} - {1268550000 -14400 1 EDT} - {1289109600 -18000 0 EST} - {1299999600 -14400 1 EDT} - {1320559200 -18000 0 EST} - {1331449200 -14400 1 EDT} - {1352008800 -18000 0 EST} - {1362898800 -14400 1 EDT} - {1383458400 -18000 0 EST} - {1394348400 -14400 1 EDT} - {1414908000 -18000 0 EST} - {1425798000 -14400 1 EDT} - {1446357600 -18000 0 EST} - {1457852400 -14400 1 EDT} - {1478412000 -18000 0 EST} - {1489302000 -14400 1 EDT} - {1509861600 -18000 0 EST} - {1520751600 -14400 1 EDT} - {1541311200 -18000 0 EST} - {1552201200 -14400 1 EDT} - {1572760800 -18000 0 EST} - {1583650800 -14400 1 EDT} - {1604210400 -18000 0 EST} - {1615705200 -14400 1 EDT} - {1636264800 -18000 0 EST} - {1647154800 -14400 1 EDT} - {1667714400 -18000 0 EST} - {1678604400 -14400 1 EDT} - {1699164000 -18000 0 EST} - {1710054000 -14400 1 EDT} - {1730613600 -18000 0 EST} - {1741503600 -14400 1 EDT} - {1762063200 -18000 0 EST} - {1772953200 -14400 1 EDT} - {1793512800 -18000 0 EST} - {1805007600 -14400 1 EDT} - {1825567200 -18000 0 EST} - {1836457200 -14400 1 EDT} - {1857016800 -18000 0 EST} - {1867906800 -14400 1 EDT} - {1888466400 -18000 0 EST} - {1899356400 -14400 1 EDT} - {1919916000 -18000 0 EST} - {1930806000 -14400 1 EDT} - {1951365600 -18000 0 EST} - {1962860400 -14400 1 EDT} - {1983420000 -18000 0 EST} - {1994310000 -14400 1 EDT} - {2014869600 -18000 0 EST} - {2025759600 -14400 1 EDT} - {2046319200 -18000 0 EST} - {2057209200 -14400 1 EDT} - {2077768800 -18000 0 EST} - {2088658800 -14400 1 EDT} - {2109218400 -18000 0 EST} - {2120108400 -14400 1 EDT} - {2140668000 -18000 0 EST} - {2152162800 -14400 1 EDT} - {2172722400 -18000 0 EST} - {2183612400 -14400 1 EDT} - {2204172000 -18000 0 EST} - {2215062000 -14400 1 EDT} - {2235621600 -18000 0 EST} - {2246511600 -14400 1 EDT} - {2267071200 -18000 0 EST} - {2277961200 -14400 1 EDT} - {2298520800 -18000 0 EST} - {2309410800 -14400 1 EDT} - {2329970400 -18000 0 EST} - {2341465200 -14400 1 EDT} - {2362024800 -18000 0 EST} - {2372914800 -14400 1 EDT} - {2393474400 -18000 0 EST} - {2404364400 -14400 1 EDT} - {2424924000 -18000 0 EST} - {2435814000 -14400 1 EDT} - {2456373600 -18000 0 EST} - {2467263600 -14400 1 EDT} - {2487823200 -18000 0 EST} - {2499318000 -14400 1 EDT} - {2519877600 -18000 0 EST} - {2530767600 -14400 1 EDT} - {2551327200 -18000 0 EST} - {2562217200 -14400 1 EDT} - {2582776800 -18000 0 EST} - {2593666800 -14400 1 EDT} - {2614226400 -18000 0 EST} - {2625116400 -14400 1 EDT} - {2645676000 -18000 0 EST} - {2656566000 -14400 1 EDT} - {2677125600 -18000 0 EST} - {2688620400 -14400 1 EDT} - {2709180000 -18000 0 EST} - {2720070000 -14400 1 EDT} - {2740629600 -18000 0 EST} - {2751519600 -14400 1 EDT} - {2772079200 -18000 0 EST} - {2782969200 -14400 1 EDT} - {2803528800 -18000 0 EST} - {2814418800 -14400 1 EDT} - {2834978400 -18000 0 EST} - {2846473200 -14400 1 EDT} - {2867032800 -18000 0 EST} - {2877922800 -14400 1 EDT} - {2898482400 -18000 0 EST} - {2909372400 -14400 1 EDT} - {2929932000 -18000 0 EST} - {2940822000 -14400 1 EDT} - {2961381600 -18000 0 EST} - {2972271600 -14400 1 EDT} - {2992831200 -18000 0 EST} - {3003721200 -14400 1 EDT} - {3024280800 -18000 0 EST} - {3035775600 -14400 1 EDT} - {3056335200 -18000 0 EST} - {3067225200 -14400 1 EDT} - {3087784800 -18000 0 EST} - {3098674800 -14400 1 EDT} - {3119234400 -18000 0 EST} - {3130124400 -14400 1 EDT} - {3150684000 -18000 0 EST} - {3161574000 -14400 1 EDT} - {3182133600 -18000 0 EST} - {3193023600 -14400 1 EDT} - {3213583200 -18000 0 EST} - {3225078000 -14400 1 EDT} - {3245637600 -18000 0 EST} - {3256527600 -14400 1 EDT} - {3277087200 -18000 0 EST} - {3287977200 -14400 1 EDT} - {3308536800 -18000 0 EST} - {3319426800 -14400 1 EDT} - {3339986400 -18000 0 EST} - {3350876400 -14400 1 EDT} - {3371436000 -18000 0 EST} - {3382930800 -14400 1 EDT} - {3403490400 -18000 0 EST} - {3414380400 -14400 1 EDT} - {3434940000 -18000 0 EST} - {3445830000 -14400 1 EDT} - {3466389600 -18000 0 EST} - {3477279600 -14400 1 EDT} - {3497839200 -18000 0 EST} - {3508729200 -14400 1 EDT} - {3529288800 -18000 0 EST} - {3540178800 -14400 1 EDT} - {3560738400 -18000 0 EST} - {3572233200 -14400 1 EDT} - {3592792800 -18000 0 EST} - {3603682800 -14400 1 EDT} - {3624242400 -18000 0 EST} - {3635132400 -14400 1 EDT} - {3655692000 -18000 0 EST} - {3666582000 -14400 1 EDT} - {3687141600 -18000 0 EST} - {3698031600 -14400 1 EDT} - {3718591200 -18000 0 EST} - {3730086000 -14400 1 EDT} - {3750645600 -18000 0 EST} - {3761535600 -14400 1 EDT} - {3782095200 -18000 0 EST} - {3792985200 -14400 1 EDT} - {3813544800 -18000 0 EST} - {3824434800 -14400 1 EDT} - {3844994400 -18000 0 EST} - {3855884400 -14400 1 EDT} - {3876444000 -18000 0 EST} - {3887334000 -14400 1 EDT} - {3907893600 -18000 0 EST} - {3919388400 -14400 1 EDT} - {3939948000 -18000 0 EST} - {3950838000 -14400 1 EDT} - {3971397600 -18000 0 EST} - {3982287600 -14400 1 EDT} - {4002847200 -18000 0 EST} - {4013737200 -14400 1 EDT} - {4034296800 -18000 0 EST} - {4045186800 -14400 1 EDT} - {4065746400 -18000 0 EST} - {4076636400 -14400 1 EDT} - {4097196000 -18000 0 EST} +if {![info exists TZData(America/Toronto)]} { + LoadTimeZoneFile America/Toronto } +set TZData(:America/Nipigon) $TZData(:America/Toronto) diff --git a/library/tzdata/America/Ojinaga b/library/tzdata/America/Ojinaga index c01cfde..7102f73 100644 --- a/library/tzdata/America/Ojinaga +++ b/library/tzdata/America/Ojinaga @@ -64,159 +64,5 @@ set TZData(:America/Ojinaga) { {1615712400 -21600 1 MDT} {1636272000 -25200 0 MST} {1647162000 -21600 1 MDT} - {1667721600 -25200 0 MST} - {1678611600 -21600 1 MDT} - {1699171200 -25200 0 MST} - {1710061200 -21600 1 MDT} - {1730620800 -25200 0 MST} - {1741510800 -21600 1 MDT} - {1762070400 -25200 0 MST} - {1772960400 -21600 1 MDT} - {1793520000 -25200 0 MST} - {1805014800 -21600 1 MDT} - {1825574400 -25200 0 MST} - {1836464400 -21600 1 MDT} - {1857024000 -25200 0 MST} - {1867914000 -21600 1 MDT} - {1888473600 -25200 0 MST} - {1899363600 -21600 1 MDT} - {1919923200 -25200 0 MST} - {1930813200 -21600 1 MDT} - {1951372800 -25200 0 MST} - {1962867600 -21600 1 MDT} - {1983427200 -25200 0 MST} - {1994317200 -21600 1 MDT} - {2014876800 -25200 0 MST} - {2025766800 -21600 1 MDT} - {2046326400 -25200 0 MST} - {2057216400 -21600 1 MDT} - {2077776000 -25200 0 MST} - {2088666000 -21600 1 MDT} - {2109225600 -25200 0 MST} - {2120115600 -21600 1 MDT} - {2140675200 -25200 0 MST} - {2152170000 -21600 1 MDT} - {2172729600 -25200 0 MST} - {2183619600 -21600 1 MDT} - {2204179200 -25200 0 MST} - {2215069200 -21600 1 MDT} - {2235628800 -25200 0 MST} - {2246518800 -21600 1 MDT} - {2267078400 -25200 0 MST} - {2277968400 -21600 1 MDT} - {2298528000 -25200 0 MST} - {2309418000 -21600 1 MDT} - {2329977600 -25200 0 MST} - {2341472400 -21600 1 MDT} - {2362032000 -25200 0 MST} - {2372922000 -21600 1 MDT} - {2393481600 -25200 0 MST} - {2404371600 -21600 1 MDT} - {2424931200 -25200 0 MST} - {2435821200 -21600 1 MDT} - {2456380800 -25200 0 MST} - {2467270800 -21600 1 MDT} - {2487830400 -25200 0 MST} - {2499325200 -21600 1 MDT} - {2519884800 -25200 0 MST} - {2530774800 -21600 1 MDT} - {2551334400 -25200 0 MST} - {2562224400 -21600 1 MDT} - {2582784000 -25200 0 MST} - {2593674000 -21600 1 MDT} - {2614233600 -25200 0 MST} - {2625123600 -21600 1 MDT} - {2645683200 -25200 0 MST} - {2656573200 -21600 1 MDT} - {2677132800 -25200 0 MST} - {2688627600 -21600 1 MDT} - {2709187200 -25200 0 MST} - {2720077200 -21600 1 MDT} - {2740636800 -25200 0 MST} - {2751526800 -21600 1 MDT} - {2772086400 -25200 0 MST} - {2782976400 -21600 1 MDT} - {2803536000 -25200 0 MST} - {2814426000 -21600 1 MDT} - {2834985600 -25200 0 MST} - {2846480400 -21600 1 MDT} - {2867040000 -25200 0 MST} - {2877930000 -21600 1 MDT} - {2898489600 -25200 0 MST} - {2909379600 -21600 1 MDT} - {2929939200 -25200 0 MST} - {2940829200 -21600 1 MDT} - {2961388800 -25200 0 MST} - {2972278800 -21600 1 MDT} - {2992838400 -25200 0 MST} - {3003728400 -21600 1 MDT} - {3024288000 -25200 0 MST} - {3035782800 -21600 1 MDT} - {3056342400 -25200 0 MST} - {3067232400 -21600 1 MDT} - {3087792000 -25200 0 MST} - {3098682000 -21600 1 MDT} - {3119241600 -25200 0 MST} - {3130131600 -21600 1 MDT} - {3150691200 -25200 0 MST} - {3161581200 -21600 1 MDT} - {3182140800 -25200 0 MST} - {3193030800 -21600 1 MDT} - {3213590400 -25200 0 MST} - {3225085200 -21600 1 MDT} - {3245644800 -25200 0 MST} - {3256534800 -21600 1 MDT} - {3277094400 -25200 0 MST} - {3287984400 -21600 1 MDT} - {3308544000 -25200 0 MST} - {3319434000 -21600 1 MDT} - {3339993600 -25200 0 MST} - {3350883600 -21600 1 MDT} - {3371443200 -25200 0 MST} - {3382938000 -21600 1 MDT} - {3403497600 -25200 0 MST} - {3414387600 -21600 1 MDT} - {3434947200 -25200 0 MST} - {3445837200 -21600 1 MDT} - {3466396800 -25200 0 MST} - {3477286800 -21600 1 MDT} - {3497846400 -25200 0 MST} - {3508736400 -21600 1 MDT} - {3529296000 -25200 0 MST} - {3540186000 -21600 1 MDT} - {3560745600 -25200 0 MST} - {3572240400 -21600 1 MDT} - {3592800000 -25200 0 MST} - {3603690000 -21600 1 MDT} - {3624249600 -25200 0 MST} - {3635139600 -21600 1 MDT} - {3655699200 -25200 0 MST} - {3666589200 -21600 1 MDT} - {3687148800 -25200 0 MST} - {3698038800 -21600 1 MDT} - {3718598400 -25200 0 MST} - {3730093200 -21600 1 MDT} - {3750652800 -25200 0 MST} - {3761542800 -21600 1 MDT} - {3782102400 -25200 0 MST} - {3792992400 -21600 1 MDT} - {3813552000 -25200 0 MST} - {3824442000 -21600 1 MDT} - {3845001600 -25200 0 MST} - {3855891600 -21600 1 MDT} - {3876451200 -25200 0 MST} - {3887341200 -21600 1 MDT} - {3907900800 -25200 0 MST} - {3919395600 -21600 1 MDT} - {3939955200 -25200 0 MST} - {3950845200 -21600 1 MDT} - {3971404800 -25200 0 MST} - {3982294800 -21600 1 MDT} - {4002854400 -25200 0 MST} - {4013744400 -21600 1 MDT} - {4034304000 -25200 0 MST} - {4045194000 -21600 1 MDT} - {4065753600 -25200 0 MST} - {4076643600 -21600 1 MDT} - {4097203200 -25200 0 MST} + {1667120400 -21600 0 CST} } diff --git a/library/tzdata/America/Rainy_River b/library/tzdata/America/Rainy_River index a2b11aa..17fccb4 100644 --- a/library/tzdata/America/Rainy_River +++ b/library/tzdata/America/Rainy_River @@ -1,264 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Rainy_River) { - {-9223372036854775808 -22696 0 LMT} - {-2366732504 -21600 0 CST} - {-1632067200 -18000 1 CDT} - {-1615136400 -21600 0 CST} - {-923248800 -18000 1 CDT} - {-880214400 -18000 0 CWT} - {-769395600 -18000 1 CPT} - {-765392400 -21600 0 CST} - {136368000 -18000 1 CDT} - {152089200 -21600 0 CST} - {167817600 -18000 1 CDT} - {183538800 -21600 0 CST} - {199267200 -18000 1 CDT} - {215593200 -21600 0 CST} - {230716800 -18000 1 CDT} - {247042800 -21600 0 CST} - {262771200 -18000 1 CDT} - {278492400 -21600 0 CST} - {294220800 -18000 1 CDT} - {309942000 -21600 0 CST} - {325670400 -18000 1 CDT} - {341391600 -21600 0 CST} - {357120000 -18000 1 CDT} - {372841200 -21600 0 CST} - {388569600 -18000 1 CDT} - {404895600 -21600 0 CST} - {420019200 -18000 1 CDT} - {436345200 -21600 0 CST} - {452073600 -18000 1 CDT} - {467794800 -21600 0 CST} - {483523200 -18000 1 CDT} - {499244400 -21600 0 CST} - {514972800 -18000 1 CDT} - {530694000 -21600 0 CST} - {544608000 -18000 1 CDT} - {562143600 -21600 0 CST} - {576057600 -18000 1 CDT} - {594198000 -21600 0 CST} - {607507200 -18000 1 CDT} - {625647600 -21600 0 CST} - {638956800 -18000 1 CDT} - {657097200 -21600 0 CST} - {671011200 -18000 1 CDT} - {688546800 -21600 0 CST} - {702460800 -18000 1 CDT} - {719996400 -21600 0 CST} - {733910400 -18000 1 CDT} - {752050800 -21600 0 CST} - {765360000 -18000 1 CDT} - {783500400 -21600 0 CST} - {796809600 -18000 1 CDT} - {814950000 -21600 0 CST} - {828864000 -18000 1 CDT} - {846399600 -21600 0 CST} - {860313600 -18000 1 CDT} - {877849200 -21600 0 CST} - {891763200 -18000 1 CDT} - {909298800 -21600 0 CST} - {923212800 -18000 1 CDT} - {941353200 -21600 0 CST} - {954662400 -18000 1 CDT} - {972802800 -21600 0 CST} - {986112000 -18000 1 CDT} - {1004252400 -21600 0 CST} - {1018166400 -18000 1 CDT} - {1035702000 -21600 0 CST} - {1049616000 -18000 1 CDT} - {1067151600 -21600 0 CST} - {1081065600 -18000 1 CDT} - {1099206000 -21600 0 CST} - {1112515200 -18000 1 CDT} - {1130655600 -21600 0 CST} - {1143964800 -18000 1 CDT} - {1162105200 -21600 0 CST} - {1173600000 -18000 1 CDT} - {1194159600 -21600 0 CST} - {1205049600 -18000 1 CDT} - {1225609200 -21600 0 CST} - {1236499200 -18000 1 CDT} - {1257058800 -21600 0 CST} - {1268553600 -18000 1 CDT} - {1289113200 -21600 0 CST} - {1300003200 -18000 1 CDT} - {1320562800 -21600 0 CST} - {1331452800 -18000 1 CDT} - {1352012400 -21600 0 CST} - {1362902400 -18000 1 CDT} - {1383462000 -21600 0 CST} - {1394352000 -18000 1 CDT} - {1414911600 -21600 0 CST} - {1425801600 -18000 1 CDT} - {1446361200 -21600 0 CST} - {1457856000 -18000 1 CDT} - {1478415600 -21600 0 CST} - {1489305600 -18000 1 CDT} - {1509865200 -21600 0 CST} - {1520755200 -18000 1 CDT} - {1541314800 -21600 0 CST} - {1552204800 -18000 1 CDT} - {1572764400 -21600 0 CST} - {1583654400 -18000 1 CDT} - {1604214000 -21600 0 CST} - {1615708800 -18000 1 CDT} - {1636268400 -21600 0 CST} - {1647158400 -18000 1 CDT} - {1667718000 -21600 0 CST} - {1678608000 -18000 1 CDT} - {1699167600 -21600 0 CST} - {1710057600 -18000 1 CDT} - {1730617200 -21600 0 CST} - {1741507200 -18000 1 CDT} - {1762066800 -21600 0 CST} - {1772956800 -18000 1 CDT} - {1793516400 -21600 0 CST} - {1805011200 -18000 1 CDT} - {1825570800 -21600 0 CST} - {1836460800 -18000 1 CDT} - {1857020400 -21600 0 CST} - {1867910400 -18000 1 CDT} - {1888470000 -21600 0 CST} - {1899360000 -18000 1 CDT} - {1919919600 -21600 0 CST} - {1930809600 -18000 1 CDT} - {1951369200 -21600 0 CST} - {1962864000 -18000 1 CDT} - {1983423600 -21600 0 CST} - {1994313600 -18000 1 CDT} - {2014873200 -21600 0 CST} - {2025763200 -18000 1 CDT} - {2046322800 -21600 0 CST} - {2057212800 -18000 1 CDT} - {2077772400 -21600 0 CST} - {2088662400 -18000 1 CDT} - {2109222000 -21600 0 CST} - {2120112000 -18000 1 CDT} - {2140671600 -21600 0 CST} - {2152166400 -18000 1 CDT} - {2172726000 -21600 0 CST} - {2183616000 -18000 1 CDT} - {2204175600 -21600 0 CST} - {2215065600 -18000 1 CDT} - {2235625200 -21600 0 CST} - {2246515200 -18000 1 CDT} - {2267074800 -21600 0 CST} - {2277964800 -18000 1 CDT} - {2298524400 -21600 0 CST} - {2309414400 -18000 1 CDT} - {2329974000 -21600 0 CST} - {2341468800 -18000 1 CDT} - {2362028400 -21600 0 CST} - {2372918400 -18000 1 CDT} - {2393478000 -21600 0 CST} - {2404368000 -18000 1 CDT} - {2424927600 -21600 0 CST} - {2435817600 -18000 1 CDT} - {2456377200 -21600 0 CST} - {2467267200 -18000 1 CDT} - {2487826800 -21600 0 CST} - {2499321600 -18000 1 CDT} - {2519881200 -21600 0 CST} - {2530771200 -18000 1 CDT} - {2551330800 -21600 0 CST} - {2562220800 -18000 1 CDT} - {2582780400 -21600 0 CST} - {2593670400 -18000 1 CDT} - {2614230000 -21600 0 CST} - {2625120000 -18000 1 CDT} - {2645679600 -21600 0 CST} - {2656569600 -18000 1 CDT} - {2677129200 -21600 0 CST} - {2688624000 -18000 1 CDT} - {2709183600 -21600 0 CST} - {2720073600 -18000 1 CDT} - {2740633200 -21600 0 CST} - {2751523200 -18000 1 CDT} - {2772082800 -21600 0 CST} - {2782972800 -18000 1 CDT} - {2803532400 -21600 0 CST} - {2814422400 -18000 1 CDT} - {2834982000 -21600 0 CST} - {2846476800 -18000 1 CDT} - {2867036400 -21600 0 CST} - {2877926400 -18000 1 CDT} - {2898486000 -21600 0 CST} - {2909376000 -18000 1 CDT} - {2929935600 -21600 0 CST} - {2940825600 -18000 1 CDT} - {2961385200 -21600 0 CST} - {2972275200 -18000 1 CDT} - {2992834800 -21600 0 CST} - {3003724800 -18000 1 CDT} - {3024284400 -21600 0 CST} - {3035779200 -18000 1 CDT} - {3056338800 -21600 0 CST} - {3067228800 -18000 1 CDT} - {3087788400 -21600 0 CST} - {3098678400 -18000 1 CDT} - {3119238000 -21600 0 CST} - {3130128000 -18000 1 CDT} - {3150687600 -21600 0 CST} - {3161577600 -18000 1 CDT} - {3182137200 -21600 0 CST} - {3193027200 -18000 1 CDT} - {3213586800 -21600 0 CST} - {3225081600 -18000 1 CDT} - {3245641200 -21600 0 CST} - {3256531200 -18000 1 CDT} - {3277090800 -21600 0 CST} - {3287980800 -18000 1 CDT} - {3308540400 -21600 0 CST} - {3319430400 -18000 1 CDT} - {3339990000 -21600 0 CST} - {3350880000 -18000 1 CDT} - {3371439600 -21600 0 CST} - {3382934400 -18000 1 CDT} - {3403494000 -21600 0 CST} - {3414384000 -18000 1 CDT} - {3434943600 -21600 0 CST} - {3445833600 -18000 1 CDT} - {3466393200 -21600 0 CST} - {3477283200 -18000 1 CDT} - {3497842800 -21600 0 CST} - {3508732800 -18000 1 CDT} - {3529292400 -21600 0 CST} - {3540182400 -18000 1 CDT} - {3560742000 -21600 0 CST} - {3572236800 -18000 1 CDT} - {3592796400 -21600 0 CST} - {3603686400 -18000 1 CDT} - {3624246000 -21600 0 CST} - {3635136000 -18000 1 CDT} - {3655695600 -21600 0 CST} - {3666585600 -18000 1 CDT} - {3687145200 -21600 0 CST} - {3698035200 -18000 1 CDT} - {3718594800 -21600 0 CST} - {3730089600 -18000 1 CDT} - {3750649200 -21600 0 CST} - {3761539200 -18000 1 CDT} - {3782098800 -21600 0 CST} - {3792988800 -18000 1 CDT} - {3813548400 -21600 0 CST} - {3824438400 -18000 1 CDT} - {3844998000 -21600 0 CST} - {3855888000 -18000 1 CDT} - {3876447600 -21600 0 CST} - {3887337600 -18000 1 CDT} - {3907897200 -21600 0 CST} - {3919392000 -18000 1 CDT} - {3939951600 -21600 0 CST} - {3950841600 -18000 1 CDT} - {3971401200 -21600 0 CST} - {3982291200 -18000 1 CDT} - {4002850800 -21600 0 CST} - {4013740800 -18000 1 CDT} - {4034300400 -21600 0 CST} - {4045190400 -18000 1 CDT} - {4065750000 -21600 0 CST} - {4076640000 -18000 1 CDT} - {4097199600 -21600 0 CST} +if {![info exists TZData(America/Winnipeg)]} { + LoadTimeZoneFile America/Winnipeg } +set TZData(:America/Rainy_River) $TZData(:America/Winnipeg) diff --git a/library/tzdata/America/Thunder_Bay b/library/tzdata/America/Thunder_Bay index 8a454be..4761beb 100644 --- a/library/tzdata/America/Thunder_Bay +++ b/library/tzdata/America/Thunder_Bay @@ -1,272 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Thunder_Bay) { - {-9223372036854775808 -21420 0 LMT} - {-2366733780 -21600 0 CST} - {-1893434400 -18000 0 EST} - {-883594800 -18000 0 EST} - {-880218000 -14400 1 EWT} - {-769395600 -14400 1 EPT} - {-765396000 -18000 0 EST} - {18000 -18000 0 EST} - {9961200 -14400 1 EDT} - {25682400 -18000 0 EST} - {41410800 -14400 1 EDT} - {57736800 -18000 0 EST} - {73465200 -14400 1 EDT} - {89186400 -18000 0 EST} - {94712400 -18000 0 EST} - {126248400 -18000 0 EST} - {136364400 -14400 1 EDT} - {152085600 -18000 0 EST} - {167814000 -14400 1 EDT} - {183535200 -18000 0 EST} - {199263600 -14400 1 EDT} - {215589600 -18000 0 EST} - {230713200 -14400 1 EDT} - {247039200 -18000 0 EST} - {262767600 -14400 1 EDT} - {278488800 -18000 0 EST} - {294217200 -14400 1 EDT} - {309938400 -18000 0 EST} - {325666800 -14400 1 EDT} - {341388000 -18000 0 EST} - {357116400 -14400 1 EDT} - {372837600 -18000 0 EST} - {388566000 -14400 1 EDT} - {404892000 -18000 0 EST} - {420015600 -14400 1 EDT} - {436341600 -18000 0 EST} - {452070000 -14400 1 EDT} - {467791200 -18000 0 EST} - {483519600 -14400 1 EDT} - {499240800 -18000 0 EST} - {514969200 -14400 1 EDT} - {530690400 -18000 0 EST} - {544604400 -14400 1 EDT} - {562140000 -18000 0 EST} - {576054000 -14400 1 EDT} - {594194400 -18000 0 EST} - {607503600 -14400 1 EDT} - {625644000 -18000 0 EST} - {638953200 -14400 1 EDT} - {657093600 -18000 0 EST} - {671007600 -14400 1 EDT} - {688543200 -18000 0 EST} - {702457200 -14400 1 EDT} - {719992800 -18000 0 EST} - {733906800 -14400 1 EDT} - {752047200 -18000 0 EST} - {765356400 -14400 1 EDT} - {783496800 -18000 0 EST} - {796806000 -14400 1 EDT} - {814946400 -18000 0 EST} - {828860400 -14400 1 EDT} - {846396000 -18000 0 EST} - {860310000 -14400 1 EDT} - {877845600 -18000 0 EST} - {891759600 -14400 1 EDT} - {909295200 -18000 0 EST} - {923209200 -14400 1 EDT} - {941349600 -18000 0 EST} - {954658800 -14400 1 EDT} - {972799200 -18000 0 EST} - {986108400 -14400 1 EDT} - {1004248800 -18000 0 EST} - {1018162800 -14400 1 EDT} - {1035698400 -18000 0 EST} - {1049612400 -14400 1 EDT} - {1067148000 -18000 0 EST} - {1081062000 -14400 1 EDT} - {1099202400 -18000 0 EST} - {1112511600 -14400 1 EDT} - {1130652000 -18000 0 EST} - {1143961200 -14400 1 EDT} - {1162101600 -18000 0 EST} - {1173596400 -14400 1 EDT} - {1194156000 -18000 0 EST} - {1205046000 -14400 1 EDT} - {1225605600 -18000 0 EST} - {1236495600 -14400 1 EDT} - {1257055200 -18000 0 EST} - {1268550000 -14400 1 EDT} - {1289109600 -18000 0 EST} - {1299999600 -14400 1 EDT} - {1320559200 -18000 0 EST} - {1331449200 -14400 1 EDT} - {1352008800 -18000 0 EST} - {1362898800 -14400 1 EDT} - {1383458400 -18000 0 EST} - {1394348400 -14400 1 EDT} - {1414908000 -18000 0 EST} - {1425798000 -14400 1 EDT} - {1446357600 -18000 0 EST} - {1457852400 -14400 1 EDT} - {1478412000 -18000 0 EST} - {1489302000 -14400 1 EDT} - {1509861600 -18000 0 EST} - {1520751600 -14400 1 EDT} - {1541311200 -18000 0 EST} - {1552201200 -14400 1 EDT} - {1572760800 -18000 0 EST} - {1583650800 -14400 1 EDT} - {1604210400 -18000 0 EST} - {1615705200 -14400 1 EDT} - {1636264800 -18000 0 EST} - {1647154800 -14400 1 EDT} - {1667714400 -18000 0 EST} - {1678604400 -14400 1 EDT} - {1699164000 -18000 0 EST} - {1710054000 -14400 1 EDT} - {1730613600 -18000 0 EST} - {1741503600 -14400 1 EDT} - {1762063200 -18000 0 EST} - {1772953200 -14400 1 EDT} - {1793512800 -18000 0 EST} - {1805007600 -14400 1 EDT} - {1825567200 -18000 0 EST} - {1836457200 -14400 1 EDT} - {1857016800 -18000 0 EST} - {1867906800 -14400 1 EDT} - {1888466400 -18000 0 EST} - {1899356400 -14400 1 EDT} - {1919916000 -18000 0 EST} - {1930806000 -14400 1 EDT} - {1951365600 -18000 0 EST} - {1962860400 -14400 1 EDT} - {1983420000 -18000 0 EST} - {1994310000 -14400 1 EDT} - {2014869600 -18000 0 EST} - {2025759600 -14400 1 EDT} - {2046319200 -18000 0 EST} - {2057209200 -14400 1 EDT} - {2077768800 -18000 0 EST} - {2088658800 -14400 1 EDT} - {2109218400 -18000 0 EST} - {2120108400 -14400 1 EDT} - {2140668000 -18000 0 EST} - {2152162800 -14400 1 EDT} - {2172722400 -18000 0 EST} - {2183612400 -14400 1 EDT} - {2204172000 -18000 0 EST} - {2215062000 -14400 1 EDT} - {2235621600 -18000 0 EST} - {2246511600 -14400 1 EDT} - {2267071200 -18000 0 EST} - {2277961200 -14400 1 EDT} - {2298520800 -18000 0 EST} - {2309410800 -14400 1 EDT} - {2329970400 -18000 0 EST} - {2341465200 -14400 1 EDT} - {2362024800 -18000 0 EST} - {2372914800 -14400 1 EDT} - {2393474400 -18000 0 EST} - {2404364400 -14400 1 EDT} - {2424924000 -18000 0 EST} - {2435814000 -14400 1 EDT} - {2456373600 -18000 0 EST} - {2467263600 -14400 1 EDT} - {2487823200 -18000 0 EST} - {2499318000 -14400 1 EDT} - {2519877600 -18000 0 EST} - {2530767600 -14400 1 EDT} - {2551327200 -18000 0 EST} - {2562217200 -14400 1 EDT} - {2582776800 -18000 0 EST} - {2593666800 -14400 1 EDT} - {2614226400 -18000 0 EST} - {2625116400 -14400 1 EDT} - {2645676000 -18000 0 EST} - {2656566000 -14400 1 EDT} - {2677125600 -18000 0 EST} - {2688620400 -14400 1 EDT} - {2709180000 -18000 0 EST} - {2720070000 -14400 1 EDT} - {2740629600 -18000 0 EST} - {2751519600 -14400 1 EDT} - {2772079200 -18000 0 EST} - {2782969200 -14400 1 EDT} - {2803528800 -18000 0 EST} - {2814418800 -14400 1 EDT} - {2834978400 -18000 0 EST} - {2846473200 -14400 1 EDT} - {2867032800 -18000 0 EST} - {2877922800 -14400 1 EDT} - {2898482400 -18000 0 EST} - {2909372400 -14400 1 EDT} - {2929932000 -18000 0 EST} - {2940822000 -14400 1 EDT} - {2961381600 -18000 0 EST} - {2972271600 -14400 1 EDT} - {2992831200 -18000 0 EST} - {3003721200 -14400 1 EDT} - {3024280800 -18000 0 EST} - {3035775600 -14400 1 EDT} - {3056335200 -18000 0 EST} - {3067225200 -14400 1 EDT} - {3087784800 -18000 0 EST} - {3098674800 -14400 1 EDT} - {3119234400 -18000 0 EST} - {3130124400 -14400 1 EDT} - {3150684000 -18000 0 EST} - {3161574000 -14400 1 EDT} - {3182133600 -18000 0 EST} - {3193023600 -14400 1 EDT} - {3213583200 -18000 0 EST} - {3225078000 -14400 1 EDT} - {3245637600 -18000 0 EST} - {3256527600 -14400 1 EDT} - {3277087200 -18000 0 EST} - {3287977200 -14400 1 EDT} - {3308536800 -18000 0 EST} - {3319426800 -14400 1 EDT} - {3339986400 -18000 0 EST} - {3350876400 -14400 1 EDT} - {3371436000 -18000 0 EST} - {3382930800 -14400 1 EDT} - {3403490400 -18000 0 EST} - {3414380400 -14400 1 EDT} - {3434940000 -18000 0 EST} - {3445830000 -14400 1 EDT} - {3466389600 -18000 0 EST} - {3477279600 -14400 1 EDT} - {3497839200 -18000 0 EST} - {3508729200 -14400 1 EDT} - {3529288800 -18000 0 EST} - {3540178800 -14400 1 EDT} - {3560738400 -18000 0 EST} - {3572233200 -14400 1 EDT} - {3592792800 -18000 0 EST} - {3603682800 -14400 1 EDT} - {3624242400 -18000 0 EST} - {3635132400 -14400 1 EDT} - {3655692000 -18000 0 EST} - {3666582000 -14400 1 EDT} - {3687141600 -18000 0 EST} - {3698031600 -14400 1 EDT} - {3718591200 -18000 0 EST} - {3730086000 -14400 1 EDT} - {3750645600 -18000 0 EST} - {3761535600 -14400 1 EDT} - {3782095200 -18000 0 EST} - {3792985200 -14400 1 EDT} - {3813544800 -18000 0 EST} - {3824434800 -14400 1 EDT} - {3844994400 -18000 0 EST} - {3855884400 -14400 1 EDT} - {3876444000 -18000 0 EST} - {3887334000 -14400 1 EDT} - {3907893600 -18000 0 EST} - {3919388400 -14400 1 EDT} - {3939948000 -18000 0 EST} - {3950838000 -14400 1 EDT} - {3971397600 -18000 0 EST} - {3982287600 -14400 1 EDT} - {4002847200 -18000 0 EST} - {4013737200 -14400 1 EDT} - {4034296800 -18000 0 EST} - {4045186800 -14400 1 EDT} - {4065746400 -18000 0 EST} - {4076636400 -14400 1 EDT} - {4097196000 -18000 0 EST} +if {![info exists TZData(America/Toronto)]} { + LoadTimeZoneFile America/Toronto } +set TZData(:America/Thunder_Bay) $TZData(:America/Toronto) diff --git a/library/tzdata/Pacific/Fiji b/library/tzdata/Pacific/Fiji index 67a1f00..c1d748b 100644 --- a/library/tzdata/Pacific/Fiji +++ b/library/tzdata/Pacific/Fiji @@ -31,159 +31,4 @@ set TZData(:Pacific/Fiji) { {1578751200 43200 0 +12} {1608386400 46800 1 +12} {1610805600 43200 0 +12} - {1668261600 46800 1 +12} - {1673704800 43200 0 +12} - {1699711200 46800 1 +12} - {1705154400 43200 0 +12} - {1731160800 46800 1 +12} - {1736604000 43200 0 +12} - {1762610400 46800 1 +12} - {1768658400 43200 0 +12} - {1794060000 46800 1 +12} - {1800108000 43200 0 +12} - {1826114400 46800 1 +12} - {1831557600 43200 0 +12} - {1857564000 46800 1 +12} - {1863007200 43200 0 +12} - {1889013600 46800 1 +12} - {1894456800 43200 0 +12} - {1920463200 46800 1 +12} - {1925906400 43200 0 +12} - {1951912800 46800 1 +12} - {1957960800 43200 0 +12} - {1983967200 46800 1 +12} - {1989410400 43200 0 +12} - {2015416800 46800 1 +12} - {2020860000 43200 0 +12} - {2046866400 46800 1 +12} - {2052309600 43200 0 +12} - {2078316000 46800 1 +12} - {2083759200 43200 0 +12} - {2109765600 46800 1 +12} - {2115813600 43200 0 +12} - {2141215200 46800 1 +12} - {2147263200 43200 0 +12} - {2173269600 46800 1 +12} - {2178712800 43200 0 +12} - {2204719200 46800 1 +12} - {2210162400 43200 0 +12} - {2236168800 46800 1 +12} - {2241612000 43200 0 +12} - {2267618400 46800 1 +12} - {2273061600 43200 0 +12} - {2299068000 46800 1 +12} - {2305116000 43200 0 +12} - {2330517600 46800 1 +12} - {2336565600 43200 0 +12} - {2362572000 46800 1 +12} - {2368015200 43200 0 +12} - {2394021600 46800 1 +12} - {2399464800 43200 0 +12} - {2425471200 46800 1 +12} - {2430914400 43200 0 +12} - {2456920800 46800 1 +12} - {2462364000 43200 0 +12} - {2488370400 46800 1 +12} - {2494418400 43200 0 +12} - {2520424800 46800 1 +12} - {2525868000 43200 0 +12} - {2551874400 46800 1 +12} - {2557317600 43200 0 +12} - {2583324000 46800 1 +12} - {2588767200 43200 0 +12} - {2614773600 46800 1 +12} - {2620216800 43200 0 +12} - {2646223200 46800 1 +12} - {2652271200 43200 0 +12} - {2677672800 46800 1 +12} - {2683720800 43200 0 +12} - {2709727200 46800 1 +12} - {2715170400 43200 0 +12} - {2741176800 46800 1 +12} - {2746620000 43200 0 +12} - {2772626400 46800 1 +12} - {2778069600 43200 0 +12} - {2804076000 46800 1 +12} - {2809519200 43200 0 +12} - {2835525600 46800 1 +12} - {2841573600 43200 0 +12} - {2867580000 46800 1 +12} - {2873023200 43200 0 +12} - {2899029600 46800 1 +12} - {2904472800 43200 0 +12} - {2930479200 46800 1 +12} - {2935922400 43200 0 +12} - {2961928800 46800 1 +12} - {2967372000 43200 0 +12} - {2993378400 46800 1 +12} - {2999426400 43200 0 +12} - {3024828000 46800 1 +12} - {3030876000 43200 0 +12} - {3056882400 46800 1 +12} - {3062325600 43200 0 +12} - {3088332000 46800 1 +12} - {3093775200 43200 0 +12} - {3119781600 46800 1 +12} - {3125224800 43200 0 +12} - {3151231200 46800 1 +12} - {3156674400 43200 0 +12} - {3182680800 46800 1 +12} - {3188728800 43200 0 +12} - {3214130400 46800 1 +12} - {3220178400 43200 0 +12} - {3246184800 46800 1 +12} - {3251628000 43200 0 +12} - {3277634400 46800 1 +12} - {3283077600 43200 0 +12} - {3309084000 46800 1 +12} - {3314527200 43200 0 +12} - {3340533600 46800 1 +12} - {3345976800 43200 0 +12} - {3371983200 46800 1 +12} - {3378031200 43200 0 +12} - {3404037600 46800 1 +12} - {3409480800 43200 0 +12} - {3435487200 46800 1 +12} - {3440930400 43200 0 +12} - {3466936800 46800 1 +12} - {3472380000 43200 0 +12} - {3498386400 46800 1 +12} - {3503829600 43200 0 +12} - {3529836000 46800 1 +12} - {3535884000 43200 0 +12} - {3561285600 46800 1 +12} - {3567333600 43200 0 +12} - {3593340000 46800 1 +12} - {3598783200 43200 0 +12} - {3624789600 46800 1 +12} - {3630232800 43200 0 +12} - {3656239200 46800 1 +12} - {3661682400 43200 0 +12} - {3687688800 46800 1 +12} - {3693132000 43200 0 +12} - {3719138400 46800 1 +12} - {3725186400 43200 0 +12} - {3751192800 46800 1 +12} - {3756636000 43200 0 +12} - {3782642400 46800 1 +12} - {3788085600 43200 0 +12} - {3814092000 46800 1 +12} - {3819535200 43200 0 +12} - {3845541600 46800 1 +12} - {3850984800 43200 0 +12} - {3876991200 46800 1 +12} - {3883039200 43200 0 +12} - {3908440800 46800 1 +12} - {3914488800 43200 0 +12} - {3940495200 46800 1 +12} - {3945938400 43200 0 +12} - {3971944800 46800 1 +12} - {3977388000 43200 0 +12} - {4003394400 46800 1 +12} - {4008837600 43200 0 +12} - {4034844000 46800 1 +12} - {4040287200 43200 0 +12} - {4066293600 46800 1 +12} - {4072341600 43200 0 +12} - {4097743200 46800 1 +12} } -- cgit v0.12 From d9a19f95121e4fd846211083cc7c3b0d22c7a564 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 30 Oct 2022 17:41:56 +0000 Subject: Bytecode compiler for ledit --- generic/tclBasic.c | 5 +- generic/tclCompCmdsGR.c | 187 ++++++++++++++++++++++++++++++------------------ generic/tclInt.h | 3 + tests/lreplace.test | 1 + 4 files changed, 124 insertions(+), 72 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index c9697d2..a1eb4cc 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -310,9 +310,9 @@ static const CmdInfo builtInCmds[] = { {"join", Tcl_JoinObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE}, {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE}, + {"ledit", Tcl_LeditObjCmd, TclCompileLeditCmd, NULL, CMD_IS_SAFE}, {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE}, {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE}, - {"xx", Tcl_LinsertObjCmd, TclCompileXxCmd, NULL, CMD_IS_SAFE}, {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE}, {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE}, @@ -323,10 +323,9 @@ static const CmdInfo builtInCmds[] = { {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE}, {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"lseq", Tcl_LseqObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"lseq", Tcl_LseqObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE}, {"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE}, - {"ledit", Tcl_LeditObjCmd, NULL, NULL, CMD_IS_SAFE}, {"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE}, {"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE}, {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE}, diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 72716a4..bf6288a 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -1036,6 +1036,124 @@ TclCompileLassignCmd( /* *---------------------------------------------------------------------- * + * TclCompileLeditCmd -- + * + * How to compile the "ledit" command. We only bother with the case + * where the index is constant. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileLeditCmd( + Tcl_Interp *interp, /* Tcl interpreter for context. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the + * command. */ + TCL_UNUSED(Command *), + CompileEnv *envPtr) /* Holds the resulting instructions. */ +{ + DefineLineInformation; /* TIP #280 */ + Tcl_Token *tokenPtr, *varTokenPtr; + int localIndex; /* Index of var in local var table. */ + int isScalar; /* Flag == 1 if scalar, 0 if array. */ + int tempDepth; /* Depth used for emitting one part of the + * code burst. */ + int first, last, i, end_indicator; + + if (parsePtr->numWords < 4) { + return TCL_ERROR; + } + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + + tokenPtr = TokenAfter(varTokenPtr); + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE, + &first) != TCL_OK) { + return TCL_ERROR; + } + + tokenPtr = TokenAfter(tokenPtr); + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_NONE, TCL_INDEX_END, + &last) != TCL_OK) { + return TCL_ERROR; + } + end_indicator = 1; /* "end" means last element by default */ + if (first == (int)TCL_INDEX_NONE) { + /* first == TCL_INDEX_NONE => Range after last element. */ + first = TCL_INDEX_END; /* Insert at end where ... */ + end_indicator = 0; /* ... end means AFTER last element */ + last = TCL_INDEX_NONE; /* Informs lreplace, nothing to replace */ + } + + PushVarNameWord(interp, varTokenPtr, envPtr, 0, + &localIndex, &isScalar, 1); + + /* Duplicate the variable name if it's been pushed. */ + if (localIndex < 0) { + if (isScalar) { + tempDepth = 0; + } else { + tempDepth = 1; + } + TclEmitInstInt4(INST_OVER, tempDepth, envPtr); + } + + /* Duplicate an array index if one's been pushed. */ + if (!isScalar) { + if (localIndex < 0) { + tempDepth = 1; + } else { + tempDepth = parsePtr->numWords - 2; + } + TclEmitInstInt4(INST_OVER, tempDepth, envPtr); + } + + /* Emit code to load the variable's value. */ + if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode(INST_LOAD_STK, envPtr); + } else { + Emit14Inst(INST_LOAD_SCALAR, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); + } else { + Emit14Inst(INST_LOAD_ARRAY, localIndex, envPtr); + } + } + + for (i=4 ; inumWords ; ++i) { + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, i); + } + + TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 3, envPtr); + TclEmitInt4(end_indicator, envPtr); + TclEmitInt4(first, envPtr); + TclEmitInt4(last, envPtr); + + /* Emit code to put the value back in the variable. */ + + if (isScalar) { + if (localIndex < 0) { + TclEmitOpcode(INST_STORE_STK, envPtr); + } else { + Emit14Inst(INST_STORE_SCALAR, localIndex, envPtr); + } + } else { + if (localIndex < 0) { + TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr); + } else { + Emit14Inst(INST_STORE_ARRAY, localIndex, envPtr); + } + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclCompileLindexCmd -- * * Procedure called to compile the "lindex" command. @@ -2908,75 +3026,6 @@ TclCompileObjectSelfCmd( } /* - *---------------------------------------------------------------------- - * - * TclCompileXxCmd -- - * - * How to compile the "linsert2" command. We only bother with the case - * where the index is constant. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileXxCmd( - Tcl_Interp *interp, /* Tcl interpreter for context. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the - * command. */ - TCL_UNUSED(Command *), - CompileEnv *envPtr) /* Holds the resulting instructions. */ -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr, *listTokenPtr; - int first, last, i, end_indicator; - - if (parsePtr->numWords < 4) { - return TCL_ERROR; - } - listTokenPtr = TokenAfter(parsePtr->tokenPtr); - - tokenPtr = TokenAfter(listTokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE, - &first) != TCL_OK) { - return TCL_ERROR; - } - - tokenPtr = TokenAfter(tokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_NONE, TCL_INDEX_END, - &last) != TCL_OK) { - return TCL_ERROR; - } - end_indicator = 1; /* "end" means last element by default */ - if (first == (int)TCL_INDEX_NONE) { - /* first == TCL_INDEX_NONE => Range after last element. */ - first = TCL_INDEX_END; /* Insert at end where ... */ - end_indicator = 0; /* ... end means AFTER last element */ - last = TCL_INDEX_NONE; /* Informs lreplace, nothing to replace */ - } else if (last == TCL_INDEX_NONE) { - /* - * last == TCL_INDEX_NONE => last precedes first element - * lreplace4 will treat this as nothing to delete - * Nought to do, just here for clarity, will be optimized away - */ - } else { - - } - - CompileWord(envPtr, listTokenPtr, interp, 1); - - for (i=4 ; inumWords ; i++) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i); - } - - TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 3, envPtr); - TclEmitInt4(end_indicator, envPtr); - TclEmitInt4(first, envPtr); - TclEmitInt4(last, envPtr); - return TCL_OK; -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclInt.h b/generic/tclInt.h index a67c8f9..5c977e5 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3759,6 +3759,9 @@ MODULE_SCOPE int TclCompileLappendCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileLassignCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileLeditCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLindexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); diff --git a/tests/lreplace.test b/tests/lreplace.test index 2952899..209c3d2 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -521,6 +521,7 @@ apply {{} { foreach i $ins { set expected [list [catch {$lreplace $ls $a $b {*}$i} m] $m] set tester [list ledit ls $a $b {*}$i] + #set script [list catch $tester m] set script [list catch $tester m] set script "list \[$script\] \$m" test ledit-6.[incr n] {ledit battery} -body \ -- cgit v0.12 From 026e32d86a8119bac99953394dffdfd5a80665e9 Mon Sep 17 00:00:00 2001 From: griffin Date: Tue, 1 Nov 2022 02:05:11 +0000 Subject: Fix refCount crash. Improve ArithSeries regression coverage. --- generic/tclArithSeries.c | 22 ++++++++++++++++++++-- generic/tclDecls.h | 4 ++-- generic/tclListObj.c | 2 +- tests/lseq.test | 35 +++++++++++++++++++++++++++++++++-- 4 files changed, 56 insertions(+), 7 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index c3c44f3..5c4e5a5 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -723,9 +723,27 @@ TclArithSeriesObjRange( return obj; } - TclArithSeriesObjIndex(arithSeriesPtr, fromIdx, &startObj); + if (TclArithSeriesObjIndex(arithSeriesPtr, fromIdx, &startObj) != TCL_OK) { + if (interp) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("index %d is out of bounds 0 to %" + TCL_LL_MODIFIER "d", fromIdx, (arithSeriesRepPtr->len-1))); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } Tcl_IncrRefCount(startObj); - TclArithSeriesObjIndex(arithSeriesPtr, toIdx, &endObj); + if (TclArithSeriesObjIndex(arithSeriesPtr, toIdx, &endObj) != TCL_OK) { + if (interp) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("index %d is out of bounds 0 to %" + TCL_LL_MODIFIER "d", fromIdx, (arithSeriesRepPtr->len-1))); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } Tcl_IncrRefCount(endObj); TclArithSeriesObjStep(arithSeriesPtr, &stepObj); Tcl_IncrRefCount(stepObj); diff --git a/generic/tclDecls.h b/generic/tclDecls.h index a7d3023..8cb77b8 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -636,7 +636,7 @@ EXTERN Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, /* 199 */ EXTERN Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port, const char *address, const char *myaddr, - int myport, int async); + int myport, int flags); /* 200 */ EXTERN Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port, const char *host, @@ -2272,7 +2272,7 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_ObjSetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 196 */ Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, Tcl_Size argc, const char **argv, int flags); /* 197 */ Tcl_Channel (*tcl_OpenFileChannel) (Tcl_Interp *interp, const char *fileName, const char *modeString, int permissions); /* 198 */ - Tcl_Channel (*tcl_OpenTcpClient) (Tcl_Interp *interp, int port, const char *address, const char *myaddr, int myport, int async); /* 199 */ + Tcl_Channel (*tcl_OpenTcpClient) (Tcl_Interp *interp, int port, const char *address, const char *myaddr, int myport, int flags); /* 199 */ Tcl_Channel (*tcl_OpenTcpServer) (Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, void *callbackData); /* 200 */ void (*tcl_Preserve) (void *data); /* 201 */ void (*tcl_PrintDouble) (Tcl_Interp *interp, double value, char *dst); /* 202 */ diff --git a/generic/tclListObj.c b/generic/tclListObj.c index a1d080c..8ee0f48 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -2644,10 +2644,10 @@ TclLindexFlat( /* ArithSeries cannot be a list of lists */ Tcl_DecrRefCount(elemObj); TclNewObj(elemObj); - Tcl_IncrRefCount(elemObj); break; } } + Tcl_IncrRefCount(elemObj); return elemObj; } diff --git a/tests/lseq.test b/tests/lseq.test index 2e5d7e1..b8ae2e9 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -255,8 +255,9 @@ test lseq-3.7 {lmap lseq} { test lseq-3.8 {lrange lseq} { set r [lrange [lseq 1 100] 10 20] - lindex [tcl::unsupported::representation $r] 3 -} {arithseries} + set empty [lrange [lseq 1 100] 20 10] + list $r $empty [lindex [tcl::unsupported::representation $r] 3] +} {{11 12 13 14 15 16 17 18 19 20 21} {} arithseries} test lseq-3.9 {lassign lseq} arithSeriesShimmer { set r [lseq 15] @@ -510,6 +511,36 @@ test lseq-4.5 {lindex off by one} -body { unset res } -result {4 3} +# Bad refcount on ResultObj +test lseq-4.6 {lindex flat} -body { + set l [lseq 2 10] + set cmd lindex + set i 4 + set c [lindex $l $i] + set d [$cmd $l $i] + set e [lindex [lseq 2 10] $i] + set f [$cmd [lseq 2 10] $i] + list $c $d $e $f +} -cleanup { + unset l + unset e +} -result [lrepeat 4 6] + +test lseq-4.7 {empty list} { + list [lseq 0] [join [lseq 0] {}] [join [lseq 1] {}] +} {{} {} 0} + +test lseq-4.8 {error case lrange} -body { + lrange [lseq 1 5] fred ginger +} -returnCodes 1 \ + -result {bad index "fred": must be integer?[+-]integer? or end?[+-]integer?} + +test lseq-4.9 {error case lrange} -body { + set fred 7 + set ginger 8 + lrange [lseq 1 5] $fred $ginger +} -returnCodes 1 \ + -result {index 7 is out of bounds 0 to 4} # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 4d9dcbbcbc557a5b15e79a8b05e5b0b92230adcb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 1 Nov 2022 16:13:26 +0000 Subject: Two missing out-of-bound situations in TclIndexEncode(), one for index > MAX_INT, one for index < end-MAX_INT --- generic/tclUtil.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 1ac2b31..a361ba3 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3751,7 +3751,11 @@ TclIndexEncode( * We parsed an end+offset index value. * wide holds the offset value in the range WIDE_MIN...WIDE_MAX. */ - if (wide > (unsigned)(irPtr ? TCL_INDEX_END : INT_MAX)) { + if (!irPtr && (wide > INT_MAX)) { + return TCL_ERROR; + } else if (irPtr && (wide < INT_MIN)) { + return TCL_ERROR; + } else if (wide > (unsigned)(irPtr ? TCL_INDEX_END : INT_MAX)) { /* * All end+postive or end-negative expressions * always indicate "after the end". -- cgit v0.12 From 67319477f132908fc3f5241bece926457d7d4a5e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 1 Nov 2022 17:02:02 +0000 Subject: Bug-fix for TIP #502 implementation: Two missing out-of-bound situations in TclIndexEncode(), one for index > MAX_INT, one for index < end-MAX_INT --- generic/tclUtil.c | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index ab97461..4b9c120 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4068,7 +4068,11 @@ TclIndexEncode( * We parsed an end+offset index value. * wide holds the offset value in the range WIDE_MIN...WIDE_MAX. */ - if (wide > (unsigned)(irPtr ? TCL_INDEX_END : INT_MAX)) { + if (!irPtr && (wide > INT_MAX)) { + return TCL_ERROR; + } else if (irPtr && (wide < INT_MIN)) { + return TCL_ERROR; + } else if (wide > (unsigned)(irPtr ? TCL_INDEX_END : INT_MAX)) { /* * All end+postive or end-negative expressions * always indicate "after the end". -- cgit v0.12 From cbbee698745c4ddd1f5482cfca6cf73dab8fd953 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 1 Nov 2022 21:45:49 +0000 Subject: Backout previous change: test-cases are failing --- generic/tclUtil.c | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 4b9c120..ab97461 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -4068,11 +4068,7 @@ TclIndexEncode( * We parsed an end+offset index value. * wide holds the offset value in the range WIDE_MIN...WIDE_MAX. */ - if (!irPtr && (wide > INT_MAX)) { - return TCL_ERROR; - } else if (irPtr && (wide < INT_MIN)) { - return TCL_ERROR; - } else if (wide > (unsigned)(irPtr ? TCL_INDEX_END : INT_MAX)) { + if (wide > (unsigned)(irPtr ? TCL_INDEX_END : INT_MAX)) { /* * All end+postive or end-negative expressions * always indicate "after the end". -- cgit v0.12 From 954b5db3bb10738fab8a1b20e69b0a47c4c3a55a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 2 Nov 2022 08:02:00 +0000 Subject: Make robust against TIP #288 proposed change --- generic/tclOOScript.h | 4 ++-- tools/tclOOScript.tcl | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index a1e4624..f2e99b0 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -116,7 +116,7 @@ static const char *tclOOSetupScript = "\t\t\t\t}]\n" "\t\t}\n" "\t}\n" -"\tproc define::classmethod {name {args {}} {body {}}} {\n" +"\tproc define::classmethod {name args} {\n" "\t\t::set argc [::llength [::info level 0]]\n" "\t\t::if {$argc == 3} {\n" "\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n" @@ -125,7 +125,7 @@ static const char *tclOOSetupScript = "\t\t}\n" "\t\t::set cls [::uplevel 1 self]\n" "\t\t::if {$argc == 4} {\n" -"\t\t\t::oo::define [::oo::DelegateName $cls] method $name $args $body\n" +"\t\t\t::oo::define [::oo::DelegateName $cls] method $name {*}$args\n" "\t\t}\n" "\t\t::tailcall forward $name myclass $name\n" "\t}\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 10d3bf8..941f15c 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -195,7 +195,7 @@ # # ---------------------------------------------------------------------- - proc define::classmethod {name {args {}} {body {}}} { + proc define::classmethod {name args} { # Create the method on the class if the caller gave arguments and body ::set argc [::llength [::info level 0]] ::if {$argc == 3} { @@ -205,7 +205,7 @@ } ::set cls [::uplevel 1 self] ::if {$argc == 4} { - ::oo::define [::oo::DelegateName $cls] method $name $args $body + ::oo::define [::oo::DelegateName $cls] method $name {*}$args } # Make the connection by forwarding ::tailcall forward $name myclass $name -- cgit v0.12 From 7b395ecf512b54237e5fd3b5c243fd6a58996711 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 2 Nov 2022 08:30:20 +0000 Subject: code cleanup (e.g. ProcGetIntRep -> ProcGetInternalRep, size_t -> Tcl_Size) --- generic/tclProc.c | 76 +++++++++++++++++++++++++++---------------------------- 1 file changed, 37 insertions(+), 39 deletions(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index acb520c..f5bd652 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -76,7 +76,7 @@ const Tcl_ObjType tclProcBodyType = { Tcl_StoreInternalRep((objPtr), &tclProcBodyType, &ir); \ } while (0) -#define ProcGetIntRep(objPtr, procPtr) \ +#define ProcGetInternalRep(objPtr, procPtr) \ do { \ const Tcl_ObjInternalRep *irPtr; \ irPtr = TclFetchInternalRep((objPtr), &tclProcBodyType); \ @@ -153,7 +153,7 @@ int Tcl_ProcObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - size_t objc, /* Number of arguments. */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; @@ -339,7 +339,7 @@ Tcl_ProcObjCmd( } if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) { - size_t numBytes; + Tcl_Size numBytes; procArgs +=4; while (*procArgs != '\0') { @@ -405,12 +405,12 @@ TclCreateProc( Interp *iPtr = (Interp *) interp; Proc *procPtr = NULL; - size_t i, numArgs; + Tcl_Size i, numArgs; CompiledLocal *localPtr = NULL; Tcl_Obj **argArray; int precompiled = 0, result; - ProcGetIntRep(bodyPtr, procPtr); + ProcGetInternalRep(bodyPtr, procPtr); if (procPtr != NULL) { /* * Because the body is a TclProProcBody, the actual body is already @@ -445,7 +445,7 @@ TclCreateProc( if (Tcl_IsShared(bodyPtr)) { const char *bytes; - size_t length; + Tcl_Size length; Tcl_Obj *sharedBodyPtr = bodyPtr; bytes = Tcl_GetStringFromObj(bodyPtr, &length); @@ -508,7 +508,7 @@ TclCreateProc( for (i = 0; i < numArgs; i++) { const char *argname, *argnamei, *argnamelast; - size_t fieldCount, nameLength; + Tcl_Size fieldCount, nameLength; Tcl_Obj **fieldValues; /* @@ -600,7 +600,7 @@ TclCreateProc( */ if (localPtr->defValuePtr != NULL) { - size_t tmpLength, valueLength; + Tcl_Size tmpLength, valueLength; const char *tmpPtr = Tcl_GetStringFromObj(localPtr->defValuePtr, &tmpLength); const char *value = Tcl_GetStringFromObj(fieldValues[1], &valueLength); @@ -865,7 +865,7 @@ badLevel: static int Uplevel_Callback( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -886,7 +886,7 @@ Uplevel_Callback( int Tcl_UplevelObjCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -920,7 +920,7 @@ TclNRUplevelObjCmd( return TCL_ERROR; } else if (!TclHasStringRep(objv[1]) && objc == 2) { int status; - size_t llength; + Tcl_Size llength; status = TclListObjLengthM(interp, objv[1], &llength); if (status == TCL_OK && llength > 1) { /* the first argument can't interpreted as a level. Avoid @@ -1247,7 +1247,7 @@ TclFreeLocalCache( Tcl_Interp *interp, LocalCache *localCachePtr) { - size_t i; + Tcl_Size i; Tcl_Obj **namePtrPtr = &localCachePtr->varName0; for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) { @@ -1267,8 +1267,8 @@ InitLocalCache( { Interp *iPtr = procPtr->iPtr; ByteCode *codePtr; - size_t localCt = procPtr->numCompiledLocals; - size_t numArgs = procPtr->numArgs, i = 0; + Tcl_Size localCt = procPtr->numCompiledLocals; + Tcl_Size numArgs = procPtr->numArgs, i = 0; Tcl_Obj **namePtr; Var *varPtr; @@ -1501,11 +1501,11 @@ InitArgsAndLocals( int TclPushProcCallFrame( - ClientData clientData, /* Record describing procedure to be + void *clientData, /* Record describing procedure to be * interpreted. */ Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ - size_t objc1, /* Count of number of arguments to this + Tcl_Size objc, /* Count of number of arguments to this * procedure. */ Tcl_Obj *const objv[], /* Argument value objects. */ int isLambda) /* 1 if this is a call by ApplyObjCmd: it @@ -1516,7 +1516,6 @@ TclPushProcCallFrame( CallFrame *framePtr, **framePtrPtr; int result; ByteCode *codePtr; - int objc = objc1; /* * If necessary (i.e. if we haven't got a suitable compilation already @@ -1597,7 +1596,7 @@ TclPushProcCallFrame( int TclObjInterpProc( - ClientData clientData, /* Record describing procedure to be + void *clientData, /* Record describing procedure to be * interpreted. */ Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ @@ -1614,7 +1613,7 @@ TclObjInterpProc( int TclNRInterpProc( - ClientData clientData, /* Record describing procedure to be + void *clientData, /* Record describing procedure to be * interpreted. */ Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ @@ -1633,7 +1632,7 @@ TclNRInterpProc( static int NRInterpProc2( - ClientData clientData, /* Record describing procedure to be + void *clientData, /* Record describing procedure to be * interpreted. */ Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ @@ -1652,7 +1651,7 @@ NRInterpProc2( static int ObjInterpProc2( - ClientData clientData, /* Record describing procedure to be + void *clientData, /* Record describing procedure to be * interpreted. */ Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ @@ -1691,7 +1690,7 @@ TclNRInterpProcCore( Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ Tcl_Obj *procNameObj, /* Procedure name for error reporting. */ - size_t skip1, /* Number of initial arguments to be skipped, + Tcl_Size skip, /* Number of initial arguments to be skipped, * i.e., words in the "command name". */ ProcErrorProc *errorProc) /* How to convert results from the script into * results of the overall procedure. */ @@ -1701,7 +1700,6 @@ TclNRInterpProcCore( int result; CallFrame *freePtr; ByteCode *codePtr; - int skip = skip1; result = InitArgsAndLocals(interp, skip); if (result != TCL_OK) { @@ -1716,7 +1714,7 @@ TclNRInterpProcCore( #if defined(TCL_COMPILE_DEBUG) if (tclTraceExec >= 1) { CallFrame *framePtr = iPtr->varFramePtr; - size_t i; + Tcl_Size i; if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { fprintf(stdout, "Calling lambda "); @@ -1734,9 +1732,9 @@ TclNRInterpProcCore( #ifdef USE_DTRACE if (TCL_DTRACE_PROC_ARGS_ENABLED()) { - size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; const char *a[10]; - size_t i; + Tcl_Size i; for (i = 0 ; i < 10 ; i++) { a[i] = (l < iPtr->varFramePtr->objc ? @@ -1755,7 +1753,7 @@ TclNRInterpProcCore( TclDecrRefCount(info); } if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { - size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ? TclGetString(iPtr->varFramePtr->objv[l]) : NULL, @@ -1763,7 +1761,7 @@ TclNRInterpProcCore( (Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1)); } if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { - size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ? TclGetString(iPtr->varFramePtr->objv[l]) : NULL, @@ -1786,7 +1784,7 @@ TclNRInterpProcCore( static int InterpProcNR2( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -1797,7 +1795,7 @@ InterpProcNR2( ProcErrorProc *errorProc = (ProcErrorProc *)data[1]; if (TCL_DTRACE_PROC_RETURN_ENABLED()) { - size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; TCL_DTRACE_PROC_RETURN(l < iPtr->varFramePtr->objc ? TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result); @@ -1820,7 +1818,7 @@ InterpProcNR2( done: if (TCL_DTRACE_PROC_RESULT_ENABLED()) { - size_t l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; Tcl_Obj *r = Tcl_GetObjResult(interp); TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ? @@ -2079,7 +2077,7 @@ MakeProcError( * messages and trace information. */ { unsigned int overflow, limit = 60; - size_t nameLen; + Tcl_Size nameLen; const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); @@ -2111,7 +2109,7 @@ MakeProcError( void TclProcDeleteProc( - ClientData clientData) /* Procedure to be deleted. */ + void *clientData) /* Procedure to be deleted. */ { Proc *procPtr = (Proc *)clientData; @@ -2350,7 +2348,7 @@ ProcBodyDup( Tcl_Obj *dupPtr) /* Target object for the duplication. */ { Proc *procPtr; - ProcGetIntRep(srcPtr, procPtr); + ProcGetInternalRep(srcPtr, procPtr); ProcSetIntRep(dupPtr, procPtr); } @@ -2380,7 +2378,7 @@ ProcBodyFree( { Proc *procPtr; - ProcGetIntRep(objPtr, procPtr); + ProcGetInternalRep(objPtr, procPtr); if (procPtr->refCount-- <= 1) { TclProcCleanupProc(procPtr); @@ -2443,7 +2441,7 @@ SetLambdaFromAny( const char *name; Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv; int isNew, result; - size_t objc; + Tcl_Size objc; CmdFrame *cfPtr = NULL; Proc *procPtr; @@ -2650,7 +2648,7 @@ TclGetLambdaFromObj( int Tcl_ApplyObjCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2729,7 +2727,7 @@ TclNRApplyObjCmd( static int ApplyNR2( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -2765,7 +2763,7 @@ MakeLambdaError( * messages and trace information. */ { unsigned int overflow, limit = 60; - size_t nameLen; + Tcl_Size nameLen; const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); -- cgit v0.12 From 6ab05e04d1c2e4d0a473c114f67d7a8f1cab4dbd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 2 Nov 2022 10:00:17 +0000 Subject: If CFLAGS contains -DTCL_NO_DEPRECATED, remove TclInitCompiledLocals. More code cleanup (backported from 9.0) --- generic/tclProc.c | 96 +++++++++++++++++++++++++++------------------------ generic/tclStubInit.c | 1 + 2 files changed, 52 insertions(+), 45 deletions(-) diff --git a/generic/tclProc.c b/generic/tclProc.c index 1644376..b8c324e 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -84,7 +84,7 @@ const Tcl_ObjType tclProcBodyType = { } while (0) /* - * The [upvar]/[uplevel] level reference type. Uses the longValue field + * The [upvar]/[uplevel] level reference type. Uses the wideValue field * to remember the integer value of a parsed # format. * * Uses the default behaviour throughout, and never disposes of the string @@ -151,9 +151,9 @@ static const Tcl_ObjType lambdaType = { #undef TclObjInterpProc int Tcl_ProcObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; @@ -339,7 +339,7 @@ Tcl_ProcObjCmd( } if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) { - int numBytes; + Tcl_Size numBytes; procArgs +=4; while (*procArgs != '\0') { @@ -405,10 +405,10 @@ TclCreateProc( Interp *iPtr = (Interp *) interp; Proc *procPtr = NULL; - int i, result, numArgs; + Tcl_Size i, numArgs; CompiledLocal *localPtr = NULL; Tcl_Obj **argArray; - int precompiled = 0; + int precompiled = 0, result; ProcGetInternalRep(bodyPtr, procPtr); if (procPtr != NULL) { @@ -445,7 +445,7 @@ TclCreateProc( if (Tcl_IsShared(bodyPtr)) { const char *bytes; - int length; + Tcl_Size length; Tcl_Obj *sharedBodyPtr = bodyPtr; bytes = TclGetStringFromObj(bodyPtr, &length); @@ -508,7 +508,7 @@ TclCreateProc( for (i = 0; i < numArgs; i++) { const char *argname, *argnamei, *argnamelast; - int fieldCount, nameLength; + Tcl_Size fieldCount, nameLength; Tcl_Obj **fieldValues; /* @@ -600,10 +600,9 @@ TclCreateProc( */ if (localPtr->defValuePtr != NULL) { - const char *tmpPtr = TclGetString(localPtr->defValuePtr); - size_t tmpLength = localPtr->defValuePtr->length; - const char *value = TclGetString(fieldValues[1]); - size_t valueLength = fieldValues[1]->length; + Tcl_Size tmpLength, valueLength; + const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, &tmpLength); + const char *value = TclGetStringFromObj(fieldValues[1], &valueLength); if ((valueLength != tmpLength) || memcmp(value, tmpPtr, tmpLength) != 0 @@ -866,7 +865,7 @@ badLevel: static int Uplevel_Callback( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -887,7 +886,7 @@ Uplevel_Callback( int Tcl_UplevelObjCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -897,7 +896,7 @@ Tcl_UplevelObjCmd( int TclNRUplevelObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -920,7 +919,8 @@ TclNRUplevelObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "?level? command ?arg ...?"); return TCL_ERROR; } else if (!TclHasStringRep(objv[1]) && objc == 2) { - int status ,llength; + int status; + Tcl_Size llength; status = TclListObjLengthM(interp, objv[1], &llength); if (status == TCL_OK && llength > 1) { /* the first argument can't interpreted as a level. Avoid @@ -1141,6 +1141,7 @@ ProcWrongNumArgs( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED void TclInitCompiledLocals( Tcl_Interp *interp, /* Current interpreter. */ @@ -1167,6 +1168,7 @@ TclInitCompiledLocals( InitResolvedLocals(interp, codePtr, varPtr, nsPtr); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -1299,7 +1301,7 @@ TclFreeLocalCache( Tcl_Interp *interp, LocalCache *localCachePtr) { - int i; + Tcl_Size i; Tcl_Obj **namePtrPtr = &localCachePtr->varName0; for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) { @@ -1319,8 +1321,8 @@ InitLocalCache( { Interp *iPtr = procPtr->iPtr; ByteCode *codePtr; - int localCt = procPtr->numCompiledLocals; - int numArgs = procPtr->numArgs, i = 0; + Tcl_Size localCt = procPtr->numCompiledLocals; + Tcl_Size numArgs = procPtr->numArgs, i = 0; Tcl_Obj **namePtr; Var *varPtr; @@ -1483,7 +1485,7 @@ InitArgsAndLocals( varPtr->flags = 0; if (defPtr && defPtr->flags & VAR_IS_ARGS) { - Tcl_Obj *listPtr = Tcl_NewListObj(argCt-i, argObjs+i); + Tcl_Obj *listPtr = Tcl_NewListObj((argCt>i)? argCt-i : 0, argObjs+i); varPtr->value.objPtr = listPtr; Tcl_IncrRefCount(listPtr); /* Local var is a reference. */ @@ -1553,11 +1555,11 @@ InitArgsAndLocals( int TclPushProcCallFrame( - ClientData clientData, /* Record describing procedure to be + void *clientData, /* Record describing procedure to be * interpreted. */ Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ - int objc, /* Count of number of arguments to this + Tcl_Size objc, /* Count of number of arguments to this * procedure. */ Tcl_Obj *const objv[], /* Argument value objects. */ int isLambda) /* 1 if this is a call by ApplyObjCmd: it @@ -1648,7 +1650,7 @@ TclPushProcCallFrame( int TclObjInterpProc( - ClientData clientData, /* Record describing procedure to be + void *clientData, /* Record describing procedure to be * interpreted. */ Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ @@ -1665,7 +1667,7 @@ TclObjInterpProc( int TclNRInterpProc( - ClientData clientData, /* Record describing procedure to be + void *clientData, /* Record describing procedure to be * interpreted. */ Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ @@ -1684,7 +1686,7 @@ TclNRInterpProc( static int NRInterpProc2( - ClientData clientData, /* Record describing procedure to be + void *clientData, /* Record describing procedure to be * interpreted. */ Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ @@ -1703,7 +1705,7 @@ NRInterpProc2( static int ObjInterpProc2( - ClientData clientData, /* Record describing procedure to be + void *clientData, /* Record describing procedure to be * interpreted. */ Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ @@ -1742,7 +1744,7 @@ TclNRInterpProcCore( Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ Tcl_Obj *procNameObj, /* Procedure name for error reporting. */ - int skip, /* Number of initial arguments to be skipped, + Tcl_Size skip, /* Number of initial arguments to be skipped, * i.e., words in the "command name". */ ProcErrorProc *errorProc) /* How to convert results from the script into * results of the overall procedure. */ @@ -1766,7 +1768,7 @@ TclNRInterpProcCore( #if defined(TCL_COMPILE_DEBUG) if (tclTraceExec >= 1) { CallFrame *framePtr = iPtr->varFramePtr; - int i; + Tcl_Size i; if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { fprintf(stdout, "Calling lambda "); @@ -1784,9 +1786,9 @@ TclNRInterpProcCore( #ifdef USE_DTRACE if (TCL_DTRACE_PROC_ARGS_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; const char *a[10]; - int i; + Tcl_Size i; for (i = 0 ; i < 10 ; i++) { a[i] = (l < iPtr->varFramePtr->objc ? @@ -1805,7 +1807,7 @@ TclNRInterpProcCore( TclDecrRefCount(info); } if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ? TclGetString(iPtr->varFramePtr->objv[l]) : NULL, @@ -1813,7 +1815,7 @@ TclNRInterpProcCore( (Tcl_Obj **)(iPtr->varFramePtr->objv + l + 1)); } if (TCL_DTRACE_PROC_ENTRY_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; TCL_DTRACE_PROC_ENTRY(l < iPtr->varFramePtr->objc ? TclGetString(iPtr->varFramePtr->objv[l]) : NULL, @@ -1836,7 +1838,7 @@ TclNRInterpProcCore( static int InterpProcNR2( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -1847,7 +1849,7 @@ InterpProcNR2( ProcErrorProc *errorProc = (ProcErrorProc *)data[1]; if (TCL_DTRACE_PROC_RETURN_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; TCL_DTRACE_PROC_RETURN(l < iPtr->varFramePtr->objc ? TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result); @@ -1870,7 +1872,7 @@ InterpProcNR2( done: if (TCL_DTRACE_PROC_RESULT_ENABLED()) { - int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; + Tcl_Size l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0; Tcl_Obj *r = Tcl_GetObjResult(interp); TCL_DTRACE_PROC_RESULT(l < iPtr->varFramePtr->objc ? @@ -2128,13 +2130,14 @@ MakeProcError( Tcl_Obj *procNameObj) /* Name of the procedure. Used for error * messages and trace information. */ { - int overflow, limit = 60, nameLen; + int overflow, limit = 60; + Tcl_Size nameLen; const char *procName = TclGetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (procedure \"%.*s%s\" line %d)", - (overflow ? limit : nameLen), procName, + (overflow ? limit : (int)nameLen), procName, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } @@ -2160,7 +2163,7 @@ MakeProcError( void TclProcDeleteProc( - ClientData clientData) /* Procedure to be deleted. */ + void *clientData) /* Procedure to be deleted. */ { Proc *procPtr = (Proc *)clientData; @@ -2317,7 +2320,8 @@ TclUpdateReturnInfo( * of a function exported by a DLL exist. * * Results: - * Returns the internal address of the TclObjInterpProc function. + * Returns the internal address of the TclObjInterpProc/ObjInterpProc2 + * functions. * * Side effects: * None. @@ -2490,7 +2494,8 @@ SetLambdaFromAny( Interp *iPtr = (Interp *) interp; const char *name; Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv; - int isNew, objc, result; + int isNew, result; + Tcl_Size objc; CmdFrame *cfPtr = NULL; Proc *procPtr; @@ -2697,7 +2702,7 @@ TclGetLambdaFromObj( int Tcl_ApplyObjCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2707,7 +2712,7 @@ Tcl_ApplyObjCmd( int TclNRApplyObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2776,7 +2781,7 @@ TclNRApplyObjCmd( static int ApplyNR2( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -2811,13 +2816,14 @@ MakeLambdaError( Tcl_Obj *procNameObj) /* Name of the procedure. Used for error * messages and trace information. */ { - int overflow, limit = 60, nameLen; + int overflow, limit = 60; + Tcl_Size nameLen; const char *procName = TclGetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (lambda term \"%.*s%s\" line %d)", - (overflow ? limit : nameLen), procName, + (overflow ? limit : (int)nameLen), procName, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 6d50a46..1ffe916 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -380,6 +380,7 @@ mp_err TclBN_mp_mul_d(const mp_int *a, unsigned int b, mp_int *c) { # define TclGetLoadedPackages 0 # undef TclSetPreInitScript # define TclSetPreInitScript 0 +# define TclInitCompiledLocals 0 #else #define TclGuessPackageName guessPackageName -- cgit v0.12 From 366778e86ecc27d557a56047f3f6d12439f67cf8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 2 Nov 2022 13:18:42 +0000 Subject: Fix [00cced7b87]: Incorrect handling of indices > 0x80000000 in byte compiler (64-bit Tcl) --- generic/tclUtil.c | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 1ac2b31..577c45a 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3751,7 +3751,17 @@ TclIndexEncode( * We parsed an end+offset index value. * wide holds the offset value in the range WIDE_MIN...WIDE_MAX. */ - if (wide > (unsigned)(irPtr ? TCL_INDEX_END : INT_MAX)) { + if (irPtr ? ((wide < INT_MIN) && ((size_t)-wide <= LIST_MAX)) + : ((wide > INT_MAX) && ((size_t)wide <= LIST_MAX))) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "index \"%s\" out of range", + TclGetString(objPtr))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" + "OUTOFRANGE", NULL); + } + return TCL_ERROR; + } else if (wide > (unsigned)(irPtr ? TCL_INDEX_END : INT_MAX)) { /* * All end+postive or end-negative expressions * always indicate "after the end". -- cgit v0.12 From 0dfd2bdc9def2f625b73fa3f8ca501d68ab24f98 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 2 Nov 2022 15:56:42 +0000 Subject: Bug #0f98bce669 - string repeat support for > 2**31 characters --- generic/tcl.h | 5 +++-- generic/tclCmdMZ.c | 4 ++-- generic/tclStringObj.c | 22 +++++++++++++++++----- 3 files changed, 22 insertions(+), 9 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index cb781a6..be39d2f 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -664,10 +664,11 @@ typedef union Tcl_ObjInternalRep { /* The internal representation: */ * or both. */ #if TCL_MAJOR_VERSION > 8 -# define Tcl_Size size_t +typedef size_t Tcl_Size; #else -# define Tcl_Size int +typedef int Tcl_Size; #endif +#define TCL_SIZE_SMAX ((((Tcl_Size) 1) << ((8*sizeof(Tcl_Size)) - 1)) - 1) typedef struct Tcl_Obj { diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 8a08f53..83e5647 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2337,7 +2337,7 @@ StringReptCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int count; + Tcl_WideInt count; Tcl_Obj *resultPtr; if (objc != 3) { @@ -2345,7 +2345,7 @@ StringReptCmd( return TCL_ERROR; } - if (TclGetIntFromObj(interp, objv[2], &count) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[2], &count) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index cf23aab..60dfa4d 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2933,6 +2933,7 @@ TclStringRepeat( int inPlace = flags & TCL_STRING_IN_PLACE; size_t length = 0, unichar = 0, done = 1; int binary = TclIsPureByteArray(objPtr); + size_t maxCount; /* assert (count >= 2) */ @@ -2955,12 +2956,17 @@ TclStringRepeat( if (binary) { /* Result will be pure byte array. Pre-size it */ (void)Tcl_GetByteArrayFromObj(objPtr, &length); - } else if (unichar) { + maxCount = TCL_SIZE_SMAX; + } + else if (unichar) { /* Result will be pure Tcl_UniChar array. Pre-size it. */ (void)Tcl_GetUnicodeFromObj(objPtr, &length); - } else { + maxCount = TCL_SIZE_SMAX/sizeof(Tcl_UniChar); + } + else { /* Result will be concat of string reps. Pre-size it. */ (void)Tcl_GetStringFromObj(objPtr, &length); + maxCount = TCL_SIZE_SMAX; } if (length == 0) { @@ -2968,10 +2974,14 @@ TclStringRepeat( return objPtr; } - if (count > INT_MAX/length) { + /* maxCount includes space for null */ + if (count > (maxCount-1)) { if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("max size for a Tcl value (%u" TCL_Z_MODIFIER + " bytes) exceeded", + TCL_SIZE_SMAX)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } return NULL; @@ -2982,6 +2992,7 @@ TclStringRepeat( objResultPtr = (!inPlace || Tcl_IsShared(objPtr)) ? Tcl_DuplicateObj(objPtr) : objPtr; + /* Allocate count*length space */ Tcl_SetByteArrayLength(objResultPtr, count*length); /* PANIC? */ Tcl_SetByteArrayLength(objResultPtr, length); while (count - done > done) { @@ -3049,6 +3060,7 @@ TclStringRepeat( (count - done) * length); } return objResultPtr; + } /* -- cgit v0.12 From 3920a8f42ae243f7c84d2101438263da7583793b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 2 Nov 2022 16:02:07 +0000 Subject: Fix [d2c2baac2]: Tcl 9 32-bit build exits immediately with stack overflow on Windows --- generic/tclDecls.h | 2 +- generic/tclStubInit.c | 7 +++++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 56cd7e8..273e2e1 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4159,7 +4159,7 @@ extern const TclStubs *tclStubsPtr; # define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) == sizeof(int) \ ? tclStubsPtr->tclParseArgsObjv((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv)) \ : tclStubsPtr->tcl_ParseArgsObjv((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv))) -#else +#elif !defined(BUILD_tcl) # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ ? (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_UniCharToUtfDString \ : (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_Char16ToUtfDString) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 4b13d06..4b2fd30 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -55,6 +55,13 @@ #undef TclSockMinimumBuffers #undef Tcl_SetIntObj #undef Tcl_SetLongObj +#undef Tcl_ListObjGetElements +#undef Tcl_ListObjLength +#undef Tcl_DictObjSize +#undef Tcl_SplitList +#undef Tcl_SplitPath +#undef Tcl_FSSplitPath +#undef Tcl_ParseArgsObjv #undef TclpInetNtoa #undef TclWinGetServByName #undef TclWinGetSockOpt -- cgit v0.12 From 330034ec028701d182ab255424084a9a5a9b5499 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 2 Nov 2022 16:20:27 +0000 Subject: Make Tcl_WCharToUtfDString() usable (again) on Windows. Was lost due to previous commit --- generic/tclDecls.h | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 273e2e1..8040adf 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4159,7 +4159,7 @@ extern const TclStubs *tclStubsPtr; # define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) == sizeof(int) \ ? tclStubsPtr->tclParseArgsObjv((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv)) \ : tclStubsPtr->tcl_ParseArgsObjv((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv))) -#elif !defined(BUILD_tcl) +#else # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ ? (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_UniCharToUtfDString \ : (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_Char16ToUtfDString) @@ -4172,6 +4172,7 @@ extern const TclStubs *tclStubsPtr; # define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ ? (Tcl_Size (*)(wchar_t *))Tcl_UniCharLen \ : (Tcl_Size (*)(wchar_t *))Tcl_Char16Len) +#if !defined(BUILD_tcl) # define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) == sizeof(int) \ ? TclListObjGetElements((interp), (listPtr), (int *)(void *)(objcPtr), (objvPtr)) \ : (Tcl_ListObjGetElements)((interp), (listPtr), (size_t *)(void *)(objcPtr), (objvPtr))) @@ -4193,6 +4194,7 @@ extern const TclStubs *tclStubsPtr; # define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) == sizeof(int) \ ? TclParseArgsObjv((interp), (argTable), (int *)(void *)(objcPtr), (objv), (remObjv)) \ : (Tcl_ParseArgsObjv)((interp), (argTable), (size_t *)(void *)(objcPtr), (objv), (remObjv))) +#endif /* !defined(BUILD_tcl) */ #endif /* -- cgit v0.12 From 59ee35fd388827c8ca20bf08a63bd827a42519ec Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 2 Nov 2022 16:25:59 +0000 Subject: Fix testcase failure (assemble-15.9), only seen on 32-bit --- generic/tclUtil.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 577c45a..92dac30 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3751,8 +3751,8 @@ TclIndexEncode( * We parsed an end+offset index value. * wide holds the offset value in the range WIDE_MIN...WIDE_MAX. */ - if (irPtr ? ((wide < INT_MIN) && ((size_t)-wide <= LIST_MAX)) - : ((wide > INT_MAX) && ((size_t)wide <= LIST_MAX))) { + if ((irPtr ? ((wide < INT_MIN) && ((size_t)-wide <= LIST_MAX)) + : ((wide > INT_MAX) && ((size_t)wide <= LIST_MAX))) && (sizeof(int) != sizeof(size_t))) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "index \"%s\" out of range", -- cgit v0.12 From 5a3d2ddfede6842bc089bd78d0c80fad82f911b0 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 2 Nov 2022 16:28:59 +0000 Subject: Bug #0f98bce669 - string cat support for > 2**31 characters. Tests pending --- generic/tcl.h | 1 - generic/tclInt.h | 5 +++++ generic/tclStringObj.c | 14 ++++++++++---- 3 files changed, 15 insertions(+), 5 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index be39d2f..706c5f1 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -668,7 +668,6 @@ typedef size_t Tcl_Size; #else typedef int Tcl_Size; #endif -#define TCL_SIZE_SMAX ((((Tcl_Size) 1) << ((8*sizeof(Tcl_Size)) - 1)) - 1) typedef struct Tcl_Obj { diff --git a/generic/tclInt.h b/generic/tclInt.h index a7985f7..39ddef2 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -105,6 +105,11 @@ #endif /* + * Maximum *signed* value that can be stored in a Tcl_Size type. + */ +#define TCL_SIZE_SMAX ((((Tcl_Size) 1) << ((8*sizeof(Tcl_Size)) - 1)) - 1) + +/* * Macros used to cast between pointers and integers (e.g. when storing an int * in ClientData), on 64-bit architectures they avoid gcc warning about "cast * to/from pointer from/to integer of different size". diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 60dfa4d..008ece9 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -3089,7 +3089,7 @@ TclStringCat( { Tcl_Obj *objResultPtr, * const *ov; int oc, binary = 1; - size_t length = 0; + size_t length = 0; int allowUniChar = 1, requestUniChar = 0, forceUniChar = 0; int first = objc - 1; /* Index of first value possibly not empty */ int last = 0; /* Index of last value possibly not empty */ @@ -3171,6 +3171,9 @@ TclStringCat( if (length == 0) { first = last; } + if (length > (TCL_SIZE_SMAX-numBytes)) { + goto overflow; + } length += numBytes; } } @@ -3194,6 +3197,9 @@ TclStringCat( if (length == 0) { first = last; } + if (length > ((TCL_SIZE_SMAX/sizeof(Tcl_UniChar))-numChars)) { + goto overflow; + } length += numChars; } } @@ -3258,7 +3264,7 @@ TclStringCat( if (numBytes) { first = last; } - } else if (numBytes + length > (size_t)INT_MAX) { + } else if (numBytes > (TCL_SIZE_SMAX - length)) { goto overflow; } length += numBytes; @@ -3275,7 +3281,7 @@ TclStringCat( numBytes = objPtr->length; if (numBytes) { last = objc - oc; - if (numBytes + length > (size_t)INT_MAX) { + if (numBytes > (TCL_SIZE_SMAX - length)) { goto overflow; } length += numBytes; @@ -3434,7 +3440,7 @@ TclStringCat( overflow: if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); + "max size for a Tcl value (%u" TCL_Z_MODIFIER " bytes) exceeded", TCL_SIZE_SMAX)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } return NULL; -- cgit v0.12 From 9cc14dacd9e5389835ce195da4375592572f5a45 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 3 Nov 2022 08:15:19 +0000 Subject: Fix formatting of error-message --- generic/tclStringObj.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 008ece9..f8b795e 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2979,8 +2979,8 @@ TclStringRepeat( if (interp) { Tcl_SetObjResult( interp, - Tcl_ObjPrintf("max size for a Tcl value (%u" TCL_Z_MODIFIER - " bytes) exceeded", + Tcl_ObjPrintf("max size for a Tcl value (%" TCL_Z_MODIFIER + "u bytes) exceeded", TCL_SIZE_SMAX)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } @@ -3440,7 +3440,7 @@ TclStringCat( overflow: if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max size for a Tcl value (%u" TCL_Z_MODIFIER " bytes) exceeded", TCL_SIZE_SMAX)); + "max size for a Tcl value (%" TCL_Z_MODIFIER "u bytes) exceeded", TCL_SIZE_SMAX)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } return NULL; -- cgit v0.12 From 6559f4084e844e187198c5471bfd15f19c8dfecc Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 3 Nov 2022 12:26:41 +0000 Subject: Bug [0f98bce669]. Fix limits for string replace. --- generic/tclCmdMZ.c | 3 +++ generic/tclInt.h | 3 ++- generic/tclStringObj.c | 8 ++++---- 3 files changed, 9 insertions(+), 5 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 83e5647..f94d914 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2437,6 +2437,9 @@ StringRplcCmd( last + 1 - first, (objc == 5) ? objv[4] : NULL, TCL_STRING_IN_PLACE); + if (resultPtr == NULL) { + return TCL_ERROR; + } Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; diff --git a/generic/tclInt.h b/generic/tclInt.h index 39ddef2..a17ce7d 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -105,7 +105,8 @@ #endif /* - * Maximum *signed* value that can be stored in a Tcl_Size type. + * Maximum *signed* value that can be stored in a Tcl_Size type. This is + * primarily used for checking overflows in dynamically allocating memory. */ #define TCL_SIZE_SMAX ((((Tcl_Size) 1) << ((8*sizeof(Tcl_Size)) - 1)) - 1) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index f8b795e..7c0d626 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -4100,11 +4100,11 @@ TclStringReplace( return objPtr; } - if ((size_t)newBytes > INT_MAX - (numBytes - count)) { + if (newBytes > (TCL_SIZE_SMAX - (numBytes - count))) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max size for a Tcl value (%d bytes) exceeded", - INT_MAX)); + "max size for a Tcl value (%" TCL_Z_MODIFIER "u bytes) exceeded", + TCL_SIZE_SMAX)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } return NULL; @@ -4139,7 +4139,7 @@ TclStringReplace( if (insertPtr) { Tcl_AppendObjToObj(result, insertPtr); } - if (first + count < (size_t)numChars) { + if ((first + count) < numChars) { Tcl_AppendUnicodeToObj(result, ustring + first + count, numChars - first - count); } -- cgit v0.12 From f768eb3bf2d09ebf310ed07f664dc114e1c1412d Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 3 Nov 2022 17:04:07 +0000 Subject: Rewrite lreplace4 implementation not to need extra immediate operands. --- generic/tclBasic.c | 2 +- generic/tclCompCmdsGR.c | 210 +++++++++--------------------------------------- generic/tclCompile.c | 13 +-- generic/tclCompile.h | 10 ++- generic/tclExecute.c | 129 ++++++++++++++++++----------- generic/tclInt.h | 3 - 6 files changed, 135 insertions(+), 232 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index a1eb4cc..80dc416 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -310,7 +310,7 @@ static const CmdInfo builtInCmds[] = { {"join", Tcl_JoinObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE}, {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE}, - {"ledit", Tcl_LeditObjCmd, TclCompileLeditCmd, NULL, CMD_IS_SAFE}, + {"ledit", Tcl_LeditObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE}, {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE}, {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index bf6288a..2681d01 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -1036,124 +1036,6 @@ TclCompileLassignCmd( /* *---------------------------------------------------------------------- * - * TclCompileLeditCmd -- - * - * How to compile the "ledit" command. We only bother with the case - * where the index is constant. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileLeditCmd( - Tcl_Interp *interp, /* Tcl interpreter for context. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the - * command. */ - TCL_UNUSED(Command *), - CompileEnv *envPtr) /* Holds the resulting instructions. */ -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr, *varTokenPtr; - int localIndex; /* Index of var in local var table. */ - int isScalar; /* Flag == 1 if scalar, 0 if array. */ - int tempDepth; /* Depth used for emitting one part of the - * code burst. */ - int first, last, i, end_indicator; - - if (parsePtr->numWords < 4) { - return TCL_ERROR; - } - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - - tokenPtr = TokenAfter(varTokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE, - &first) != TCL_OK) { - return TCL_ERROR; - } - - tokenPtr = TokenAfter(tokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_NONE, TCL_INDEX_END, - &last) != TCL_OK) { - return TCL_ERROR; - } - end_indicator = 1; /* "end" means last element by default */ - if (first == (int)TCL_INDEX_NONE) { - /* first == TCL_INDEX_NONE => Range after last element. */ - first = TCL_INDEX_END; /* Insert at end where ... */ - end_indicator = 0; /* ... end means AFTER last element */ - last = TCL_INDEX_NONE; /* Informs lreplace, nothing to replace */ - } - - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); - - /* Duplicate the variable name if it's been pushed. */ - if (localIndex < 0) { - if (isScalar) { - tempDepth = 0; - } else { - tempDepth = 1; - } - TclEmitInstInt4(INST_OVER, tempDepth, envPtr); - } - - /* Duplicate an array index if one's been pushed. */ - if (!isScalar) { - if (localIndex < 0) { - tempDepth = 1; - } else { - tempDepth = parsePtr->numWords - 2; - } - TclEmitInstInt4(INST_OVER, tempDepth, envPtr); - } - - /* Emit code to load the variable's value. */ - if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode(INST_LOAD_STK, envPtr); - } else { - Emit14Inst(INST_LOAD_SCALAR, localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); - } else { - Emit14Inst(INST_LOAD_ARRAY, localIndex, envPtr); - } - } - - for (i=4 ; inumWords ; ++i) { - tokenPtr = TokenAfter(tokenPtr); - CompileWord(envPtr, tokenPtr, interp, i); - } - - TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 3, envPtr); - TclEmitInt4(end_indicator, envPtr); - TclEmitInt4(first, envPtr); - TclEmitInt4(last, envPtr); - - /* Emit code to put the value back in the variable. */ - - if (isScalar) { - if (localIndex < 0) { - TclEmitOpcode(INST_STORE_STK, envPtr); - } else { - Emit14Inst(INST_STORE_SCALAR, localIndex, envPtr); - } - } else { - if (localIndex < 0) { - TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr); - } else { - Emit14Inst(INST_STORE_ARRAY, localIndex, envPtr); - } - } - - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * TclCompileLindexCmd -- * * Procedure called to compile the "lindex" command. @@ -1473,42 +1355,34 @@ TclCompileLinsertCmd( CompileEnv *envPtr) /* Holds the resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr, *listTokenPtr; - int idx, i; + Tcl_Token *tokenPtr; + int i; if (parsePtr->numWords < 3) { return TCL_ERROR; } - listTokenPtr = TokenAfter(parsePtr->tokenPtr); - - tokenPtr = TokenAfter(listTokenPtr); - - /* - * This command treats all inserts at indices before the list - * the same as inserts at the start of the list, and all inserts - * after the list the same as inserts at the end of the list. We - * make that transformation here so we can use the optimized bytecode - * as much as possible. - */ - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_END, &idx) - != TCL_OK) { - /* Not a constant index. */ - return TCL_ERROR; - } - - CompileWord(envPtr, listTokenPtr, interp, 1); + + /* Push list, insertion index onto the stack */ + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 2); + /* Push new elements to be inserted */ for (i=3 ; inumWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } - /* First operand is count of new elements */ - TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 2, envPtr); - TclEmitInt4(0, envPtr); /* "end" refers to position AFTER last element */ - TclEmitInt4(idx, envPtr);/* Insertion point (also start of range to delete) */ - TclEmitInt4(TCL_INDEX_NONE, envPtr); /* End of range to delete. - TCL_INDEX_NONE => no deletions */ + /* First operand is count of arguments */ + TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 1, envPtr); + /* + * Second operand is bitmask + * TCL_LREPLACE4_END_IS_LAST - end refers to last element + * TCL_LREPLACE4_SINGLE_INDEX - second index is not present + * indicating this is a pure insert + */ + TclEmitInt1(TCL_LREPLACE4_SINGLE_INDEX, envPtr); return TCL_OK; } @@ -1533,46 +1407,38 @@ TclCompileLreplaceCmd( CompileEnv *envPtr) /* Holds the resulting instructions. */ { DefineLineInformation; /* TIP #280 */ - Tcl_Token *tokenPtr, *listTokenPtr; - int first, last, i, end_indicator; + Tcl_Token *tokenPtr; + int i; if (parsePtr->numWords < 4) { return TCL_ERROR; } - listTokenPtr = TokenAfter(parsePtr->tokenPtr); - - tokenPtr = TokenAfter(listTokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE, - &first) != TCL_OK) { - return TCL_ERROR; - } + /* Push list, first, last onto the stack */ + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); tokenPtr = TokenAfter(tokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_NONE, TCL_INDEX_END, - &last) != TCL_OK) { - return TCL_ERROR; - } - end_indicator = 1; /* "end" means last element by default */ - if (first == (int)TCL_INDEX_NONE) { - /* Special case: first == TCL_INDEX_NONE => Range after last element. */ - first = TCL_INDEX_END; /* Insert at end where ... */ - end_indicator = 0; /* ... end means AFTER last element */ - last = TCL_INDEX_NONE; /* Informs lreplace, nothing to replace */ - } - - CompileWord(envPtr, listTokenPtr, interp, 1); + CompileWord(envPtr, tokenPtr, interp, 2); + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 3); + /* Push new elements to be inserted */ for (i=4 ; inumWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } - TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 3, envPtr); - TclEmitInt4(end_indicator, envPtr); - TclEmitInt4(first, envPtr); - TclEmitInt4(last, envPtr); - return TCL_OK;} - + /* First operand is count of arguments */ + TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 1, envPtr); + /* + * Second operand is bitmask + * TCL_LREPLACE4_END_IS_LAST - end refers to last element + */ + TclEmitInt1(TCL_LREPLACE4_END_IS_LAST, envPtr); + + return TCL_OK; +} + /* *---------------------------------------------------------------------- * diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 57e2d71..2dd0718 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -675,12 +675,13 @@ InstructionDesc const tclInstructionTable[] = { /* String Less or equal: push (stknext <= stktop) */ {"strge", 1, -1, 0, {OPERAND_NONE}}, /* String Greater or equal: push (stknext >= stktop) */ - {"lreplace4", 17, INT_MIN, 4, {OPERAND_UINT4, OPERAND_UINT4, OPERAND_INT4, OPERAND_INT4}}, - /* Operands: number of arguments, end_indicator, firstIdx, lastIdx - * end_indicator: 1 if "end" is treated as index of last element, - * 0 if "end" is position after last element - * firstIdx,lastIdx: range of elements to delete - * Stack: ... listobj new1 ... newN => ... newlistobj */ + {"lreplace4", 6, INT_MIN, 2, {OPERAND_UINT4, OPERAND_UINT1}}, + /* Operands: number of arguments, flags + * flags: Combination of TCL_LREPLACE4_* flags + * Stack: ... listobj index1 ?index2? new1 ... newN => ... newlistobj + * where index2 is present only if TCL_LREPLACE_SINGLE_INDEX is not + * set in flags. + */ {NULL, 0, 0, 0, {OPERAND_NONE}} }; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 9633050..71ceede 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -848,7 +848,7 @@ typedef struct ByteCode { #define INST_STR_LE 193 #define INST_STR_GE 194 -#define INST_LREPLACE4 195 +#define INST_LREPLACE4 195 /* The last opcode */ #define LAST_INST_OPCODE 195 @@ -862,7 +862,7 @@ typedef struct ByteCode { * instruction. */ -#define MAX_INSTRUCTION_OPERANDS 4 +#define MAX_INSTRUCTION_OPERANDS 2 typedef enum InstOperandType { OPERAND_NONE, @@ -1685,6 +1685,12 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, #define TCL_NO_ELEMENT 2 /* Do not push the array element. */ /* + * Flags bits used by lreplace4 instruction + */ +#define TCL_LREPLACE4_END_IS_LAST 1 /* "end" refers to last element */ +#define TCL_LREPLACE4_SINGLE_INDEX 2 /* Second index absent (pure insert) */ + +/* * DTrace probe macros (NOPs if DTrace support is not enabled). */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 2713093..a8d9d57 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5246,61 +5246,94 @@ TEBCresume( case INST_LREPLACE4: { - int firstIdx, lastIdx, numToDelete, numNewElems, end_indicator; - opnd = TclGetInt4AtPtr(pc + 1); - end_indicator = TclGetInt4AtPtr(pc + 5); - firstIdx = TclGetInt4AtPtr(pc + 9); - lastIdx = TclGetInt4AtPtr(pc + 13); - numNewElems = opnd - 1; - valuePtr = OBJ_AT_DEPTH(numNewElems); - if (Tcl_ListObjLength(interp, valuePtr, &length) != TCL_OK) { + int numToDelete, numNewElems, end_indicator; + int haveSecondIndex, flags; + Tcl_Obj *fromIdxObj, *toIdxObj; + opnd = TclGetInt4AtPtr(pc + 1); + flags = TclGetInt1AtPtr(pc + 5); + + /* Stack: ... listobj index1 ?index2? new1 ... newN */ + valuePtr = OBJ_AT_DEPTH(opnd-1); + + /* haveSecondIndex==0 => pure insert */ + haveSecondIndex = (flags & TCL_LREPLACE4_SINGLE_INDEX) == 0; + numNewElems = opnd - 2 - haveSecondIndex; + + /* end_indicator==1 => "end" is last element's index, 0=>index beyond */ + end_indicator = (flags & TCL_LREPLACE4_END_IS_LAST) != 0; + fromIdxObj = OBJ_AT_DEPTH(opnd - 2); + toIdxObj = haveSecondIndex ? OBJ_AT_DEPTH(opnd - 3) : NULL; + if (Tcl_ListObjLength(interp, valuePtr, &length) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + + DECACHE_STACK_INFO(); + + if (TclGetIntForIndexM( + interp, fromIdxObj, length - end_indicator, &fromIdx) + != TCL_OK) { + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; + } + if (fromIdx == TCL_INDEX_NONE) { + fromIdx = 0; + } + else if (fromIdx > length) { + fromIdx = length; + } + numToDelete = 0; + if (toIdxObj) { + if (TclGetIntForIndexM( + interp, toIdxObj, length - end_indicator, &toIdx) + != TCL_OK) { + CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } - firstIdx = TclIndexDecode(firstIdx, length-end_indicator); - if (firstIdx == TCL_INDEX_NONE) { - firstIdx = 0; - } else if (firstIdx > length) { - firstIdx = length; - } - numToDelete = 0; - if (lastIdx != TCL_INDEX_NONE) { - lastIdx = TclIndexDecode(lastIdx, length - end_indicator); - if (lastIdx >= firstIdx) { - numToDelete = lastIdx - firstIdx + 1; - } + if (toIdx > length) { + toIdx = length; } - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_DuplicateObj(valuePtr); - if (Tcl_ListObjReplace(interp, - objResultPtr, - firstIdx, - numToDelete, - numNewElems, - &OBJ_AT_DEPTH(numNewElems-1)) - != TCL_OK) { - TRACE_ERROR(interp); - Tcl_DecrRefCount(objResultPtr); - goto gotError; - } - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - NEXT_INST_V(17, opnd, 1); - } else { - if (Tcl_ListObjReplace(interp, - valuePtr, - firstIdx, - numToDelete, - numNewElems, - &OBJ_AT_DEPTH(numNewElems-1)) - != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); - NEXT_INST_V(17, opnd-1, 0); + if (toIdx >= fromIdx) { + numToDelete = toIdx - fromIdx + 1; } } + CACHE_STACK_INFO(); + + if (Tcl_IsShared(valuePtr)) { + objResultPtr = Tcl_DuplicateObj(valuePtr); + if (Tcl_ListObjReplace(interp, + objResultPtr, + fromIdx, + numToDelete, + numNewElems, + &OBJ_AT_DEPTH(numNewElems - 1)) + != TCL_OK) { + TRACE_ERROR(interp); + Tcl_DecrRefCount(objResultPtr); + goto gotError; + } + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); + NEXT_INST_V(6, opnd, 1); + } + else { + if (Tcl_ListObjReplace(interp, + valuePtr, + fromIdx, + numToDelete, + numNewElems, + &OBJ_AT_DEPTH(numNewElems - 1)) + != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); + NEXT_INST_V(6, opnd - 1, 0); + } + } + /* * End of INST_LIST and related instructions. * ----------------------------------------------------------------- diff --git a/generic/tclInt.h b/generic/tclInt.h index 5c977e5..a67c8f9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3759,9 +3759,6 @@ MODULE_SCOPE int TclCompileLappendCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileLassignCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -MODULE_SCOPE int TclCompileLeditCmd(Tcl_Interp *interp, - Tcl_Parse *parsePtr, Command *cmdPtr, - struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLindexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); -- cgit v0.12 From b07c7ad8aea461d1e2e16c66029fbaa43d05d54c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 6 Nov 2022 20:27:51 +0000 Subject: Update Tcl_Filesystem documentation --- ChangeLog.2008 | 2 +- doc/FileSystem.3 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ChangeLog.2008 b/ChangeLog.2008 index 9c4e951..53690e4 100644 --- a/ChangeLog.2008 +++ b/ChangeLog.2008 @@ -1939,7 +1939,7 @@ 2008-07-28 Jan Nijtmans * doc/FileSystem.3: CONSTified many functions using - * generic/tcl.decls: Tcl_FileSystem which all are supposed + * generic/tcl.decls: Tcl_Filesystem which all are supposed * generic/tclDecls.h: to be a constant, but this was not * generic/tclFileSystem.h: reflected in the API: Tcl_FSData, * generic/tclIOUtil.c: Tcl_FSGetInternalRep, Tcl_FSRegister, diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index 239ff0f..469af22 100644 --- a/doc/FileSystem.3 +++ b/doc/FileSystem.3 @@ -850,7 +850,7 @@ The \fBTcl_Filesystem\fR structure contains the following fields: .CS typedef struct Tcl_Filesystem { const char *\fItypeName\fR; - int \fIstructureLength\fR; + size_t \fIstructureLength\fR; Tcl_FSVersion \fIversion\fR; Tcl_FSPathInFilesystemProc *\fIpathInFilesystemProc\fR; Tcl_FSDupInternalRepProc *\fIdupInternalRepProc\fR; -- cgit v0.12 From fac57136f20a8c4ace9517a25a77be701705827e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 6 Nov 2022 21:01:12 +0000 Subject: Remove TclpHasSockets(): Every system nowadays has sockets --- generic/tclIOCmd.c | 4 +- generic/tclInt.decls | 7 +- generic/tclInt.h | 1 + generic/tclIntDecls.h | 8 +- generic/tclStubInit.c | 2 +- unix/tclUnixSock.c | 23 ------ win/tclWinSock.c | 216 ++++++++++---------------------------------------- 7 files changed, 51 insertions(+), 210 deletions(-) diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index e706f40..4ce27bb 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -1455,9 +1455,7 @@ Tcl_SocketObjCmd( Tcl_Obj *script = NULL; Tcl_Channel chan; - if (TclpHasSockets(interp) != TCL_OK) { - return TCL_ERROR; - } + TclInitSockets(); for (a = 1; a < objc; a++) { const char *arg = TclGetString(objv[a]); diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 1bd462d..d9bd5c5 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -330,9 +330,10 @@ declare 131 { Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } -declare 132 { - int TclpHasSockets(Tcl_Interp *interp) -} +# Removed in 9.0: +#declare 132 { +# int TclpHasSockets(Tcl_Interp *interp) +#} # Removed in 9.0: #declare 133 { # struct tm *TclpGetDate(const time_t *time, int useGMT) diff --git a/generic/tclInt.h b/generic/tclInt.h index a17ce7d..dbe44b5 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3276,6 +3276,7 @@ MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); MODULE_SCOPE void TclpFinalizeNotifier(void *clientData); MODULE_SCOPE void TclpFinalizePipes(void); MODULE_SCOPE void TclpFinalizeSockets(void); +MODULE_SCOPE void TclInitSockets(void); MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, struct addrinfo **addrlist, const char *host, int port, int willBind, diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index b84b996..eaa7d95 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -292,8 +292,7 @@ EXTERN void Tcl_SetNamespaceResolvers( Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); -/* 132 */ -EXTERN int TclpHasSockets(Tcl_Interp *interp); +/* Slot 132 is reserved */ /* Slot 133 is reserved */ /* Slot 134 is reserved */ /* Slot 135 is reserved */ @@ -721,7 +720,7 @@ typedef struct TclIntStubs { int (*tcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */ int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */ void (*tcl_SetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 131 */ - int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */ + void (*reserved132)(void); void (*reserved133)(void); void (*reserved134)(void); void (*reserved135)(void); @@ -1058,8 +1057,7 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tcl_RemoveInterpResolvers) /* 130 */ #define Tcl_SetNamespaceResolvers \ (tclIntStubsPtr->tcl_SetNamespaceResolvers) /* 131 */ -#define TclpHasSockets \ - (tclIntStubsPtr->tclpHasSockets) /* 132 */ +/* Slot 132 is reserved */ /* Slot 133 is reserved */ /* Slot 134 is reserved */ /* Slot 135 is reserved */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 4b2fd30..a1d0541 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -531,7 +531,7 @@ static const TclIntStubs tclIntStubs = { Tcl_PushCallFrame, /* 129 */ Tcl_RemoveInterpResolvers, /* 130 */ Tcl_SetNamespaceResolvers, /* 131 */ - TclpHasSockets, /* 132 */ + 0, /* 132 */ 0, /* 133 */ 0, /* 134 */ 0, /* 135 */ diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index de4d9a8..864d477 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -319,29 +319,6 @@ Tcl_GetHostName(void) /* * ---------------------------------------------------------------------- * - * TclpHasSockets -- - * - * Detect if sockets are available on this platform. - * - * Results: - * Returns TCL_OK. - * - * Side effects: - * None. - * - * ---------------------------------------------------------------------- - */ - -int -TclpHasSockets( - TCL_UNUSED(Tcl_Interp *)) -{ - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * * TclpFinalizeSockets -- * * Performs per-thread socket subsystem finalization. diff --git a/win/tclWinSock.c b/win/tclWinSock.c index d9cff72..3c82caa 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -234,7 +234,6 @@ static TcpState * NewSocketInfo(SOCKET socket); static void SocketExitHandler(void *clientData); static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); -static int SocketsEnabled(void); static void TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr); static int WaitForConnect(TcpState *statePtr, int *errorCodePtr); static int WaitForSocketEvent(TcpState *statePtr, int events, @@ -362,23 +361,22 @@ InitializeHostName( Tcl_UtfToLower(Tcl_WCharToUtfDString(wbuf, TCL_INDEX_NONE, &ds)); } else { - if (TclpHasSockets(NULL) == TCL_OK) { - /* - * The buffer size of 256 is recommended by the MSDN page that - * documents gethostname() as being always adequate. - */ + TclInitSockets(); + /* + * The buffer size of 256 is recommended by the MSDN page that + * documents gethostname() as being always adequate. + */ - Tcl_DString inDs; + Tcl_DString inDs; - Tcl_DStringInit(&inDs); - Tcl_DStringSetLength(&inDs, 256); - if (gethostname(Tcl_DStringValue(&inDs), - Tcl_DStringLength(&inDs)) == 0) { - Tcl_ExternalToUtfDStringEx(NULL, Tcl_DStringValue(&inDs), - TCL_INDEX_NONE, TCL_ENCODING_NOCOMPLAIN, &ds); - } - Tcl_DStringFree(&inDs); + Tcl_DStringInit(&inDs); + Tcl_DStringSetLength(&inDs, 256); + if (gethostname(Tcl_DStringValue(&inDs), + Tcl_DStringLength(&inDs)) == 0) { + Tcl_ExternalToUtfDStringEx(NULL, Tcl_DStringValue(&inDs), + TCL_INDEX_NONE, TCL_ENCODING_NOCOMPLAIN, &ds); } + Tcl_DStringFree(&inDs); } *encodingPtr = Tcl_GetEncoding(NULL, "utf-8"); @@ -415,11 +413,9 @@ Tcl_GetHostName(void) /* *---------------------------------------------------------------------- * - * TclpHasSockets -- + * TclInitSockets -- * - * This function determines whether sockets are available on the current - * system and returns an error in interp if they are not. Note that - * interp may be NULL. + * This function just calls InitSockets(), but is protected by a mutex. * * Results: * Returns TCL_OK if the system supports sockets, or TCL_ERROR with an @@ -433,24 +429,16 @@ Tcl_GetHostName(void) *---------------------------------------------------------------------- */ -int -TclpHasSockets( - Tcl_Interp *interp) /* Where to write an error message if sockets - * are not present, or NULL if no such message - * is to be written. */ +void +TclInitSockets() { - Tcl_MutexLock(&socketMutex); - InitSockets(); - Tcl_MutexUnlock(&socketMutex); - - if (SocketsEnabled()) { - return TCL_OK; - } - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "sockets are not available on this system", TCL_INDEX_NONE)); + if (!initialized) { + Tcl_MutexLock(&socketMutex); + if (!initialized) { + InitSockets(); + } + Tcl_MutexUnlock(&socketMutex); } - return TCL_ERROR; } /* @@ -775,17 +763,6 @@ TcpInputProc( *errorCodePtr = 0; /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - *errorCodePtr = EFAULT; - return -1; - } - - /* * First check to see if EOF was already detected, to prevent calling the * socket stack after the first time EOF is detected. */ @@ -918,17 +895,6 @@ TcpOutputProc( *errorCodePtr = 0; /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - *errorCodePtr = EFAULT; - return -1; - } - - /* * Check if there is an async connect running. * For blocking sockets terminate connect, otherwise do one step. * For a non blocking socket return EWOULDBLOCK if connect not terminated @@ -1029,28 +995,20 @@ TcpCloseProc( ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. + * Clean up the OS socket handle. The default Windows setting for a + * socket is SO_DONTLINGER, which does a graceful shutdown in the + * background. */ - if (SocketsEnabled()) { - /* - * Clean up the OS socket handle. The default Windows setting for a - * socket is SO_DONTLINGER, which does a graceful shutdown in the - * background. - */ - - while (statePtr->sockets != NULL) { - TcpFdList *thisfd = statePtr->sockets; + while (statePtr->sockets != NULL) { + TcpFdList *thisfd = statePtr->sockets; - statePtr->sockets = thisfd->next; - if (closesocket(thisfd->fd) == SOCKET_ERROR) { - Tcl_WinConvertError((DWORD) WSAGetLastError()); - errorCode = Tcl_GetErrno(); - } - Tcl_Free(thisfd); + statePtr->sockets = thisfd->next; + if (closesocket(thisfd->fd) == SOCKET_ERROR) { + Tcl_WinConvertError((DWORD) WSAGetLastError()); + errorCode = Tcl_GetErrno(); } + Tcl_Free(thisfd); } if (statePtr->addrlist != NULL) { @@ -1177,20 +1135,6 @@ TcpSetOptionProc( len = strlen(optionName); } - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "winsock is not initialized", -1)); - } - return TCL_ERROR; - } - sock = statePtr->sockets->fd; if ((len > 1) && (optionName[1] == 'k') && @@ -1277,20 +1221,6 @@ TcpGetOptionProc( #define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS" /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "winsock is not initialized", -1)); - } - return TCL_ERROR; - } - - /* * Go one step in async connect * * If any error is thrown save it as backround error to report eventually @@ -2013,19 +1943,7 @@ Tcl_OpenTcpClient( struct addrinfo *addrlist = NULL, *myaddrlist = NULL; char channelName[SOCK_CHAN_LENGTH]; - if (TclpHasSockets(interp) != TCL_OK) { - return NULL; - } - - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - return NULL; - } + TclInitSockets(); /* * Do the name lookups for the local and remote addresses. @@ -2099,9 +2017,7 @@ Tcl_MakeTcpClientChannel( char channelName[SOCK_CHAN_LENGTH]; ThreadSpecificData *tsdPtr; - if (TclpHasSockets(NULL) != TCL_OK) { - return NULL; - } + TclInitSockets(); tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); @@ -2167,19 +2083,7 @@ Tcl_OpenTcpServerEx( const char *errorMsg = NULL; int optvalue, port; - if (TclpHasSockets(interp) != TCL_OK) { - return NULL; - } - - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - return NULL; - } + TclInitSockets(); /* * Construct the addresses for each end of the socket. @@ -2510,55 +2414,19 @@ InitSockets(void) WaitForSingleObject(tsdPtr->readyEvent, INFINITE); - if (tsdPtr->hwnd == NULL) { - goto initFailure; /* Trouble creating the window. */ + if (tsdPtr->hwnd != NULL) { + Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); + return; } - Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); - return; - initFailure: - TclpFinalizeSockets(); - initialized = -1; + Tcl_Panic("InitSockets failed"); return; } /* *---------------------------------------------------------------------- * - * SocketsEnabled -- - * - * Check that the WinSock was successfully initialized. - * - * Warning: - * This check was useful in times of Windows98 where WinSock may - * not be available. This is not the case any more. - * This function may be removed with TCL 9.0 - * - * Results: - * 1 if it is. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -SocketsEnabled(void) -{ - int enabled; - - Tcl_MutexLock(&socketMutex); - enabled = (initialized == 1); - Tcl_MutexUnlock(&socketMutex); - return enabled; -} - - -/* - *---------------------------------------------------------------------- - * * SocketExitHandler -- * * Callback invoked during exit clean up to delete the socket @@ -3388,9 +3256,7 @@ TcpThreadActionProc( * sockets will not work. */ - Tcl_MutexLock(&socketMutex); - InitSockets(); - Tcl_MutexUnlock(&socketMutex); + TclInitSockets(); tsdPtr = TCL_TSD_INIT(&dataKey); -- cgit v0.12 From 44ce8c245fa83b3cc8733db27a99b24bdca732fb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 Nov 2022 10:50:39 +0000 Subject: TclInitSockets() only exists on Windows --- generic/tclInt.h | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclInt.h b/generic/tclInt.h index dbe44b5..a633a17 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3276,7 +3276,11 @@ MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); MODULE_SCOPE void TclpFinalizeNotifier(void *clientData); MODULE_SCOPE void TclpFinalizePipes(void); MODULE_SCOPE void TclpFinalizeSockets(void); +#ifdef _WIN32 MODULE_SCOPE void TclInitSockets(void); +#else +#define TclInitSockets() /* do nothing */ +#endif MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, struct addrinfo **addrlist, const char *host, int port, int willBind, -- cgit v0.12 From 82a4bb8618f4a8672fd62a895fa355c1a0628b88 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 Nov 2022 20:46:49 +0000 Subject: Deprecate TclpHasSockets(): Every system nowadays has sockets --- ChangeLog.2008 | 2 +- generic/tclCompCmdsGR.c | 25 +++--- generic/tclCompile.c | 2 +- generic/tclIOCmd.c | 61 +++++++------- generic/tclInt.decls | 2 +- generic/tclInt.h | 5 ++ generic/tclIntDecls.h | 5 +- generic/tclStubInit.c | 3 + unix/tclUnixSock.c | 27 +----- win/tclWinSock.c | 216 +++++++++--------------------------------------- 10 files changed, 102 insertions(+), 246 deletions(-) diff --git a/ChangeLog.2008 b/ChangeLog.2008 index 9c4e951..53690e4 100644 --- a/ChangeLog.2008 +++ b/ChangeLog.2008 @@ -1939,7 +1939,7 @@ 2008-07-28 Jan Nijtmans * doc/FileSystem.3: CONSTified many functions using - * generic/tcl.decls: Tcl_FileSystem which all are supposed + * generic/tcl.decls: Tcl_Filesystem which all are supposed * generic/tclDecls.h: to be a constant, but this was not * generic/tclFileSystem.h: reflected in the API: Tcl_FSData, * generic/tclIOUtil.c: Tcl_FSGetInternalRep, Tcl_FSRegister, diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 2681d01..7bb06ab 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -181,7 +181,8 @@ TclCompileIfCmd( * determined. */ Tcl_Token *tokenPtr, *testTokenPtr; int jumpIndex = 0; /* Avoid compiler warning. */ - int jumpFalseDist, numWords, wordIdx, numBytes, j, code; + int numBytes, j; + int jumpFalseDist, numWords, wordIdx, code; const char *word; int realCond = 1; /* Set to 0 for static conditions: * "if 0 {..}" */ @@ -1361,7 +1362,7 @@ TclCompileLinsertCmd( if (parsePtr->numWords < 3) { return TCL_ERROR; } - + /* Push list, insertion index onto the stack */ tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); @@ -1376,7 +1377,7 @@ TclCompileLinsertCmd( /* First operand is count of arguments */ TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 1, envPtr); - /* + /* * Second operand is bitmask * TCL_LREPLACE4_END_IS_LAST - end refers to last element * TCL_LREPLACE4_SINGLE_INDEX - second index is not present @@ -1430,7 +1431,7 @@ TclCompileLreplaceCmd( /* First operand is count of arguments */ TclEmitInstInt4(INST_LREPLACE4, parsePtr->numWords - 1, envPtr); - /* + /* * Second operand is bitmask * TCL_LREPLACE4_END_IS_LAST - end refers to last element */ @@ -1438,7 +1439,7 @@ TclCompileLreplaceCmd( return TCL_OK; } - + /* *---------------------------------------------------------------------- * @@ -1924,7 +1925,8 @@ TclCompileRegexpCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the * parse of the RE or string. */ - int i, len, nocase, exact, sawLast, simple; + int len; + int i, nocase, exact, sawLast, simple; const char *str; /* @@ -2110,7 +2112,8 @@ TclCompileRegsubCmd( Tcl_Obj *patternObj = NULL, *replacementObj = NULL; Tcl_DString pattern; const char *bytes; - int len, exact, quantified, result = TCL_ERROR; + int exact, quantified, result = TCL_ERROR; + int len; if (parsePtr->numWords < 5 || parsePtr->numWords > 6) { return TCL_ERROR; @@ -2264,7 +2267,8 @@ TclCompileReturnCmd( * General syntax: [return ?-option value ...? ?result?] * An even number of words means an explicit result argument is present. */ - int level, code, objc, size, status = TCL_OK; + int level, code, objc, status = TCL_OK; + int size; int numWords = parsePtr->numWords; int explicitResult = (0 == (numWords % 2)); int numOptionWords = numWords - 1 - explicitResult; @@ -2374,7 +2378,7 @@ TclCompileReturnCmd( ExceptionRange range = envPtr->exceptArrayPtr[index]; if ((range.type == CATCH_EXCEPTION_RANGE) - && (range.catchOffset == -1)) { + && (range.catchOffset == TCL_INDEX_NONE)) { enclosingCatch = 1; break; } @@ -2700,7 +2704,8 @@ IndexTailVarIfKnown( { Tcl_Obj *tailPtr; const char *tailName, *p; - int len, n = varTokenPtr->numComponents; + int n = varTokenPtr->numComponents; + int len; Tcl_Token *lastTokenPtr; int full, localIndex; diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 2dd0718..c10145c 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -678,7 +678,7 @@ InstructionDesc const tclInstructionTable[] = { {"lreplace4", 6, INT_MIN, 2, {OPERAND_UINT4, OPERAND_UINT1}}, /* Operands: number of arguments, flags * flags: Combination of TCL_LREPLACE4_* flags - * Stack: ... listobj index1 ?index2? new1 ... newN => ... newlistobj + * Stack: ... listobj index1 ?index2? new1 ... newN => ... newlistobj * where index2 is present only if TCL_LREPLACE_SINGLE_INDEX is not * set in flags. */ diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 0ea84f1..e8a534f 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -15,7 +15,7 @@ * Callback structure for accept callback in a TCP server. */ -typedef struct AcceptCallback { +typedef struct { Tcl_Obj *script; /* Script to invoke. */ Tcl_Interp *interp; /* Interpreter in which to run it. */ } AcceptCallback; @@ -44,7 +44,7 @@ static void RegisterTcpServerInterpCleanup( Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr); static Tcl_InterpDeleteProc TcpAcceptCallbacksDeleteProc; -static void TcpServerCloseProc(ClientData callbackData); +static void TcpServerCloseProc(void *callbackData); static void UnregisterTcpServerInterpCleanupProc( Tcl_Interp *interp, AcceptCallback *acceptCallbackPtr); @@ -67,7 +67,7 @@ static void UnregisterTcpServerInterpCleanupProc( static void FinalizeIOCmdTSD( - TCL_UNUSED(ClientData)) + TCL_UNUSED(void *)) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -97,7 +97,7 @@ FinalizeIOCmdTSD( int Tcl_PutsObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -223,7 +223,7 @@ Tcl_PutsObjCmd( int Tcl_FlushObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -287,7 +287,7 @@ Tcl_FlushObjCmd( int Tcl_GetsObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -335,7 +335,7 @@ Tcl_GetsObjCmd( code = TCL_ERROR; goto done; } - lineLen = -1; + lineLen = TCL_INDEX_NONE; } if (objc == 3) { if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr, @@ -371,7 +371,7 @@ Tcl_GetsObjCmd( int Tcl_ReadObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -514,7 +514,7 @@ Tcl_ReadObjCmd( int Tcl_SeekObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -589,7 +589,7 @@ Tcl_SeekObjCmd( int Tcl_TellObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -651,7 +651,7 @@ Tcl_TellObjCmd( int Tcl_CloseObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -759,7 +759,7 @@ Tcl_CloseObjCmd( int Tcl_FconfigureObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -834,7 +834,7 @@ Tcl_FconfigureObjCmd( int Tcl_EofObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -873,7 +873,7 @@ Tcl_EofObjCmd( int Tcl_ExecObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -883,8 +883,8 @@ Tcl_ExecObjCmd( * on the _Tcl_ stack. */ const char *string; Tcl_Channel chan; - int argc, background, i, index, keepNewline, result, skip, length; - int ignoreStderr; + int argc, background, i, index, keepNewline, result, skip, ignoreStderr; + int length; static const char *const options[] = { "-ignorestderr", "-keepnewline", "--", NULL }; @@ -1040,7 +1040,7 @@ Tcl_ExecObjCmd( int Tcl_FblockedObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1086,7 +1086,7 @@ Tcl_FblockedObjCmd( int Tcl_OpenObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1144,7 +1144,8 @@ Tcl_OpenObjCmd( if (!pipeline) { chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot); } else { - int mode, seekFlag, cmdObjc, binary; + int mode, seekFlag, binary; + int cmdObjc; const char **cmdArgv; if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) { @@ -1209,7 +1210,7 @@ Tcl_OpenObjCmd( static void TcpAcceptCallbacksDeleteProc( - ClientData clientData, /* Data which was passed when the assocdata + void *clientData, /* Data which was passed when the assocdata * was registered. */ TCL_UNUSED(Tcl_Interp *)) { @@ -1337,7 +1338,7 @@ UnregisterTcpServerInterpCleanupProc( static void AcceptCallbackProc( - ClientData callbackData, /* The data stored when the callback was + void *callbackData, /* The data stored when the callback was * created in the call to * Tcl_OpenTcpServer. */ Tcl_Channel chan, /* Channel for the newly accepted @@ -1428,7 +1429,7 @@ AcceptCallbackProc( static void TcpServerCloseProc( - ClientData callbackData) /* The data passed in the call to + void *callbackData) /* The data passed in the call to * Tcl_CreateCloseHandler. */ { AcceptCallback *acceptCallbackPtr = (AcceptCallback *)callbackData; @@ -1461,7 +1462,7 @@ TcpServerCloseProc( int Tcl_SocketObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1481,9 +1482,7 @@ Tcl_SocketObjCmd( Tcl_Obj *script = NULL; Tcl_Channel chan; - if (TclpHasSockets(interp) != TCL_OK) { - return TCL_ERROR; - } + TclInitSockets(); for (a = 1; a < objc; a++) { const char *arg = Tcl_GetString(objv[a]); @@ -1714,7 +1713,7 @@ Tcl_SocketObjCmd( int Tcl_FcopyObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1809,7 +1808,7 @@ Tcl_FcopyObjCmd( static int ChanPendingObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1871,7 +1870,7 @@ ChanPendingObjCmd( static int ChanTruncateObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1944,7 +1943,7 @@ ChanTruncateObjCmd( static int ChanPipeObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1995,7 +1994,7 @@ ChanPipeObjCmd( int TclChannelNamesCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) diff --git a/generic/tclInt.decls b/generic/tclInt.decls index d16a74c..c0e0e06 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -321,7 +321,7 @@ declare 131 { Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } -declare 132 { +declare 132 {deprecated {}} { int TclpHasSockets(Tcl_Interp *interp) } declare 133 {deprecated {}} { diff --git a/generic/tclInt.h b/generic/tclInt.h index 6af0991..bdd7e5a 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3294,6 +3294,11 @@ MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); MODULE_SCOPE void TclpFinalizeNotifier(void *clientData); MODULE_SCOPE void TclpFinalizePipes(void); MODULE_SCOPE void TclpFinalizeSockets(void); +#ifdef _WIN32 +MODULE_SCOPE void TclInitSockets(void); +#else +#define TclInitSockets() /* do nothing */ +#endif MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, struct addrinfo **addrlist, const char *host, int port, int willBind, diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index ec9023f..3da8567 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -354,7 +354,8 @@ EXTERN void Tcl_SetNamespaceResolvers( Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 132 */ -EXTERN int TclpHasSockets(Tcl_Interp *interp); +TCL_DEPRECATED("") +int TclpHasSockets(Tcl_Interp *interp); /* 133 */ TCL_DEPRECATED("") struct tm * TclpGetDate(const time_t *time, int useGMT); @@ -801,7 +802,7 @@ typedef struct TclIntStubs { int (*tcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */ int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */ void (*tcl_SetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 131 */ - int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */ + TCL_DEPRECATED_API("") int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */ TCL_DEPRECATED_API("") struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */ void (*reserved134)(void); void (*reserved135)(void); diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 1ffe916..7af42d3 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -795,6 +795,7 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ # undef TclBN_s_mp_sub # define TclBN_s_mp_sub 0 # define Tcl_MakeSafe 0 +# define TclpHasSockets 0 #else /* TCL_NO_DEPRECATED */ # define Tcl_SeekOld seekOld # define Tcl_TellOld tellOld @@ -818,6 +819,8 @@ static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ # define TclpGmtime_unix TclpGmtime # define Tcl_MakeSafe TclMakeSafe +int TclpHasSockets(TCL_UNUSED(Tcl_Interp *)) {return TCL_OK;} + static int seekOld( Tcl_Channel chan, /* The channel on which to seek. */ diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 4e34af5..70dfc61 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -322,29 +322,6 @@ Tcl_GetHostName(void) /* * ---------------------------------------------------------------------- * - * TclpHasSockets -- - * - * Detect if sockets are available on this platform. - * - * Results: - * Returns TCL_OK. - * - * Side effects: - * None. - * - * ---------------------------------------------------------------------- - */ - -int -TclpHasSockets( - TCL_UNUSED(Tcl_Interp *)) -{ - return TCL_OK; -} - -/* - * ---------------------------------------------------------------------- - * * TclpFinalizeSockets -- * * Performs per-thread socket subsystem finalization. @@ -541,7 +518,7 @@ TcpInputProc( if (WaitForConnect(statePtr, errorCodePtr) != 0) { return -1; } - bytesRead = recv(statePtr->fds.fd, buf, (size_t) bufSize, 0); + bytesRead = recv(statePtr->fds.fd, buf, bufSize, 0); if (bytesRead >= 0) { return bytesRead; } @@ -591,7 +568,7 @@ TcpOutputProc( if (WaitForConnect(statePtr, errorCodePtr) != 0) { return -1; } - written = send(statePtr->fds.fd, buf, (size_t) toWrite, 0); + written = send(statePtr->fds.fd, buf, toWrite, 0); if (written >= 0) { return written; diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 9ac1a15..ef01fa8 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -234,7 +234,6 @@ static TcpState * NewSocketInfo(SOCKET socket); static void SocketExitHandler(void *clientData); static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); -static int SocketsEnabled(void); static void TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr); static int WaitForConnect(TcpState *statePtr, int *errorCodePtr); static int WaitForSocketEvent(TcpState *statePtr, int events, @@ -366,23 +365,22 @@ InitializeHostName( Tcl_UtfToLower(Tcl_WCharToUtfDString(wbuf, TCL_INDEX_NONE, &ds)); } else { - if (TclpHasSockets(NULL) == TCL_OK) { - /* - * The buffer size of 256 is recommended by the MSDN page that - * documents gethostname() as being always adequate. - */ + TclInitSockets(); + /* + * The buffer size of 256 is recommended by the MSDN page that + * documents gethostname() as being always adequate. + */ - Tcl_DString inDs; + Tcl_DString inDs; - Tcl_DStringInit(&inDs); - Tcl_DStringSetLength(&inDs, 256); - if (gethostname(Tcl_DStringValue(&inDs), - Tcl_DStringLength(&inDs)) == 0) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), - TCL_INDEX_NONE, &ds); - } - Tcl_DStringFree(&inDs); + Tcl_DStringInit(&inDs); + Tcl_DStringSetLength(&inDs, 256); + if (gethostname(Tcl_DStringValue(&inDs), + Tcl_DStringLength(&inDs)) == 0) { + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), + TCL_INDEX_NONE, &ds); } + Tcl_DStringFree(&inDs); } *encodingPtr = Tcl_GetEncoding(NULL, "utf-8"); @@ -419,11 +417,9 @@ Tcl_GetHostName(void) /* *---------------------------------------------------------------------- * - * TclpHasSockets -- + * TclInitSockets -- * - * This function determines whether sockets are available on the current - * system and returns an error in interp if they are not. Note that - * interp may be NULL. + * This function just calls InitSockets(), but is protected by a mutex. * * Results: * Returns TCL_OK if the system supports sockets, or TCL_ERROR with an @@ -437,24 +433,16 @@ Tcl_GetHostName(void) *---------------------------------------------------------------------- */ -int -TclpHasSockets( - Tcl_Interp *interp) /* Where to write an error message if sockets - * are not present, or NULL if no such message - * is to be written. */ +void +TclInitSockets() { - Tcl_MutexLock(&socketMutex); - InitSockets(); - Tcl_MutexUnlock(&socketMutex); - - if (SocketsEnabled()) { - return TCL_OK; - } - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "sockets are not available on this system", TCL_INDEX_NONE)); + if (!initialized) { + Tcl_MutexLock(&socketMutex); + if (!initialized) { + InitSockets(); + } + Tcl_MutexUnlock(&socketMutex); } - return TCL_ERROR; } /* @@ -779,17 +767,6 @@ TcpInputProc( *errorCodePtr = 0; /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - *errorCodePtr = EFAULT; - return -1; - } - - /* * First check to see if EOF was already detected, to prevent calling the * socket stack after the first time EOF is detected. */ @@ -922,17 +899,6 @@ TcpOutputProc( *errorCodePtr = 0; /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - *errorCodePtr = EFAULT; - return -1; - } - - /* * Check if there is an async connect running. * For blocking sockets terminate connect, otherwise do one step. * For a non blocking socket return EWOULDBLOCK if connect not terminated @@ -1033,28 +999,20 @@ TcpCloseProc( ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. + * Clean up the OS socket handle. The default Windows setting for a + * socket is SO_DONTLINGER, which does a graceful shutdown in the + * background. */ - if (SocketsEnabled()) { - /* - * Clean up the OS socket handle. The default Windows setting for a - * socket is SO_DONTLINGER, which does a graceful shutdown in the - * background. - */ - - while (statePtr->sockets != NULL) { - TcpFdList *thisfd = statePtr->sockets; + while (statePtr->sockets != NULL) { + TcpFdList *thisfd = statePtr->sockets; - statePtr->sockets = thisfd->next; - if (closesocket(thisfd->fd) == SOCKET_ERROR) { - Tcl_WinConvertError((DWORD) WSAGetLastError()); - errorCode = Tcl_GetErrno(); - } - ckfree(thisfd); + statePtr->sockets = thisfd->next; + if (closesocket(thisfd->fd) == SOCKET_ERROR) { + Tcl_WinConvertError((DWORD) WSAGetLastError()); + errorCode = Tcl_GetErrno(); } + ckfree(thisfd); } if (statePtr->addrlist != NULL) { @@ -1181,20 +1139,6 @@ TcpSetOptionProc( len = strlen(optionName); } - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "winsock is not initialized", -1)); - } - return TCL_ERROR; - } - sock = statePtr->sockets->fd; if ((len > 1) && (optionName[1] == 'k') && @@ -1281,20 +1225,6 @@ TcpGetOptionProc( #define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS" /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "winsock is not initialized", -1)); - } - return TCL_ERROR; - } - - /* * Go one step in async connect * * If any error is thrown save it as backround error to report eventually @@ -2017,19 +1947,7 @@ Tcl_OpenTcpClient( struct addrinfo *addrlist = NULL, *myaddrlist = NULL; char channelName[SOCK_CHAN_LENGTH]; - if (TclpHasSockets(interp) != TCL_OK) { - return NULL; - } - - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - return NULL; - } + TclInitSockets(); /* * Do the name lookups for the local and remote addresses. @@ -2103,9 +2021,7 @@ Tcl_MakeTcpClientChannel( char channelName[SOCK_CHAN_LENGTH]; ThreadSpecificData *tsdPtr; - if (TclpHasSockets(NULL) != TCL_OK) { - return NULL; - } + TclInitSockets(); tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); @@ -2171,19 +2087,7 @@ Tcl_OpenTcpServerEx( const char *errorMsg = NULL; int optvalue, port; - if (TclpHasSockets(interp) != TCL_OK) { - return NULL; - } - - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ - - if (!SocketsEnabled()) { - return NULL; - } + TclInitSockets(); /* * Construct the addresses for each end of the socket. @@ -2514,55 +2418,19 @@ InitSockets(void) WaitForSingleObject(tsdPtr->readyEvent, INFINITE); - if (tsdPtr->hwnd == NULL) { - goto initFailure; /* Trouble creating the window. */ + if (tsdPtr->hwnd != NULL) { + Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); + return; } - Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); - return; - initFailure: - TclpFinalizeSockets(); - initialized = -1; + Tcl_Panic("InitSockets failed"); return; } /* *---------------------------------------------------------------------- * - * SocketsEnabled -- - * - * Check that the WinSock was successfully initialized. - * - * Warning: - * This check was useful in times of Windows98 where WinSock may - * not be available. This is not the case any more. - * This function may be removed with TCL 9.0 - * - * Results: - * 1 if it is. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -SocketsEnabled(void) -{ - int enabled; - - Tcl_MutexLock(&socketMutex); - enabled = (initialized == 1); - Tcl_MutexUnlock(&socketMutex); - return enabled; -} - - -/* - *---------------------------------------------------------------------- - * * SocketExitHandler -- * * Callback invoked during exit clean up to delete the socket @@ -3454,9 +3322,7 @@ TcpThreadActionProc( * sockets will not work. */ - Tcl_MutexLock(&socketMutex); - InitSockets(); - Tcl_MutexUnlock(&socketMutex); + TclInitSockets(); tsdPtr = TCL_TSD_INIT(&dataKey); -- cgit v0.12 From aed83779fd0befd6315d01433e60ba27a324fc31 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 7 Nov 2022 21:35:41 +0000 Subject: tests/httpProxy.test - test for leftover socket placeholders, improve result layout, for https fetch with status 407 expect result SecureProxyFailed not SecureProxy. --- tests/httpProxy.test | 236 +++++++++++++++++++++++++++++++-------------------- 1 file changed, 144 insertions(+), 92 deletions(-) diff --git a/tests/httpProxy.test b/tests/httpProxy.test index 90fe828..d9e865a 100644 --- a/tests/httpProxy.test +++ b/tests/httpProxy.test @@ -85,40 +85,44 @@ test httpProxy-1.1.$ThreadLevel {squid is running - ipv4 noauth} -constraints {n } -body { set token [http::geturl http://$n4host:$n4port/] set ri [http::responseInfo $token] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" -} -result {complete ok 400 none} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed]" +} -result {complete ok 400 -- none} -cleanup { http::cleanup $token - unset -nocomplain ri res + unset -nocomplain token ri res } test httpProxy-1.2.$ThreadLevel {squid is running - ipv6 noauth} -constraints {needsSquid} -setup { } -body { set token [http::geturl http://\[$n6host\]:$n6port/] set ri [http::responseInfo $token] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" -} -result {complete ok 400 none} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed]" +} -result {complete ok 400 -- none} -cleanup { http::cleanup $token - unset -nocomplain ri res + unset -nocomplain token ri res } test httpProxy-1.3.$ThreadLevel {squid is running - ipv4 auth} -constraints {needsSquid} -setup { } -body { set token [http::geturl http://$a4host:$a4port/] set ri [http::responseInfo $token] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" -} -result {complete ok 400 none} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed]" +} -result {complete ok 400 -- none} -cleanup { http::cleanup $token - unset -nocomplain ri res + unset -nocomplain token ri res } test httpProxy-1.4.$ThreadLevel {squid is running - ipv6 auth} -constraints {needsSquid} -setup { } -body { set token [http::geturl http://\[$a6host\]:$a6port/] set ri [http::responseInfo $token] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" -} -result {complete ok 400 none} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed]" +} -result {complete ok 400 -- none} -cleanup { http::cleanup $token - unset -nocomplain ri res + unset -nocomplain token ri res } test httpProxy-2.1.$ThreadLevel {http no-proxy no-auth} -constraints {needsSquid} -setup { @@ -126,10 +130,12 @@ test httpProxy-2.1.$ThreadLevel {http no-proxy no-auth} -constraints {needsSquid } -body { set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" -} -result {complete ok 200 none} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res + unset -nocomplain token ri res } test httpProxy-2.2.$ThreadLevel {https no-proxy no-auth} -constraints {needsSquid needsTls} -setup { @@ -137,10 +143,12 @@ test httpProxy-2.2.$ThreadLevel {https no-proxy no-auth} -constraints {needsSqui } -body { set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" -} -result {complete ok 200 none} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res + unset -nocomplain token ri res } test httpProxy-2.3.$ThreadLevel {http with-proxy ipv4 no-auth} -constraints {needsSquid} -setup { @@ -148,10 +156,12 @@ test httpProxy-2.3.$ThreadLevel {http with-proxy ipv4 no-auth} -constraints {nee } -body { set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" -} -result {complete ok 200 HttpProxy} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- HttpProxy -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res + unset -nocomplain token ri res http::config -proxyhost {} -proxyport {} -proxynot {} } @@ -160,34 +170,40 @@ test httpProxy-2.4.$ThreadLevel {https with-proxy ipv4 no-auth} -constraints {ne } -body { set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" -} -result {complete ok 200 SecureProxy} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- SecureProxy -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res + unset -nocomplain token ri res http::config -proxyhost {} -proxyport {} -proxynot {} } test httpProxy-2.5.$ThreadLevel {http with-proxy ipv6 no-auth} -constraints {needsSquid} -setup { - http::config -proxyhost $n6host -proxyport $n6port -proxynot {127.0.0.1 localhost} -proxyauth {} + http::config -proxyhost $n6host -proxyport $n6port -proxynot {::1 localhost} -proxyauth {} } -body { set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" -} -result {complete ok 200 HttpProxy} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- HttpProxy -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res + unset -nocomplain token ri res http::config -proxyhost {} -proxyport {} -proxynot {} } test httpProxy-2.6.$ThreadLevel {https with-proxy ipv6 no-auth} -constraints {needsSquid needsTls} -setup { - http::config -proxyhost $n6host -proxyport $n6port -proxynot {127.0.0.1 localhost} -proxyauth {} + http::config -proxyhost $n6host -proxyport $n6port -proxynot {::1 localhost} -proxyauth {} } -body { set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed]" -} -result {complete ok 200 SecureProxy} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- SecureProxy -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res + unset -nocomplain token ri res http::config -proxyhost {} -proxyport {} -proxynot {} } @@ -198,10 +214,12 @@ test httpProxy-3.1.$ThreadLevel {http no-proxy with-auth valid-creds-provided} - set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 200 none 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -212,10 +230,12 @@ test httpProxy-3.2.$ThreadLevel {https no-proxy with-auth valid-creds-provided} set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 200 none 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -226,10 +246,12 @@ test httpProxy-3.3.$ThreadLevel {http with-proxy ipv4 with-auth valid-creds-prov set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 200 HttpProxy 1 1} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- HttpProxy 1 1 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -240,38 +262,44 @@ test httpProxy-3.4.$ThreadLevel {https with-proxy ipv4 with-auth valid-creds-pro set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 200 SecureProxy 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- SecureProxy 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-3.5.$ThreadLevel {http with-proxy ipv6 with-auth valid-creds-provided} -constraints {needsSquid} -setup { - http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds } -body { set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 200 HttpProxy 1 1} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- HttpProxy 1 1 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-3.6.$ThreadLevel {https with-proxy ipv6 with-auth valid-creds-provided} -constraints {needsSquid needsTls} -setup { - http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds } -body { set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 200 SecureProxy 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- SecureProxy 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -282,10 +310,12 @@ test httpProxy-4.1.$ThreadLevel {http no-proxy with-auth no-creds-provided} -con set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 200 none 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -296,10 +326,12 @@ test httpProxy-4.2.$ThreadLevel {https no-proxy with-auth no-creds-provided} -co set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 200 none 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -310,10 +342,12 @@ test httpProxy-4.3.$ThreadLevel {http with-proxy ipv4 with-auth no-creds-provide set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 407 HttpProxy 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- HttpProxy 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -324,38 +358,44 @@ test httpProxy-4.4.$ThreadLevel {https with-proxy ipv4 with-auth no-creds-provid set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 407 SecureProxy 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-4.5.$ThreadLevel {http with-proxy ipv6 with-auth no-creds-provided} -constraints {needsSquid} -setup { - http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth {} + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} } -body { set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 407 HttpProxy 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- HttpProxy 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-4.6.$ThreadLevel {https with-proxy ipv6 with-auth no-creds-provided} -constraints {needsSquid needsTls} -setup { - http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth {} + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} } -body { set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 407 SecureProxy 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -366,10 +406,12 @@ test httpProxy-5.1.$ThreadLevel {http no-proxy with-auth bad-creds-provided} -co set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 200 none 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -380,10 +422,12 @@ test httpProxy-5.2.$ThreadLevel {https no-proxy with-auth bad-creds-provided} -c set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 200 none 0 0} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 200 -- none 0 0 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -394,10 +438,12 @@ test httpProxy-5.3.$ThreadLevel {http with-proxy ipv4 with-auth bad-creds-provid set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 407 HttpProxy 1 1} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- HttpProxy 1 1 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } @@ -408,38 +454,44 @@ test httpProxy-5.4.$ThreadLevel {https with-proxy ipv4 with-auth bad-creds-provi set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 407 SecureProxy 1 1} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-5.5.$ThreadLevel {http with-proxy ipv6 with-auth bad-creds-provided} -constraints {needsSquid} -setup { - http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $badCreds } -body { set token [http::geturl http://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 407 HttpProxy 1 1} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- HttpProxy 1 1 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } test httpProxy-5.6.$ThreadLevel {https with-proxy ipv6 with-auth bad-creds-provided} -constraints {needsSquid needsTls} -setup { - http::config -proxyhost $a6host -proxyport $a6port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $badCreds } -body { set token [http::geturl https://www.google.com/] set ri [http::responseInfo $token] set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] - set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}]" -} -result {complete ok 407 SecureProxy 1 1} -cleanup { + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*]" +} -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1} -cleanup { http::cleanup $token - unset -nocomplain ri res pos1 pos2 + unset -nocomplain token ri res pos1 pos2 http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } -- cgit v0.12 From bf454b34d59371152ca527105f0908a4d29027f1 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 7 Nov 2022 21:40:55 +0000 Subject: tests/httpProxy.test - add new tests for cleanup (mainly after 407 request) by checking that a second request is handled correctly. --- tests/httpProxy.test | 638 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 638 insertions(+) diff --git a/tests/httpProxy.test b/tests/httpProxy.test index d9e865a..d8bd6b7 100644 --- a/tests/httpProxy.test +++ b/tests/httpProxy.test @@ -26,6 +26,10 @@ proc bgerror {args} { puts stderr $errorInfo } +proc stopMe {token} { + set ${token}(z) done +} + if {![info exists ThreadLevel]} { if {[catch {package require Thread}] == 0} { set ValueRange {0 1 2} @@ -303,6 +307,294 @@ test httpProxy-3.6.$ThreadLevel {https with-proxy ipv6 with-auth valid-creds-pro http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } +test httpProxy-3.7.$ThreadLevel {http with-proxy ipv4 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.7x.$ThreadLevel {http with-proxy ipv4 with-auth 1st request no-creds-provided; check that 2nd request with creds is possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] + + http::config -proxyauth $aliceCreds +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.8.$ThreadLevel {https with-proxy ipv4 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $aliceCreds + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.8x.$ThreadLevel {https with-proxy ipv4 with-auth 1st request no-creds-provided; check that 2nd request with creds is possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] + + http::config -proxyauth $aliceCreds +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.9.$ThreadLevel {http with-proxy ipv6 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.9p.$ThreadLevel {http with-proxy ipv6 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works, pipelining requested and possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds +} -body { + set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] +after idle { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can +} + vwait ${token0}(z) + after cancel $can0 + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can0 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.9x.$ThreadLevel {http with-proxy ipv6 with-auth 1st request no-creds-provided; check that 2nd request with creds is possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] + + http::config -proxyauth $aliceCreds +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.10.$ThreadLevel {https with-proxy ipv6 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.10p.$ThreadLevel {https with-proxy ipv6 with-auth valid-creds-provided; check that 2nd valid request with creds is possible, and keep-alive works, pipelining requested and possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $aliceCreds +} -body { + set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] +after idle { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token0; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can +} + vwait ${token0}(z) + after cancel $can0 + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can0 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-3.10x.$ThreadLevel {https with-proxy ipv6 with-auth 1st request no-creds-provided; check that 2nd request with creds is possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] + + http::config -proxyauth $aliceCreds +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 200 -- SecureProxy 0 0 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + test httpProxy-4.1.$ThreadLevel {http no-proxy with-auth no-creds-provided} -constraints {needsSquid} -setup { http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} } -body { @@ -399,6 +691,179 @@ test httpProxy-4.6.$ThreadLevel {https with-proxy ipv6 with-auth no-creds-provid http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } +test httpProxy-4.7.$ThreadLevel {http with-proxy ipv4 with-auth no-creds-provided; check that 2nd request is possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- HttpProxy 0 0 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.8.$ThreadLevel {https with-proxy ipv4 with-auth no-creds-provided; check that 2nd request is possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth {} + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.9.$ThreadLevel {http with-proxy ipv6 with-auth no-creds-provided; check that 2nd request is possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- HttpProxy 0 0 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.9p.$ThreadLevel {http with-proxy ipv6 with-auth no-creds-provided; check that 2nd request is possible, pipelining requested and possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} +} -body { + set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] +after idle { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token0; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can +} + vwait ${token0}(z) + after cancel $can0 + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- HttpProxy 0 0 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can0 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.10.$ThreadLevel {https with-proxy ipv6 with-auth no-creds-provided; check that 2nd request is possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-4.10p.$ThreadLevel {https with-proxy ipv6 with-auth no-creds-provided; check that 2nd request is possible, pipelining requested but not possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth {} +} -body { + set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + +after idle { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can +} + vwait ${token0}(z) + after cancel $can0 + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $aliceCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- SecureProxyFailed 0 0 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can0 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + test httpProxy-5.1.$ThreadLevel {http no-proxy with-auth bad-creds-provided} -constraints {needsSquid} -setup { http::config -proxyhost {} -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds } -body { @@ -495,10 +960,183 @@ test httpProxy-5.6.$ThreadLevel {https with-proxy ipv6 with-auth bad-creds-provi http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} } +test httpProxy-5.7.$ThreadLevel {http with-proxy ipv4 with-auth bad-creds-provided; check that 2nd request is possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.7p.$ThreadLevel {http with-proxy ipv4 with-auth bad-creds-provided; check that 2nd request is possible, pipelining requested and possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds +} -body { + set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + # Use the same caution as for the corresponding https test. +after idle { + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can +} + vwait ${token0}(z) + after cancel $can0 + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can0 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.8.$ThreadLevel {https with-proxy ipv4 with-auth bad-creds-provided; check that 2nd request is possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.8p.$ThreadLevel {https with-proxy ipv4 with-auth bad-creds-provided; check that 2nd request is possible, pipelining requested but not possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a4host -proxyport $a4port -proxynot {127.0.0.1 localhost} -proxyauth $badCreds +} -body { + set can0 [after 6000 {http::reset $token0; set ${token0}(z) timeout}] + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. +after idle { + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can +} + vwait ${token0}(z) + after cancel $can0 + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can0 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.9.$ThreadLevel {http with-proxy ipv6 with-auth bad-creds-provided; check that 2nd request is possible} -constraints {needsSquid} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $badCreds + set token0 [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # Use the same caution as for the corresponding https test. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl http://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- HttpProxy 1 1 -- -1 done 1} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + +test httpProxy-5.10.$ThreadLevel {https with-proxy ipv6 with-auth bad-creds-provided; check that 2nd request is possible} -constraints {needsSquid needsTls} -setup { + array unset ::http::socketMapping + http::config -proxyhost $a6host -proxyport $a6port -proxynot {::1 localhost} -proxyauth $badCreds + set token0 [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000] +} -body { + # If a bug passes the socket of a failed CONNECT to the main request, an infinite + # wait can occur despite -timeout. Fix this with http::reset; to do this the call + # to http::geturl must be async so we have $token for use as argument of reset. + set can [after 6000 {http::reset $token; set ${token}(z) timeout}] + set token [http::geturl https://www.google.com/ -keepalive 1 -timeout 5000 -command stopMe] + vwait ${token}(z) + after cancel $can + + set ri [http::responseInfo $token] + set pos1 [lsearch -exact [string tolower [set ${token}(requestHeaders)]] proxy-authorization] + set pos2 [lsearch -exact [set ${token}(requestHeaders)] $badCreds] + set same [string equal [set ${token0}(sock)] [set ${token}(sock)]] + set res "[dict get $ri stage] [dict get $ri status] [dict get $ri responseCode] --\ + [dict get $ri proxyUsed] [expr {$pos1 > -1}] [expr {$pos2 > -1}] --\ + [lsearch -glob [array get ::http::socketMapping] HTTP_PLACEHOLDER_*] [set ${token}(z)] $same" +} -result {complete ok 407 -- SecureProxyFailed 1 1 -- -1 done 0} -cleanup { + http::cleanup $token0 + http::cleanup $token + unset -nocomplain token0 token ri res pos1 pos2 can same + array unset ::http::socketMapping + http::config -proxyhost {} -proxyport {} -proxynot {} -proxyauth {} +} + # cleanup unset -nocomplain n4host n6host n4port n6port a4host a6host a4port a6port aliceCreds badCreds rename bgerror {} +rename stopMe {} ::tcltest::cleanupTests -- cgit v0.12 From 4c3d010bffd99f30596787903dfa04162f26c2b3 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 7 Nov 2022 21:44:39 +0000 Subject: library/http/http.tcl - replace lremove with lreplace for compatibility with 8.6. --- library/http/http.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index fcb03e1..bbde39d 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -4896,7 +4896,7 @@ proc http::SecureProxyConnect {args} { # Extract (non-proxy) target from args. set host [lindex $args end-3] set port [lindex $args end-2] - set args [lremove $args end-3 end-2] + set args [lreplace $args end-3 end-2] # Proxy server URL for connection. # This determines where the socket is opened. -- cgit v0.12 From 95b74de5c21547a344748baff089d47e8c57e391 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 7 Nov 2022 21:49:08 +0000 Subject: library/http/http.tcl - in http::SecureProxyConnect and its caller, bugfix cleanup after 407 from HTTPS proxy. Close the connection to the proxy. Do not copy all values of state() from the proxy CONNECT to the main request, especially leave out state(sock). Raise an error for a 3xx and 401 response to CONNECT. In http::Event, trap TLS handshake errors in a place where they do not occur for a non-proxy request. --- library/http/http.tcl | 176 +++++++++++++++++++++++++++++++++++++------------- 1 file changed, 132 insertions(+), 44 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index bbde39d..907256e 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -219,6 +219,33 @@ namespace eval http { 511 {Network Authentication Required} }] + variable failedProxyValues { + binary + body + charset + coding + connection + connectionRespFlag + currentsize + host + http + httpResponse + meta + method + querylength + queryoffset + reasonPhrase + requestHeaders + requestLine + responseCode + state + status + tid + totalsize + transfer + type + } + namespace export geturl config reset wait formatQuery postError quoteString namespace export register unregister registerError namespace export requestLine requestHeaders requestHeaderValue @@ -871,6 +898,7 @@ proc http::reset {token {why reset}} { set errorlist $state(error) unset state eval ::error $errorlist + # i.e. error msg errorInfo errorCode } return } @@ -1699,14 +1727,21 @@ proc http::OpenSocket {token DoLater} { ConfigureNewSocket $token $sockOld $DoLater } result errdict]} { if {[string range $result 0 20] eq {proxy connect failed:}} { - # The socket can be persistent: if so it is identified with - # the https target host, and will be kept open. - # Results of the failed proxy CONNECT have been copied to $token and - # are available to the caller. - Eot $token - } else { - Finish $token $result - } + # - The HTTPS proxy did not create a socket. The pre-existing value + # (a "placeholder socket") is unchanged. + # - The proxy returned a valid HTTP response to the failed CONNECT + # request, and http::SecureProxyConnect copied this to $token, + # and also set ${token}(connection) set to "close". + # - Remove the error message $result so that Finish delivers this + # HTTP response to the caller. + set result {} + } + Finish $token $result + # Because socket creation failed, the placeholder "socket" must be + # "closed" and (if persistent) removed from the persistent sockets + # table. In the {proxy connect failed:} case Finish does this because + # the value of ${token}(connection) is "close". In the other cases here, + # it does so because $result is non-empty. } ##Log Leaving http::OpenSocket coroutine [info coroutine] - token $token return @@ -2325,7 +2360,8 @@ proc http::Connected {token proto phost srvurl} { # If any other requests are in flight or pipelined/queued, they will # be discarded. } elseif {$state(status) eq ""} { - # ...https handshake errors come here. + # https handshake errors come here, for + # Tcl 8.7 without http::SecureProxyConnect, and for Tcl 8.6. set msg [registerError $sock] registerError $sock {} if {$msg eq {}} { @@ -3473,8 +3509,15 @@ proc http::Event {sock token} { # If any other requests are in flight or pipelined/queued, # they will be discarded. } else { + # https handshake errors come here, for + # Tcl 8.7 with http::SecureProxyConnect. + set msg [registerError $sock] + registerError $sock {} + if {$msg eq {}} { + set msg $nsl + } Log ^X$tk end of response (error) - token $token - Finish $token $nsl + Finish $token $msg return } } elseif {$nsl >= 0} { @@ -4882,15 +4925,12 @@ proc http::socketForTls {args} { # # Return Value: a socket identifier # ------------------------------------------------------------------------------ -proc http::AllDone {varName args} { - set $varName done - return -} proc http::SecureProxyConnect {args} { variable http variable ConnectVar variable ConnectCounter + variable failedProxyValues set varName ::http::ConnectVar([incr ConnectCounter]) # Extract (non-proxy) target from args. @@ -4941,8 +4981,11 @@ proc http::SecureProxyConnect {args} { variable $token2 upvar 0 $token2 state2 - # Setting this variable overrides the HTTP request line and allows + # Kludges: + # Setting this variable overrides the HTTP request line and also allows # -headers to override the Connection: header set by -keepalive. + # The arguments "-keepalive 0" ensure that when Finish is called for an + # unsuccessful request, the socket is always closed. set state2(bypass) "CONNECT $host:$port HTTP/1.1" AsyncTransaction $token2 @@ -4961,41 +5004,86 @@ proc http::SecureProxyConnect {args} { } unset $varName - set sock $state2(sock) - set code $state2(responseCode) - if {[string is integer -strict $code] && ($code >= 200) && ($code < 300)} { - # All OK. The caller in tls will now call "tls::import $sock". - # Do not use Finish, which will close (sock). - # Other tidying done in http::Event. - array unset state2 - } elseif {$targ != -1} { - # Bad HTTP status code; token is known. - # Copy from state2 to state, including (sock). - foreach name [array names state2] { - set state($name) $state2($name) + if { ($state2(state) ne "complete") + || ($state2(status) ne "ok") + || (![string is integer -strict $state2(responseCode)]) + } { + set msg {the HTTP request to the proxy server did not return a valid\ + and complete response} + if {[info exists state2(error)]} { + append msg ": " [lindex $state2(error) 0] } - set state(proxyUsed) SecureProxy - set state(proxyFail) failed + cleanup $token2 + return -code error $msg + } - # Do not use Finish, which will close (sock). - # Other tidying done in http::Event. - array unset state2 + set code $state2(responseCode) - # Error message detected by http::OpenSocket. - return -code error "proxy connect failed: $code" - } else { - # Bad HTTP status code; token is not known because option -type - # (cf. targ) was not passed through tcltls, and so the script - # cannot write to state(*). - # Do not use Finish, which will close (sock). - # Other tidying done in http::Event. - array unset state2 + if {($code >= 200) && ($code < 300)} { + # All OK. The caller in package tls will now call "tls::import $sock". + # The cleanup command does not close $sock. + # Other tidying was done in http::Event. + set sock $state2(sock) + cleanup $token2 + return $sock + } - # Error message detected by http::OpenSocket. - return -code error "proxy connect failed: $code\n$block" + if {$targ != -1} { + # Non-OK HTTP status code; token is known because option -type + # (cf. targ) was passed through tcltls, and so the useful + # parts of the proxy's response can be copied to state(*). + # Do not copy state2(sock). + # Return the proxy response to the caller of geturl. + foreach name $failedProxyValues { + if {[info exists state2($name)]} { + set state($name) $state2($name) + } + } + set state(proxyUsed) SecureProxyFailed + set state(connection) close + set msg "proxy connect failed: $code" + # - This error message will be detected by http::OpenSocket and will + # cause it to present the proxy's HTTP response as that of the + # original $token transaction, identified only by state(proxyUsed) + # as the response of the proxy. + # - The cases where this would mislead the caller of http::geturl are + # given a different value of msg (below) so that http::OpenSocket will + # treat them as errors, but will preserve the $token array for + # inspection by the caller. + # - Status code 305 (Proxy Required) was deprecated for security reasons + # in RFC 2616 (June 1999) and in any case should never be served by a + # proxy. + # - Other 3xx responses from the proxy are inappropriate, and should not + # occur. + # - A 401 response from the proxy is inappropriate, and should not + # occur. It would be confusing if returned to the caller. + + if {($code >= 300) && ($code < 400)} { + set msg "the proxy server responded to the HTTP request with an\ + inappropriate $code redirect" + set loc [responseHeaderValue $token2 location] + if {$loc ne {}} { + append msg "to " $loc + } + } elseif {($code == 401)} { + set msg "the proxy server responded to the HTTP request with an\ + inappropriate 401 request for target-host credentials" + } else { + } + } else { + set msg "connection to proxy failed with status code $code" } - return $sock + # - ${token2}(sock) has already been closed because -keepalive 0. + # - Error return does not pass the socket ID to the + # $token transaction, which retains its socket placeholder. + cleanup $token2 + return -code error $msg +} + +proc http::AllDone {varName args} { + set $varName done + return } -- cgit v0.12 From 0a9238b48a692d42d47391c88a59e76e3c3d8a52 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 7 Nov 2022 21:53:19 +0000 Subject: library/http/http.tcl - in http::SecureProxyConnect, bugfix state(proxyUsed) so the correct value SecureProxyFailed or SecureProxy is returned. --- library/http/http.tcl | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 907256e..0ba201e 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -805,7 +805,7 @@ proc http::CloseQueuedQueries {connId {token {}}} { variable socketPlayCmd variable socketCoEvent - ##Log CloseQueuedQueries $connId + ##Log CloseQueuedQueries $connId $token if {![info exists socketMapping($connId)]} { # Command has already been called. # Don't come here again - especially recursively. @@ -1725,7 +1725,9 @@ proc http::OpenSocket {token DoLater} { # Code above has set state(sock) $sock ConfigureNewSocket $token $sockOld $DoLater + ##Log OpenSocket success $sock - token $token } result errdict]} { + ##Log OpenSocket failed $result - token $token if {[string range $result 0 20] eq {proxy connect failed:}} { # - The HTTPS proxy did not create a socket. The pre-existing value # (a "placeholder socket") is unchanged. @@ -4958,8 +4960,12 @@ proc http::SecureProxyConnect {args} { # Record in the token that this is a proxy call. set token [lindex $args $targ+1] upvar 0 ${token} state - set state(proxyUsed) SecureProxy set tim $state(-timeout) + set state(proxyUsed) SecureProxyFailed + # This value is overwritten with "SecureProxy" below if the CONNECT is + # successful. If it is unsuccessful, the socket will be closed + # below, and so in this unsuccessful case there are no other transactions + # whose (proxyUsed) must be updated. } else { set tim 0 } @@ -5023,6 +5029,11 @@ proc http::SecureProxyConnect {args} { # All OK. The caller in package tls will now call "tls::import $sock". # The cleanup command does not close $sock. # Other tidying was done in http::Event. + + # If this is a persistent socket, any other transactions that are + # already marked to use the socket will have their (proxyUsed) updated + # when http::OpenSocket calls http::ConfigureNewSocket. + set state(proxyUsed) SecureProxy set sock $state2(sock) cleanup $token2 return $sock @@ -5039,7 +5050,6 @@ proc http::SecureProxyConnect {args} { set state($name) $state2($name) } } - set state(proxyUsed) SecureProxyFailed set state(connection) close set msg "proxy connect failed: $code" # - This error message will be detected by http::OpenSocket and will -- cgit v0.12 From c3e9fc9aedad22f58fd1fe766f6d01ccb8d3d6f7 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 7 Nov 2022 22:02:33 +0000 Subject: library/http/http.tcl - define http::socketProxyId and use it to record the proxy (if any) used by each persistent socket. Minor fix to socketPhQueue. --- library/http/http.tcl | 47 +++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 45 insertions(+), 2 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 0ba201e..f1d5f8b 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -77,6 +77,7 @@ namespace eval http { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId if {[info exists socketMapping]} { # Close open sockets on re-init. Do not permit retries. foreach {url sock} [array get socketMapping] { @@ -101,6 +102,7 @@ namespace eval http { array unset socketClosing array unset socketPlayCmd array unset socketCoEvent + array unset socketProxyId array set socketMapping {} array set socketRdState {} array set socketWrState {} @@ -110,6 +112,7 @@ namespace eval http { array set socketClosing {} array set socketPlayCmd {} array set socketCoEvent {} + array set socketProxyId {} return } init @@ -407,6 +410,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId variable $token upvar 0 $token state @@ -540,6 +544,7 @@ proc http::KeepSocket {token} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId variable $token upvar 0 $token state @@ -742,6 +747,7 @@ proc http::CloseSocket {s {token {}}} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId set tk [namespace tail $token] @@ -804,6 +810,7 @@ proc http::CloseQueuedQueries {connId {token {}}} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId ##Log CloseQueuedQueries $connId $token if {![info exists socketMapping($connId)]} { @@ -865,6 +872,7 @@ proc http::Unset {connId} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId unset socketMapping($connId) unset socketRdState($connId) @@ -873,6 +881,7 @@ proc http::Unset {connId} { unset -nocomplain socketWrQueue($connId) unset -nocomplain socketClosing($connId) unset -nocomplain socketPlayCmd($connId) + unset -nocomplain socketProxyId($connId) return } @@ -1344,6 +1353,11 @@ proc http::CreateToken {url args} { set srvurl $url set targetAddr [list $phost $pport] set state(proxyUsed) HttpProxy + # The value of state(proxyUsed) none|HttpProxy depends only on the + # all-transactions http::config settings and on the target URL. + # Even if this is a persistent socket there is no need to change the + # value of state(proxyUsed) for other transactions that use the socket: + # they have the same value already. } else { set targetAddr [list $host $port] } @@ -1379,6 +1393,7 @@ proc http::CreateToken {url args} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId if {[info exists socketMapping($state(socketinfo))]} { # - If the connection is idle, it has a "fileevent readable" binding @@ -1401,6 +1416,7 @@ proc http::CreateToken {url args} { # causes a call to Finish. set reusing 1 set sock $socketMapping($state(socketinfo)) + set state(proxyUsed) $socketProxyId($state(socketinfo)) Log "reusing closing socket $sock for $state(socketinfo) - token $token" set state(alreadyQueued) 1 @@ -1435,6 +1451,7 @@ proc http::CreateToken {url args} { # - The socket may not yet exist, and be defined with a placeholder. set reusing 1 set sock $socketMapping($state(socketinfo)) + set state(proxyUsed) $socketProxyId($state(socketinfo)) if {[SockIsPlaceHolder $sock]} { set state(ReusingPlaceholder) 1 lappend socketPhQueue($sock) $token @@ -1533,6 +1550,7 @@ proc http::AsyncTransaction {token} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId set sock $state(sock) @@ -1609,9 +1627,15 @@ proc http::PreparePersistentConnection {token} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId set DoLater {-traceread 0 -tracewrite 0} set socketMapping($state(socketinfo)) $state(sock) + set socketProxyId($state(socketinfo)) $state(proxyUsed) + # - The value of state(proxyUsed) was set in http::CreateToken to either + # "none" or "HttpProxy". + # - $token is the first transaction to use this placeholder, so there are + # no other tokens whose (proxyUsed) must be modified. if {![info exists socketRdState($state(socketinfo))]} { set socketRdState($state(socketinfo)) {} @@ -1643,10 +1667,11 @@ proc http::PreparePersistentConnection {token} { set socketRdQueue($state(socketinfo)) {} set socketWrQueue($state(socketinfo)) {} - set socketPhQueue($state(socketinfo)) {} + set socketPhQueue($state(sock)) {} set socketClosing($state(socketinfo)) 0 set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}} set socketCoEvent($state(socketinfo)) {} + set socketProxyId($state(socketinfo)) {} return $DoLater } @@ -1679,6 +1704,7 @@ proc http::OpenSocket {token DoLater} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId Log >K$tk Start OpenSocket coroutine @@ -1795,9 +1821,11 @@ proc http::ConfigureNewSocket {token sockOld DoLater} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId set reusing $state(reusing) set sock $state(sock) + set proxyUsed $state(proxyUsed) ##Log " ConfigureNewSocket" $token $sockOld ... -- $sock if {(!$reusing) && ($sock ne $sockOld)} { @@ -1807,6 +1835,8 @@ proc http::ConfigureNewSocket {token sockOld DoLater} { && ($socketMapping($state(socketinfo)) eq $sockOld) } { set socketMapping($state(socketinfo)) $sock + set socketProxyId($state(socketinfo)) $proxyUsed + # tokens that use the placeholder $sockOld are updated below. ##Log set socketMapping($state(socketinfo)) $sock } @@ -1846,6 +1876,7 @@ proc http::ConfigureNewSocket {token sockOld DoLater} { # 1. Amend the token's (sock). ##Log set ${tok}(sock) $sock set ${tok}(sock) $sock + set ${tok}(proxyUsed) $proxyUsed # 2. Schedule the token's HTTP request. # Every token in socketPhQueue(*) has reusing 1 alreadyQueued 0. @@ -1876,7 +1907,7 @@ proc http::ConfigureNewSocket {token sockOld DoLater} { # waiting until the read(s) in progress are finished). # socketRdQueue($connId) List of tokens that are queued for reading later. # socketWrQueue($connId) List of tokens that are queued for writing later. -# socketPhQueue($connId) List of tokens that are queued to use a placeholder +# socketPhQueue($sock) List of tokens that are queued to use a placeholder # socket, when the real socket has not yet been created. # socketClosing($connId) (boolean) true iff a server response header indicates # that the server will close the connection at the end of @@ -1885,6 +1916,11 @@ proc http::ConfigureNewSocket {token sockOld DoLater} { # part-completed transactions if the socket closes early. # socketCoEvent($connId) Identifier for the "after idle" event that will launch # an OpenSocket coroutine to open or re-use a socket. +# socketProxyId($connId) The type of proxy that this socket uses: values are +# those of state(proxyUsed) i.e. none, HttpProxy, +# SecureProxy, and SecureProxyFailed. +# The value is not used for anything by http, its purpose +# is to set the value of state() for caller information. # ------------------------------------------------------------------------------ @@ -1940,6 +1976,7 @@ proc http::ScheduleRequest {token} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId set Unfinished 0 @@ -2085,6 +2122,7 @@ proc http::Connected {token proto phost srvurl} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId variable $token upvar 0 $token state @@ -2424,6 +2462,7 @@ proc http::DoneRequest {token} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId variable $token upvar 0 $token state @@ -2755,6 +2794,7 @@ proc http::ReplayIfDead {token doing} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId variable $token upvar 0 $token state @@ -2998,6 +3038,7 @@ proc http::ReplayCore {newQueue} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId if {[llength $newQueue] == 0} { # Nothing to do. @@ -3347,6 +3388,7 @@ proc http::Write {token} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId variable $token upvar 0 $token state @@ -3459,6 +3501,7 @@ proc http::Event {sock token} { variable socketClosing variable socketPlayCmd variable socketCoEvent + variable socketProxyId variable $token upvar 0 $token state -- cgit v0.12 From 03a9eaa9512a6a1a87cc4c3225caa6bbcb44cdb1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 7 Nov 2022 22:04:59 +0000 Subject: Use TCLFLEXARRAY --- generic/tclTrace.c | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 8999858..6749978 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -56,7 +56,7 @@ typedef struct { * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ - char command[1]; /* Space for Tcl command to invoke. Actual + char command[TCLFLEXARRAY]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to hold * command. This field must be the last in the * structure, so that it can be larger than 1 @@ -1039,7 +1039,7 @@ TraceVariableObjCmd( *---------------------------------------------------------------------- */ -ClientData +void * Tcl_CommandTraceInfo( Tcl_Interp *interp, /* Interpreter containing command. */ const char *cmdName, /* Name of command. */ @@ -1818,7 +1818,8 @@ TraceExecutionProc( if (call) { Tcl_DString cmd, sub; - int i, saveInterpFlags; + int i; + int saveInterpFlags; Tcl_DStringInit(&cmd); Tcl_DStringAppend(&cmd, tcmdPtr->command, tcmdPtr->length); @@ -2074,7 +2075,7 @@ TraceVarProc( /* *---------------------------------------------------------------------- * - * Tcl_CreateObjTrace -- + * Tcl_CreateObjTrace/Tcl_CreateObjTrace2 -- * * Arrange for a function to be called to trace command execution. * @@ -2087,7 +2088,7 @@ TraceVarProc( * called to execute a Tcl command. Calls to proc will have the following * form: * - * void proc(ClientData clientData, + * void proc(void * clientData, * Tcl_Interp * interp, * int level, * const char * command, @@ -3036,7 +3037,7 @@ Tcl_UntraceVar2( *---------------------------------------------------------------------- */ -ClientData +void * Tcl_VarTraceInfo2( Tcl_Interp *interp, /* Interpreter containing variable. */ const char *part1, /* Name of variable or array. */ -- cgit v0.12 From e977d6e7af0d658006f243be34f927a266b0fc23 Mon Sep 17 00:00:00 2001 From: kjnash Date: Mon, 7 Nov 2022 22:06:42 +0000 Subject: library/http/http.tcl - bugfix OpenSocket to replay any requests in the socketPhQueue placeholder queue, if the socket was not created. --- library/http/http.tcl | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index f1d5f8b..4c9f6a7 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -1753,7 +1753,20 @@ proc http::OpenSocket {token DoLater} { ConfigureNewSocket $token $sockOld $DoLater ##Log OpenSocket success $sock - token $token } result errdict]} { - ##Log OpenSocket failed $result - token $token + ##Log OpenSocket failed $result - token $token + # There may be other requests in the socketPhQueue. + # Prepare socketPlayCmd so that Finish will replay them. + if { ($state(-keepalive)) && (!$state(reusing)) + && [info exists socketPhQueue($sockOld)] + && ($socketPhQueue($sockOld) ne {}) + } { + if {$socketMapping($state(socketinfo)) ne $sockOld} { + Log "WARNING: this code should not be reached.\ + {$socketMapping($state(socketinfo)) ne $sockOld}" + } + set socketPlayCmd($state(socketinfo)) [list ReplayIfClose Wready {} $socketPhQueue($sockOld)] + set socketPhQueue($sockOld) {} + } if {[string range $result 0 20] eq {proxy connect failed:}} { # - The HTTPS proxy did not create a socket. The pre-existing value # (a "placeholder socket") is unchanged. -- cgit v0.12 From 7e8c940ac114ea986ce22a24a142df025e0b1bbb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Nov 2022 07:28:44 +0000 Subject: Fix "package files tcl", considering TIP #590 --- generic/tclInterp.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index c5f84db..ad24d28 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -333,7 +333,7 @@ int Tcl_Init( Tcl_Interp *interp) /* Interpreter to initialize. */ { - PkgName pkgName = {NULL, "Tcl"}; + PkgName pkgName = {NULL, "tcl"}; PkgName **names = (PkgName **)TclInitPkgFiles(interp); int result = TCL_ERROR; -- cgit v0.12 From 008001c3b5e35ff3c122f2eb1bf566d93746b172 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Nov 2022 07:30:42 +0000 Subject: More TCLFLEXARRAY usage --- generic/tclPkg.c | 2 +- generic/tclTrace.c | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index fd45cc1..bfe1c66 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -40,7 +40,7 @@ typedef struct PkgAvail { typedef struct PkgName { struct PkgName *nextPtr; /* Next in list of package names being * initialized. */ - char name[1]; + char name[TCLFLEXARRAY]; } PkgName; typedef struct PkgFiles { diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 0c243a6..bed5084 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -22,7 +22,7 @@ typedef struct { int flags; /* Operations for which Tcl command is to be * invoked. */ size_t length; /* Number of non-NUL chars. in command. */ - char command[1]; /* Space for Tcl command to invoke. Actual + char command[TCLFLEXARRAY]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to hold * command. This field must be the last in the * structure, so that it can be larger than 1 @@ -56,7 +56,7 @@ typedef struct { * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ - char command[1]; /* Space for Tcl command to invoke. Actual + char command[TCLFLEXARRAY]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to hold * command. This field must be the last in the * structure, so that it can be larger than 1 -- cgit v0.12 From 2afe485f41e0c7303cbf8d181745c56f7d19f5b0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Nov 2022 09:59:28 +0000 Subject: NEVER use sizeof(FLEXARRAY)! Use offsetof() --- generic/tclPkg.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclPkg.c b/generic/tclPkg.c index bfe1c66..7866158 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -828,7 +828,7 @@ SelectPackage( * Push "ifneeded" package name in "tclPkgFiles" assocdata. */ - pkgName = (PkgName *)ckalloc(sizeof(PkgName) + strlen(name)); + pkgName = (PkgName *)ckalloc(offsetof(PkgName, name) + 1 + strlen(name)); pkgName->nextPtr = pkgFiles->names; strcpy(pkgName->name, name); pkgFiles->names = pkgName; -- cgit v0.12 From b6c0957a8f2f5b52b9c0f1c1c433cda524970f99 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Nov 2022 20:27:01 +0000 Subject: More int -> size_t (argc and level) in trace handling --- doc/CrtObjCmd.3 | 2 +- doc/CrtTrace.3 | 16 +++++++- generic/tcl.decls | 6 +-- generic/tcl.h | 4 +- generic/tclDecls.h | 18 +++++---- generic/tclInt.h | 6 ++- generic/tclTrace.c | 110 ++++++++++++++++++++++++++--------------------------- 7 files changed, 91 insertions(+), 71 deletions(-) diff --git a/doc/CrtObjCmd.3 b/doc/CrtObjCmd.3 index 012c46c..ffd9e27 100644 --- a/doc/CrtObjCmd.3 +++ b/doc/CrtObjCmd.3 @@ -224,7 +224,7 @@ pointed to by \fIinfoPtr\fR and returns 1. A \fBTcl_CmdInfo\fR structure has the following fields: .PP .CS -typedef struct Tcl_CmdInfo { +typedef struct { int \fIisNativeObjectProc\fR; Tcl_ObjCmdProc *\fIobjProc\fR; void *\fIobjClientData\fR; diff --git a/doc/CrtTrace.3 b/doc/CrtTrace.3 index 6833fc5..e4d1a43 100644 --- a/doc/CrtTrace.3 +++ b/doc/CrtTrace.3 @@ -29,7 +29,7 @@ Tcl_Trace .AS Tcl_CmdObjTraceDeleteProc *deleteProc .AP Tcl_Interp *interp in Interpreter containing command to be traced or untraced. -.AP int level in +.AP size_t level in Only commands at or below this nesting level will be traced unless 0 is specified. 1 means top-level commands only, 2 means top-level commands or those that are @@ -81,6 +81,20 @@ typedef int \fBTcl_CmdObjTraceProc\fR( \fBTcl_Obj\fR *const \fIobjv\fR[]); .CE .PP +\fIobjProc2\fR should have arguments and result that match the type, +\fBTcl_CmdObjTraceProc2\fR: +.PP +.CS +typedef int \fBTcl_CmdObjTraceProc2\fR( + \fBvoid *\fR \fIclientData\fR, + \fBTcl_Interp\fR* \fIinterp\fR, + size_t \fIlevel\fR, + const char *\fIcommand\fR, + \fBTcl_Command\fR \fIcommandToken\fR, + size_t \fIobjc\fR, + \fBTcl_Obj\fR *const \fIobjv\fR[]); +.CE +.PP The \fIclientData\fR and \fIinterp\fR parameters are copies of the corresponding arguments given to \fBTcl_CreateTrace\fR. \fIclientData\fR typically points to an application-specific data diff --git a/generic/tcl.decls b/generic/tcl.decls index 0def57e..322d0cf 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -388,7 +388,7 @@ declare 98 { Tcl_TimerProc *proc, void *clientData) } declare 99 { - Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, + Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, Tcl_Size level, Tcl_CmdTraceProc *proc, void *clientData) } declare 100 { @@ -1781,7 +1781,7 @@ declare 482 { # TIP#32 (object-enabled traces) kbk declare 483 { - Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, int flags, + Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc) } @@ -2576,7 +2576,7 @@ declare 676 { Tcl_CmdDeleteProc *deleteProc) } declare 677 { - Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, int level, int flags, + Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc) } diff --git a/generic/tcl.h b/generic/tcl.h index 706c5f1..a2fd2a4 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -558,7 +558,7 @@ typedef int (Tcl_CmdObjTraceProc) (void *clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandInfo, int objc, struct Tcl_Obj *const *objv); typedef int (Tcl_CmdObjTraceProc2) (void *clientData, Tcl_Interp *interp, - int level, const char *command, Tcl_Command commandInfo, size_t objc, + size_t level, const char *command, Tcl_Command commandInfo, size_t objc, struct Tcl_Obj *const *objv); typedef void (Tcl_CmdObjTraceDeleteProc) (void *clientData); typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr, @@ -773,7 +773,7 @@ typedef struct Tcl_CallFrame { * then calls the other function. */ -typedef struct Tcl_CmdInfo { +typedef struct { int isNativeObjectProc; /* 1 if objProc was registered by a call to * Tcl_CreateObjCommand; 2 if objProc was registered by * a call to Tcl_CreateObjCommand2; 0 otherwise. diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 8040adf..8e4aa59 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -306,7 +306,7 @@ EXTERN Tcl_Interp * Tcl_CreateChild(Tcl_Interp *interp, const char *name, EXTERN Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds, Tcl_TimerProc *proc, void *clientData); /* 99 */ -EXTERN Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, +EXTERN Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, Tcl_Size level, Tcl_CmdTraceProc *proc, void *clientData); /* 100 */ EXTERN void Tcl_DeleteAssocData(Tcl_Interp *interp, @@ -1263,8 +1263,9 @@ EXTERN int Tcl_EvalTokensStandard(Tcl_Interp *interp, /* 482 */ EXTERN void Tcl_GetTime(Tcl_Time *timeBuf); /* 483 */ -EXTERN Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, - int flags, Tcl_CmdObjTraceProc *objProc, +EXTERN Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, + Tcl_Size level, int flags, + Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 484 */ @@ -1824,8 +1825,9 @@ EXTERN Tcl_Command Tcl_CreateObjCommand2(Tcl_Interp *interp, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 677 */ -EXTERN Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, int level, - int flags, Tcl_CmdObjTraceProc2 *objProc2, +EXTERN Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, + Tcl_Size level, int flags, + Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 678 */ @@ -1960,7 +1962,7 @@ typedef struct TclStubs { Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */ Tcl_Interp * (*tcl_CreateChild) (Tcl_Interp *interp, const char *name, int isSafe); /* 97 */ Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, void *clientData); /* 98 */ - Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, void *clientData); /* 99 */ + Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, Tcl_Size level, Tcl_CmdTraceProc *proc, void *clientData); /* 99 */ void (*tcl_DeleteAssocData) (Tcl_Interp *interp, const char *name); /* 100 */ void (*tcl_DeleteChannelHandler) (Tcl_Channel chan, Tcl_ChannelProc *proc, void *clientData); /* 101 */ void (*tcl_DeleteCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, void *clientData); /* 102 */ @@ -2344,7 +2346,7 @@ typedef struct TclStubs { void (*tcl_FSMountsChanged) (const Tcl_Filesystem *fsPtr); /* 480 */ int (*tcl_EvalTokensStandard) (Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Size count); /* 481 */ void (*tcl_GetTime) (Tcl_Time *timeBuf); /* 482 */ - Tcl_Trace (*tcl_CreateObjTrace) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 483 */ + Tcl_Trace (*tcl_CreateObjTrace) (Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 483 */ int (*tcl_GetCommandInfoFromToken) (Tcl_Command token, Tcl_CmdInfo *infoPtr); /* 484 */ int (*tcl_SetCommandInfoFromToken) (Tcl_Command token, const Tcl_CmdInfo *infoPtr); /* 485 */ Tcl_Obj * (*tcl_DbNewWideIntObj) (Tcl_WideInt wideValue, const char *file, int line); /* 486 */ @@ -2538,7 +2540,7 @@ typedef struct TclStubs { int (*tcl_GetBool) (Tcl_Interp *interp, const char *src, int flags, char *charPtr); /* 674 */ int (*tcl_GetBoolFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, char *charPtr); /* 675 */ Tcl_Command (*tcl_CreateObjCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 676 */ - Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */ + Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */ Tcl_Command (*tcl_NRCreateCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc, Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 678 */ int (*tcl_NRCallObjProc2) (Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, void *clientData, size_t objc, Tcl_Obj *const objv[]); /* 679 */ int (*tcl_GetNumberFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void **clientDataPtr, int *typePtr); /* 680 */ diff --git a/generic/tclInt.h b/generic/tclInt.h index a633a17..1b817e9 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1041,9 +1041,13 @@ typedef void (ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj); */ typedef struct Trace { - int level; /* Only trace commands at nesting level less + Tcl_Size level; /* Only trace commands at nesting level less * than or equal to this. */ +#if TCL_MAJOR_VERSION > 8 + Tcl_CmdObjTraceProc2 *proc; /* Procedure to call to trace command. */ +#else Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */ +#endif void *clientData; /* Arbitrary value to pass to proc. */ struct Trace *nextPtr; /* Next in list of traces for this interp. */ int flags; /* Flags governing the trace - see diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 2c525b0..1b70f1e 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -44,7 +44,7 @@ typedef struct { size_t length; /* Number of non-NUL chars. in command. */ Tcl_Trace stepTrace; /* Used for execution traces, when tracing * inside the given command */ - int startLevel; /* Used for bookkeeping with step execution + Tcl_Size startLevel; /* Used for bookkeeping with step execution * traces, store the level at which the step * trace was invoked */ char *startCmd; /* Used for bookkeeping with step execution @@ -99,7 +99,7 @@ enum traceOptions { #endif }; typedef int (Tcl_TraceTypeObjCmd)(Tcl_Interp *interp, enum traceOptions optionIndex, - int objc, Tcl_Obj *const objv[]); + Tcl_Size objc, Tcl_Obj *const objv[]); static Tcl_TraceTypeObjCmd TraceVariableObjCmd; static Tcl_TraceTypeObjCmd TraceCommandObjCmd; @@ -126,18 +126,18 @@ static Tcl_TraceTypeObjCmd *const traceSubCmds[] = { */ static int CallTraceFunction(Tcl_Interp *interp, Trace *tracePtr, - Command *cmdPtr, const char *command, size_t numChars, - int objc, Tcl_Obj *const objv[]); + Command *cmdPtr, const char *command, Tcl_Size numChars, + Tcl_Size objc, Tcl_Obj *const objv[]); static char * TraceVarProc(void *clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); static void TraceCommandProc(void *clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); -static Tcl_CmdObjTraceProc TraceExecutionProc; +static Tcl_CmdObjTraceProc2 TraceExecutionProc; static int StringTraceProc(void *clientData, - Tcl_Interp *interp, int level, + Tcl_Interp *interp, Tcl_Size level, const char *command, Tcl_Command commandInfo, - int objc, Tcl_Obj *const objv[]); + Tcl_Size objc, Tcl_Obj *const objv[]); static void StringTraceDeleteProc(void *clientData); static void DisposeTraceResult(int flags, char *result); static int TraceVarEx(Tcl_Interp *interp, const char *part1, @@ -270,7 +270,7 @@ Tcl_TraceObjCmd( Tcl_Obj *copyObjv[6]; Tcl_Obj *opsList; int code; - size_t numFlags; + Tcl_Size numFlags; if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); @@ -399,11 +399,11 @@ static int TraceExecutionObjCmd( Tcl_Interp *interp, /* Current interpreter. */ enum traceOptions optionIndex, /* Add, info or remove */ - int objc, /* Number of arguments. */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *name, *command; - size_t commandLength, length; + Tcl_Size length; static const char *const opStrings[] = { "enter", "leave", "enterstep", "leavestep", NULL }; @@ -416,7 +416,7 @@ TraceExecutionObjCmd( case TRACE_ADD: case TRACE_REMOVE: { int flags = 0, result; - size_t i, listLen; + Tcl_Size i, listLen; Tcl_Obj **elemPtrs; if (objc != 6) { @@ -461,8 +461,7 @@ TraceExecutionObjCmd( break; } } - command = Tcl_GetStringFromObj(objv[5], &commandLength); - length = commandLength; + command = Tcl_GetStringFromObj(objv[5], &length); if (optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)Tcl_Alloc( offsetof(TraceCommandInfo, command) + 1 + length); @@ -571,7 +570,7 @@ TraceExecutionObjCmd( resultListPtr = Tcl_NewListObj(0, NULL); FOREACH_COMMAND_TRACE(interp, name, clientData) { - size_t numOps = 0; + Tcl_Size numOps = 0; Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr; TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; @@ -647,11 +646,11 @@ static int TraceCommandObjCmd( Tcl_Interp *interp, /* Current interpreter. */ enum traceOptions optionIndex, /* Add, info or remove */ - int objc, /* Number of arguments. */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *name, *command; - size_t commandLength, length; + Tcl_Size length; static const char *const opStrings[] = { "delete", "rename", NULL }; enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME } index; @@ -659,7 +658,7 @@ TraceCommandObjCmd( case TRACE_ADD: case TRACE_REMOVE: { int flags = 0, result; - size_t i, listLen; + Tcl_Size i, listLen; Tcl_Obj **elemPtrs; if (objc != 6) { @@ -700,8 +699,7 @@ TraceCommandObjCmd( } } - command = Tcl_GetStringFromObj(objv[5], &commandLength); - length = commandLength; + command = Tcl_GetStringFromObj(objv[5], &length); if (optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)Tcl_Alloc( offsetof(TraceCommandInfo, command) + 1 + length); @@ -776,7 +774,7 @@ TraceCommandObjCmd( resultListPtr = Tcl_NewListObj(0, NULL); FOREACH_COMMAND_TRACE(interp, name, clientData) { - size_t numOps = 0; + Tcl_Size numOps = 0; Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr; TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; @@ -843,11 +841,11 @@ static int TraceVariableObjCmd( Tcl_Interp *interp, /* Current interpreter. */ enum traceOptions optionIndex, /* Add, info or remove */ - int objc, /* Number of arguments. */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { const char *name, *command; - size_t commandLength, length; + Tcl_Size length; void *clientData; static const char *const opStrings[] = { "array", "read", "unset", "write", NULL @@ -860,7 +858,7 @@ TraceVariableObjCmd( case TRACE_ADD: case TRACE_REMOVE: { int flags = 0, result; - size_t i, listLen; + Tcl_Size i, listLen; Tcl_Obj **elemPtrs; if (objc != 6) { @@ -905,8 +903,7 @@ TraceVariableObjCmd( break; } } - command = Tcl_GetStringFromObj(objv[5], &commandLength); - length = commandLength; + command = Tcl_GetStringFromObj(objv[5], &length); if (optionIndex == TRACE_ADD) { CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)Tcl_Alloc( offsetof(CombinedTraceVarInfo, traceCmdInfo.command) @@ -1423,17 +1420,17 @@ TclCheckExecutionTraces( Tcl_Interp *interp, /* The current interpreter. */ const char *command, /* Pointer to beginning of the current command * string. */ - TCL_UNUSED(size_t) /*numChars*/, + TCL_UNUSED(Tcl_Size) /*numChars*/, Command *cmdPtr, /* Points to command's Command struct. */ int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ - size_t objc, /* Number of arguments for the command. */ + Tcl_Size objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; CommandTrace *tracePtr, *lastTracePtr; ActiveCommandTrace active; - int curLevel; + Tcl_Size curLevel; int traceCode = TCL_OK; Tcl_InterpState state = NULL; @@ -1528,18 +1525,18 @@ TclCheckInterpTraces( Tcl_Interp *interp, /* The current interpreter. */ const char *command, /* Pointer to beginning of the current command * string. */ - size_t numChars, /* The number of characters in 'command' which + Tcl_Size numChars, /* The number of characters in 'command' which * are part of the command string. */ Command *cmdPtr, /* Points to command's Command struct. */ int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ - size_t objc, /* Number of arguments for the command. */ + Tcl_Size objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; Trace *tracePtr, *lastTracePtr; ActiveInterpTrace active; - int curLevel; + Tcl_Size curLevel; int traceCode = TCL_OK; Tcl_InterpState state = NULL; @@ -1675,9 +1672,9 @@ CallTraceFunction( Command *cmdPtr, /* Points to command's Command struct. */ const char *command, /* Points to the first character of the * command's source before substitutions. */ - size_t numChars, /* The number of characters in the command's + Tcl_Size numChars, /* The number of characters in the command's * source. */ - int objc, /* Number of arguments for the command. */ + Tcl_Size objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; @@ -1760,10 +1757,10 @@ static int TraceExecutionProc( void *clientData, Tcl_Interp *interp, - int level, + Tcl_Size level, const char *command, TCL_UNUSED(Tcl_Command), - int objc, + Tcl_Size objc, Tcl_Obj *const objv[]) { int call = 0; @@ -1818,7 +1815,7 @@ TraceExecutionProc( if (call) { Tcl_DString cmd, sub; - int i; + Tcl_Size i; int saveInterpFlags; Tcl_DStringInit(&cmd); @@ -1926,7 +1923,7 @@ TraceExecutionProc( tcmdPtr->startCmd = (char *)Tcl_Alloc(len); memcpy(tcmdPtr->startCmd, command, len); tcmdPtr->refCount++; - tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, + tcmdPtr->stepTrace = Tcl_CreateObjTrace2(interp, 0, (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, TraceExecutionProc, tcmdPtr, CommandObjTraceDeleted); } @@ -2128,7 +2125,7 @@ TraceVarProc( */ typedef struct { - Tcl_CmdObjTraceProc2 *proc; + Tcl_CmdObjTraceProc *proc; Tcl_CmdObjTraceDeleteProc *delProc; void *clientData; } TraceWrapperInfo; @@ -2136,14 +2133,17 @@ typedef struct { static int traceWrapperProc( void *clientData, Tcl_Interp *interp, - int level, + Tcl_Size level, const char *command, Tcl_Command commandInfo, - int objc, + Tcl_Size objc, Tcl_Obj *const objv[]) { TraceWrapperInfo *info = (TraceWrapperInfo *)clientData; - return info->proc(info->clientData, interp, level, command, commandInfo, objc, objv); + if (objc > INT_MAX) { + objc = -1; /* Signal Tcl_CmdObjTraceProc that objc is out of range */ + } + return info->proc(info->clientData, interp, (int)level, command, commandInfo, objc, objv); } static void traceWrapperDelProc(void *clientData) @@ -2157,30 +2157,30 @@ static void traceWrapperDelProc(void *clientData) } Tcl_Trace -Tcl_CreateObjTrace2( +Tcl_CreateObjTrace( Tcl_Interp *interp, /* Tcl interpreter */ - int level, /* Maximum nesting level */ + Tcl_Size level, /* Maximum nesting level */ int flags, /* Flags, see above */ - Tcl_CmdObjTraceProc2 *proc, /* Trace callback */ + Tcl_CmdObjTraceProc *proc, /* Trace callback */ void *clientData, /* Client data for the callback */ Tcl_CmdObjTraceDeleteProc *delProc) /* Function to call when trace is deleted */ { - TraceWrapperInfo *info = (TraceWrapperInfo *)Tcl_Alloc(sizeof(TraceWrapperInfo)); + TraceWrapperInfo *info = (TraceWrapperInfo *)Tcl_Alloc(sizeof(TraceWrapperInfo)); info->proc = proc; info->delProc = delProc; info->clientData = clientData; - return Tcl_CreateObjTrace(interp, level, flags, + return Tcl_CreateObjTrace2(interp, level, flags, (proc ? traceWrapperProc : NULL), info, traceWrapperDelProc); } Tcl_Trace -Tcl_CreateObjTrace( +Tcl_CreateObjTrace2( Tcl_Interp *interp, /* Tcl interpreter */ - int level, /* Maximum nesting level */ + Tcl_Size level, /* Maximum nesting level */ int flags, /* Flags, see above */ - Tcl_CmdObjTraceProc *proc, /* Trace callback */ + Tcl_CmdObjTraceProc2 *proc2, /* Trace callback */ void *clientData, /* Client data for the callback */ Tcl_CmdObjTraceDeleteProc *delProc) /* Function to call when trace is deleted */ @@ -2212,7 +2212,7 @@ Tcl_CreateObjTrace( tracePtr = (Trace *)Tcl_Alloc(sizeof(Trace)); tracePtr->level = level; - tracePtr->proc = proc; + tracePtr->proc = proc2; tracePtr->clientData = clientData; tracePtr->delProc = delProc; tracePtr->nextPtr = iPtr->tracePtr; @@ -2267,7 +2267,7 @@ Tcl_CreateObjTrace( Tcl_Trace Tcl_CreateTrace( Tcl_Interp *interp, /* Interpreter in which to create trace. */ - int level, /* Only call proc for commands at nesting + Tcl_Size level, /* Only call proc for commands at nesting * level<=argument level (1=>top level). */ Tcl_CmdTraceProc *proc, /* Function to call before executing each * command. */ @@ -2277,7 +2277,7 @@ Tcl_CreateTrace( data->clientData = clientData; data->proc = proc; - return Tcl_CreateObjTrace(interp, level, 0, StringTraceProc, + return Tcl_CreateObjTrace2(interp, level, 0, StringTraceProc, data, StringTraceDeleteProc); } @@ -2301,16 +2301,16 @@ static int StringTraceProc( void *clientData, Tcl_Interp *interp, - int level, + Tcl_Size level, const char *command, Tcl_Command commandInfo, - int objc, + Tcl_Size objc, Tcl_Obj *const *objv) { StringTraceData *data = (StringTraceData *)clientData; Command *cmdPtr = (Command *) commandInfo; const char **argv; /* Args to pass to string trace proc */ - int i; + Tcl_Size i; /* * This is a bit messy because we have to emulate the old trace interface, -- cgit v0.12 From a90bc45a547c857ffc5257490827aebfb7ac6d8d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 8 Nov 2022 21:58:01 +0000 Subject: int -> size_t in Tcl_CmdObjTraceProc2 (for 'level'). Add missing documentation --- doc/CrtTrace.3 | 24 ++++-- generic/tcl.decls | 6 +- generic/tcl.h | 2 +- generic/tclDecls.h | 18 +++-- generic/tclInt.h | 2 +- generic/tclTrace.c | 230 +++++++++++++++++++++++++++-------------------------- 6 files changed, 153 insertions(+), 129 deletions(-) diff --git a/doc/CrtTrace.3 b/doc/CrtTrace.3 index 417c892..723a392 100644 --- a/doc/CrtTrace.3 +++ b/doc/CrtTrace.3 @@ -47,7 +47,7 @@ details of the calling sequence. .AP Tcl_CmdTraceProc *proc in Procedure to call for each command that is executed. See below for details on the calling sequence. -.AP ClientData clientData in +.AP void *clientData in Arbitrary one-word value to pass to \fIobjProc\fR, \fIobjProc2\fR or \fIproc\fR. .AP Tcl_CmdObjTraceDeleteProc *deleteProc in Procedure to call when the trace is deleted. See below for details of @@ -72,7 +72,7 @@ interpreter. .PP .CS typedef int \fBTcl_CmdObjTraceProc\fR( - \fBClientData\fR \fIclientData\fR, + \fBvoid *\fR \fIclientData\fR, \fBTcl_Interp\fR* \fIinterp\fR, int \fIlevel\fR, const char *\fIcommand\fR, @@ -81,6 +81,20 @@ typedef int \fBTcl_CmdObjTraceProc\fR( \fBTcl_Obj\fR *const \fIobjv\fR[]); .CE .PP +\fIobjProc2\fR should have arguments and result that match the type, +\fBTcl_CmdObjTraceProc2\fR: +.PP +.CS +typedef int \fBTcl_CmdObjTraceProc2\fR( + \fBvoid *\fR \fIclientData\fR, + \fBTcl_Interp\fR* \fIinterp\fR, + size_t \fIlevel\fR, + const char *\fIcommand\fR, + \fBTcl_Command\fR \fIcommandToken\fR, + size_t \fIobjc\fR, + \fBTcl_Obj\fR *const \fIobjv\fR[]); +.CE +.PP The \fIclientData\fR and \fIinterp\fR parameters are copies of the corresponding arguments given to \fBTcl_CreateTrace\fR. \fIClientData\fR typically points to an application-specific data @@ -146,7 +160,7 @@ When \fBTcl_DeleteTrace\fR is called, the interpreter invokes the .PP .CS typedef void \fBTcl_CmdObjTraceDeleteProc\fR( - \fBClientData\fR \fIclientData\fR); + \fBvoid *\fR \fIclientData\fR); .CE .PP The \fIclientData\fR parameter will be the same as the @@ -162,12 +176,12 @@ match the type \fBTcl_CmdTraceProc\fR: .PP .CS typedef void \fBTcl_CmdTraceProc\fR( - ClientData \fIclientData\fR, + void *\fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIlevel\fR, char *\fIcommand\fR, Tcl_CmdProc *\fIcmdProc\fR, - ClientData \fIcmdClientData\fR, + void *\fIcmdClientData\fR, int \fIargc\fR, const char *\fIargv\fR[]); .CE diff --git a/generic/tcl.decls b/generic/tcl.decls index 994af13..6d9fbbd 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -374,7 +374,7 @@ declare 98 { Tcl_TimerProc *proc, void *clientData) } declare 99 { - Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, + Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, Tcl_Size level, Tcl_CmdTraceProc *proc, void *clientData) } declare 100 { @@ -1722,7 +1722,7 @@ declare 482 { # TIP#32 (object-enabled traces) kbk declare 483 { - Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, int flags, + Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc) } @@ -2517,7 +2517,7 @@ declare 676 { Tcl_CmdDeleteProc *deleteProc) } declare 677 { - Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, int level, int flags, + Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc) } diff --git a/generic/tcl.h b/generic/tcl.h index 3560481..e705cdb 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -674,7 +674,7 @@ typedef int (Tcl_CmdObjTraceProc) (void *clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandInfo, int objc, struct Tcl_Obj *const *objv); typedef int (Tcl_CmdObjTraceProc2) (void *clientData, Tcl_Interp *interp, - int level, const char *command, Tcl_Command commandInfo, size_t objc, + size_t level, const char *command, Tcl_Command commandInfo, size_t objc, struct Tcl_Obj *const *objv); typedef void (Tcl_CmdObjTraceDeleteProc) (void *clientData); typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr, diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 8cb77b8..0888ecf 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -360,7 +360,7 @@ EXTERN Tcl_Interp * Tcl_CreateChild(Tcl_Interp *interp, const char *name, EXTERN Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds, Tcl_TimerProc *proc, void *clientData); /* 99 */ -EXTERN Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level, +EXTERN Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, Tcl_Size level, Tcl_CmdTraceProc *proc, void *clientData); /* 100 */ EXTERN void Tcl_DeleteAssocData(Tcl_Interp *interp, @@ -1451,8 +1451,9 @@ EXTERN int Tcl_EvalTokensStandard(Tcl_Interp *interp, /* 482 */ EXTERN void Tcl_GetTime(Tcl_Time *timeBuf); /* 483 */ -EXTERN Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, - int flags, Tcl_CmdObjTraceProc *objProc, +EXTERN Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, + Tcl_Size level, int flags, + Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 484 */ @@ -2012,8 +2013,9 @@ EXTERN Tcl_Command Tcl_CreateObjCommand2(Tcl_Interp *interp, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 677 */ -EXTERN Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, int level, - int flags, Tcl_CmdObjTraceProc2 *objProc2, +EXTERN Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, + Tcl_Size level, int flags, + Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 678 */ @@ -2164,7 +2166,7 @@ typedef struct TclStubs { Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */ Tcl_Interp * (*tcl_CreateChild) (Tcl_Interp *interp, const char *name, int isSafe); /* 97 */ Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, void *clientData); /* 98 */ - Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, int level, Tcl_CmdTraceProc *proc, void *clientData); /* 99 */ + Tcl_Trace (*tcl_CreateTrace) (Tcl_Interp *interp, Tcl_Size level, Tcl_CmdTraceProc *proc, void *clientData); /* 99 */ void (*tcl_DeleteAssocData) (Tcl_Interp *interp, const char *name); /* 100 */ void (*tcl_DeleteChannelHandler) (Tcl_Channel chan, Tcl_ChannelProc *proc, void *clientData); /* 101 */ void (*tcl_DeleteCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, void *clientData); /* 102 */ @@ -2556,7 +2558,7 @@ typedef struct TclStubs { void (*tcl_FSMountsChanged) (const Tcl_Filesystem *fsPtr); /* 480 */ int (*tcl_EvalTokensStandard) (Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Size count); /* 481 */ void (*tcl_GetTime) (Tcl_Time *timeBuf); /* 482 */ - Tcl_Trace (*tcl_CreateObjTrace) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 483 */ + Tcl_Trace (*tcl_CreateObjTrace) (Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc *objProc, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 483 */ int (*tcl_GetCommandInfoFromToken) (Tcl_Command token, Tcl_CmdInfo *infoPtr); /* 484 */ int (*tcl_SetCommandInfoFromToken) (Tcl_Command token, const Tcl_CmdInfo *infoPtr); /* 485 */ Tcl_Obj * (*tcl_DbNewWideIntObj) (Tcl_WideInt wideValue, const char *file, int line); /* 486 */ @@ -2750,7 +2752,7 @@ typedef struct TclStubs { int (*tcl_GetBool) (Tcl_Interp *interp, const char *src, int flags, char *charPtr); /* 674 */ int (*tcl_GetBoolFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, char *charPtr); /* 675 */ Tcl_Command (*tcl_CreateObjCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 676 */ - Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */ + Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */ Tcl_Command (*tcl_NRCreateCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc, Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 678 */ int (*tcl_NRCallObjProc2) (Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, void *clientData, size_t objc, Tcl_Obj *const objv[]); /* 679 */ int (*tcl_GetNumberFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void **clientDataPtr, int *typePtr); /* 680 */ diff --git a/generic/tclInt.h b/generic/tclInt.h index bdd7e5a..ec82abd 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1019,7 +1019,7 @@ typedef void (ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj); */ typedef struct Trace { - int level; /* Only trace commands at nesting level less + Tcl_Size level; /* Only trace commands at nesting level less * than or equal to this. */ Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */ void *clientData; /* Arbitrary value to pass to proc. */ diff --git a/generic/tclTrace.c b/generic/tclTrace.c index bed5084..e2be167 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -21,7 +21,7 @@ typedef struct { int flags; /* Operations for which Tcl command is to be * invoked. */ - size_t length; /* Number of non-NUL chars. in command. */ + Tcl_Size length; /* Number of non-NUL chars. in command. */ char command[TCLFLEXARRAY]; /* Space for Tcl command to invoke. Actual * size will be as large as necessary to hold * command. This field must be the last in the @@ -41,10 +41,10 @@ typedef struct { typedef struct { int flags; /* Operations for which Tcl command is to be * invoked. */ - size_t length; /* Number of non-NUL chars. in command. */ + Tcl_Size length; /* Number of non-NUL chars. in command. */ Tcl_Trace stepTrace; /* Used for execution traces, when tracing * inside the given command */ - int startLevel; /* Used for bookkeeping with step execution + Tcl_Size startLevel; /* Used for bookkeeping with step execution * traces, store the level at which the step * trace was invoked */ char *startCmd; /* Used for bookkeeping with step execution @@ -92,8 +92,15 @@ typedef struct { * Forward declarations for functions defined in this file: */ -typedef int (Tcl_TraceTypeObjCmd)(Tcl_Interp *interp, int optionIndex, - int objc, Tcl_Obj *const objv[]); +/* 'OLD' options are pre-Tcl-8.4 style */ +enum traceOptionsEnum { + TRACE_ADD, TRACE_INFO, TRACE_REMOVE +#ifndef TCL_REMOVE_OBSOLETE_TRACES + ,TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO +#endif +}; +typedef int (Tcl_TraceTypeObjCmd)(Tcl_Interp *interp, enum traceOptionsEnum optionIndex, + Tcl_Size objc, Tcl_Obj *const objv[]); static Tcl_TraceTypeObjCmd TraceVariableObjCmd; static Tcl_TraceTypeObjCmd TraceCommandObjCmd; @@ -120,19 +127,19 @@ static Tcl_TraceTypeObjCmd *const traceSubCmds[] = { */ static int CallTraceFunction(Tcl_Interp *interp, Trace *tracePtr, - Command *cmdPtr, const char *command, int numChars, - int objc, Tcl_Obj *const objv[]); -static char * TraceVarProc(ClientData clientData, Tcl_Interp *interp, + Command *cmdPtr, const char *command, Tcl_Size numChars, + Tcl_Size objc, Tcl_Obj *const objv[]); +static char * TraceVarProc(void *clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); -static void TraceCommandProc(ClientData clientData, +static void TraceCommandProc(void *clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); static Tcl_CmdObjTraceProc TraceExecutionProc; -static int StringTraceProc(ClientData clientData, - Tcl_Interp *interp, int level, +static int StringTraceProc(void *clientData, + Tcl_Interp *interp, Tcl_Size level, const char *command, Tcl_Command commandInfo, - int objc, Tcl_Obj *const objv[]); -static void StringTraceDeleteProc(ClientData clientData); + Tcl_Size objc, Tcl_Obj *const objv[]); +static void StringTraceDeleteProc(void *clientData); static void DisposeTraceResult(int flags, char *result); static int TraceVarEx(Tcl_Interp *interp, const char *part1, const char *part2, VarTrace *tracePtr); @@ -143,7 +150,7 @@ static int TraceVarEx(Tcl_Interp *interp, const char *part1, */ typedef struct { - ClientData clientData; /* Client data from Tcl_CreateTrace */ + void *clientData; /* Client data from Tcl_CreateTrace */ Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */ } StringTraceData; @@ -185,10 +192,9 @@ int Tcl_TraceObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int optionIndex; #ifndef TCL_REMOVE_OBSOLETE_TRACES const char *name; const char *flagOps, *p; @@ -201,13 +207,7 @@ Tcl_TraceObjCmd( #endif NULL }; - /* 'OLD' options are pre-Tcl-8.4 style */ - enum traceOptionsEnum { - TRACE_ADD, TRACE_INFO, TRACE_REMOVE, -#ifndef TCL_REMOVE_OBSOLETE_TRACES - TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO -#endif - }; + int optionIndex; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); @@ -237,7 +237,7 @@ Tcl_TraceObjCmd( 0, &typeIndex) != TCL_OK) { return TCL_ERROR; } - return traceSubCmds[typeIndex](interp, optionIndex, objc, objv); + return traceSubCmds[typeIndex](interp, (enum traceOptionsEnum)optionIndex, objc, objv); } case TRACE_INFO: { /* @@ -260,7 +260,7 @@ Tcl_TraceObjCmd( 0, &typeIndex) != TCL_OK) { return TCL_ERROR; } - return traceSubCmds[typeIndex](interp, optionIndex, objc, objv); + return traceSubCmds[typeIndex](interp, (enum traceOptionsEnum)optionIndex, objc, objv); break; } @@ -312,7 +312,7 @@ Tcl_TraceObjCmd( return code; } case TRACE_OLD_VINFO: { - ClientData clientData; + void *clientData; char ops[5]; Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr; @@ -397,16 +397,12 @@ Tcl_TraceObjCmd( static int TraceExecutionObjCmd( Tcl_Interp *interp, /* Current interpreter. */ - int optionIndex, /* Add, info or remove */ - int objc, /* Number of arguments. */ + enum traceOptionsEnum optionIndex, /* Add, info or remove */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int commandLength, index; const char *name, *command; - size_t length; - enum traceOptions { - TRACE_ADD, TRACE_INFO, TRACE_REMOVE - }; + Tcl_Size length; static const char *const opStrings[] = { "enter", "leave", "enterstep", "leavestep", NULL }; @@ -414,12 +410,13 @@ TraceExecutionObjCmd( TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE, TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP }; + int index; - switch ((enum traceOptions) optionIndex) { + switch (optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { - int flags = 0; - int i, listLen, result; + int flags = 0, result; + Tcl_Size i, listLen; Tcl_Obj **elemPtrs; if (objc != 6) { @@ -464,9 +461,8 @@ TraceExecutionObjCmd( break; } } - command = TclGetStringFromObj(objv[5], &commandLength); - length = (size_t) commandLength; - if ((enum traceOptions) optionIndex == TRACE_ADD) { + command = TclGetStringFromObj(objv[5], &length); + if ((enum traceOptionsEnum) optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)ckalloc( offsetof(TraceCommandInfo, command) + 1 + length); @@ -495,7 +491,7 @@ TraceExecutionObjCmd( * first one that matches. */ - ClientData clientData; + void *clientData; /* * First ensure the name given is valid. @@ -519,7 +515,7 @@ TraceExecutionObjCmd( && ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | TCL_TRACE_RENAME | TCL_TRACE_DELETE)) == flags) && (strncmp(command, tcmdPtr->command, - (size_t) length) == 0)) { + length) == 0)) { flags |= TCL_TRACE_DELETE; if (flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC)) { @@ -554,7 +550,7 @@ TraceExecutionObjCmd( break; } case TRACE_INFO: { - ClientData clientData; + void *clientData; Tcl_Obj *resultListPtr; if (objc != 4) { @@ -574,7 +570,7 @@ TraceExecutionObjCmd( resultListPtr = Tcl_NewListObj(0, NULL); FOREACH_COMMAND_TRACE(interp, name, clientData) { - int numOps = 0; + Tcl_Size numOps = 0; Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr; TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; @@ -619,6 +615,10 @@ TraceExecutionObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } +#ifndef TCL_REMOVE_OBSOLETE_TRACES + default: + break; +#endif } return TCL_OK; } @@ -645,22 +645,21 @@ TraceExecutionObjCmd( static int TraceCommandObjCmd( Tcl_Interp *interp, /* Current interpreter. */ - int optionIndex, /* Add, info or remove */ - int objc, /* Number of arguments. */ + enum traceOptionsEnum optionIndex, /* Add, info or remove */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int commandLength, index; const char *name, *command; - size_t length; - enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; + Tcl_Size length; static const char *const opStrings[] = { "delete", "rename", NULL }; enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME }; + int index; - switch ((enum traceOptions) optionIndex) { + switch (optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { - int flags = 0; - int i, listLen, result; + int flags = 0, result; + Tcl_Size i, listLen; Tcl_Obj **elemPtrs; if (objc != 6) { @@ -701,9 +700,8 @@ TraceCommandObjCmd( } } - command = TclGetStringFromObj(objv[5], &commandLength); - length = (size_t) commandLength; - if ((enum traceOptions) optionIndex == TRACE_ADD) { + command = TclGetStringFromObj(objv[5], &length); + if ((enum traceOptionsEnum) optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)ckalloc( offsetof(TraceCommandInfo, command) + 1 + length); @@ -728,7 +726,7 @@ TraceCommandObjCmd( * first one that matches. */ - ClientData clientData; + void *clientData; /* * First ensure the name given is valid. @@ -744,7 +742,7 @@ TraceCommandObjCmd( if ((tcmdPtr->length == length) && (tcmdPtr->flags == flags) && (strncmp(command, tcmdPtr->command, - (size_t) length) == 0)) { + length) == 0)) { Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE, TraceCommandProc, clientData); tcmdPtr->flags |= TCL_TRACE_DESTROYED; @@ -758,7 +756,7 @@ TraceCommandObjCmd( break; } case TRACE_INFO: { - ClientData clientData; + void *clientData; Tcl_Obj *resultListPtr; if (objc != 4) { @@ -777,7 +775,7 @@ TraceCommandObjCmd( resultListPtr = Tcl_NewListObj(0, NULL); FOREACH_COMMAND_TRACE(interp, name, clientData) { - int numOps = 0; + Tcl_Size numOps = 0; Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr; TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; @@ -813,6 +811,10 @@ TraceCommandObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } +#ifndef TCL_REMOVE_OBSOLETE_TRACES + default: + break; +#endif } return TCL_OK; } @@ -839,27 +841,26 @@ TraceCommandObjCmd( static int TraceVariableObjCmd( Tcl_Interp *interp, /* Current interpreter. */ - int optionIndex, /* Add, info or remove */ - int objc, /* Number of arguments. */ + enum traceOptionsEnum optionIndex, /* Add, info or remove */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int commandLength, index; const char *name, *command; - size_t length; - ClientData clientData; - enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE }; + Tcl_Size length; + void *clientData; static const char *const opStrings[] = { "array", "read", "unset", "write", NULL }; enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, TRACE_VAR_WRITE }; + int index; - switch ((enum traceOptions) optionIndex) { + switch ((enum traceOptionsEnum) optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { - int flags = 0; - int i, listLen, result; + int flags = 0, result; + Tcl_Size i, listLen; Tcl_Obj **elemPtrs; if (objc != 6) { @@ -904,9 +905,8 @@ TraceVariableObjCmd( break; } } - command = TclGetStringFromObj(objv[5], &commandLength); - length = (size_t) commandLength; - if ((enum traceOptions) optionIndex == TRACE_ADD) { + command = TclGetStringFromObj(objv[5], &length); + if ((enum traceOptionsEnum) optionIndex == TRACE_ADD) { CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)ckalloc( offsetof(CombinedTraceVarInfo, traceCmdInfo.command) + 1 + length); @@ -947,7 +947,7 @@ TraceVariableObjCmd( #endif )==flags) && (strncmp(command, tvarPtr->command, - (size_t) length) == 0)) { + length) == 0)) { Tcl_UntraceVar2(interp, name, NULL, flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, TraceVarProc, clientData); @@ -1005,6 +1005,10 @@ TraceVariableObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } +#ifndef TCL_REMOVE_OBSOLETE_TRACES + default: + break; +#endif } return TCL_OK; } @@ -1034,13 +1038,13 @@ TraceVariableObjCmd( *---------------------------------------------------------------------- */ -ClientData +void * Tcl_CommandTraceInfo( Tcl_Interp *interp, /* Interpreter containing command. */ const char *cmdName, /* Name of command. */ TCL_UNUSED(int) /*flags*/, Tcl_CommandTraceProc *proc, /* Function assocated with trace. */ - ClientData prevClientData) /* If non-NULL, gives last value returned by + void *prevClientData) /* If non-NULL, gives last value returned by * this function, so this call will return the * next trace after that one. If NULL, this * call will return the first trace. */ @@ -1108,7 +1112,7 @@ Tcl_TraceCommand( * of the TRACE_*_EXEC flags */ Tcl_CommandTraceProc *proc, /* Function to call when specified ops are * invoked upon cmdName. */ - ClientData clientData) /* Arbitrary argument to pass to proc. */ + void *clientData) /* Arbitrary argument to pass to proc. */ { Command *cmdPtr; CommandTrace *tracePtr; @@ -1172,7 +1176,7 @@ Tcl_UntraceCommand( * TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any * of the TRACE_*_EXEC flags */ Tcl_CommandTraceProc *proc, /* Function assocated with trace. */ - ClientData clientData) /* Arbitrary argument to pass to proc. */ + void *clientData) /* Arbitrary argument to pass to proc. */ { CommandTrace *tracePtr; CommandTrace *prevPtr; @@ -1277,7 +1281,7 @@ Tcl_UntraceCommand( static void TraceCommandProc( - ClientData clientData, /* Information about the command trace. */ + void *clientData, /* Information about the command trace. */ Tcl_Interp *interp, /* Interpreter containing command. */ const char *oldName, /* Name of command being changed. */ const char *newName, /* New name of command. Empty string or NULL @@ -1300,7 +1304,7 @@ TraceCommandProc( */ Tcl_DStringInit(&cmd); - Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length); + Tcl_DStringAppend(&cmd, tcmdPtr->command, tcmdPtr->length); Tcl_DStringAppendElement(&cmd, oldName); Tcl_DStringAppendElement(&cmd, (newName ? newName : "")); if (flags & TCL_TRACE_RENAME) { @@ -1418,17 +1422,17 @@ TclCheckExecutionTraces( Tcl_Interp *interp, /* The current interpreter. */ const char *command, /* Pointer to beginning of the current command * string. */ - TCL_UNUSED(int) /*numChars*/, + TCL_UNUSED(Tcl_Size) /*numChars*/, Command *cmdPtr, /* Points to command's Command struct. */ int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ - int objc, /* Number of arguments for the command. */ + Tcl_Size objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; CommandTrace *tracePtr, *lastTracePtr; ActiveCommandTrace active; - int curLevel; + Tcl_Size curLevel; int traceCode = TCL_OK; Tcl_InterpState state = NULL; @@ -1523,18 +1527,18 @@ TclCheckInterpTraces( Tcl_Interp *interp, /* The current interpreter. */ const char *command, /* Pointer to beginning of the current command * string. */ - int numChars, /* The number of characters in 'command' which + Tcl_Size numChars, /* The number of characters in 'command' which * are part of the command string. */ Command *cmdPtr, /* Points to command's Command struct. */ int code, /* The current result code. */ int traceFlags, /* Current tracing situation. */ - int objc, /* Number of arguments for the command. */ + Tcl_Size objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; Trace *tracePtr, *lastTracePtr; ActiveInterpTrace active; - int curLevel; + Tcl_Size curLevel; int traceCode = TCL_OK; Tcl_InterpState state = NULL; @@ -1670,9 +1674,9 @@ CallTraceFunction( Command *cmdPtr, /* Points to command's Command struct. */ const char *command, /* Points to the first character of the * command's source before substitutions. */ - int numChars, /* The number of characters in the command's + Tcl_Size numChars, /* The number of characters in the command's * source. */ - int objc, /* Number of arguments for the command. */ + Tcl_Size objc, /* Number of arguments for the command. */ Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */ { Interp *iPtr = (Interp *) interp; @@ -1717,7 +1721,7 @@ CallTraceFunction( static void CommandObjTraceDeleted( - ClientData clientData) + void *clientData) { TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; @@ -1753,12 +1757,12 @@ CommandObjTraceDeleted( static int TraceExecutionProc( - ClientData clientData, + void *clientData, Tcl_Interp *interp, - int level, + Tcl_Size level, const char *command, TCL_UNUSED(Tcl_Command), - int objc, + Tcl_Size objc, Tcl_Obj *const objv[]) { int call = 0; @@ -1813,10 +1817,11 @@ TraceExecutionProc( if (call) { Tcl_DString cmd, sub; - int i, saveInterpFlags; + Tcl_Size i; + int saveInterpFlags; Tcl_DStringInit(&cmd); - Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length); + Tcl_DStringAppend(&cmd, tcmdPtr->command, tcmdPtr->length); /* * Append command with arguments. @@ -1960,7 +1965,7 @@ TraceExecutionProc( static char * TraceVarProc( - ClientData clientData, /* Information about the variable trace. */ + void *clientData, /* Information about the variable trace. */ Tcl_Interp *interp, /* Interpreter containing variable. */ const char *name1, /* Name of variable or array. */ const char *name2, /* Name of element within array; NULL means @@ -1984,14 +1989,14 @@ TraceVarProc( result = NULL; if ((tvarPtr->flags & flags) && !Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) { - if (tvarPtr->length != (size_t) 0) { + if (tvarPtr->length) { /* * Generate a command to execute by appending list elements for * the two variable names and the operation. */ Tcl_DStringInit(&cmd); - Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); + Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length); Tcl_DStringAppendElement(&cmd, name1); Tcl_DStringAppendElement(&cmd, (name2 ? name2 : "")); #ifndef TCL_REMOVE_OBSOLETE_TRACES @@ -2069,7 +2074,7 @@ TraceVarProc( /* *---------------------------------------------------------------------- * - * Tcl_CreateObjTrace -- + * Tcl_CreateObjTrace/Tcl_CreateObjTrace2 -- * * Arrange for a function to be called to trace command execution. * @@ -2082,7 +2087,7 @@ TraceVarProc( * called to execute a Tcl command. Calls to proc will have the following * form: * - * void proc(ClientData clientData, + * void proc(void * clientData, * Tcl_Interp * interp, * int level, * const char * command, @@ -2130,13 +2135,16 @@ typedef struct { static int traceWrapperProc( void *clientData, Tcl_Interp *interp, - int level, + Tcl_Size level, const char *command, Tcl_Command commandInfo, - int objc, + Tcl_Size objc, Tcl_Obj *const objv[]) { TraceWrapperInfo *info = (TraceWrapperInfo *)clientData; + if (objc < 0) { + objc = -1; /* Signal Tcl_CmdObjTraceProc that objc is out of range */ + } return info->proc(info->clientData, interp, level, command, commandInfo, objc, objv); } @@ -2153,7 +2161,7 @@ static void traceWrapperDelProc(void *clientData) Tcl_Trace Tcl_CreateObjTrace2( Tcl_Interp *interp, /* Tcl interpreter */ - int level, /* Maximum nesting level */ + Tcl_Size level, /* Maximum nesting level */ int flags, /* Flags, see above */ Tcl_CmdObjTraceProc2 *proc, /* Trace callback */ void *clientData, /* Client data for the callback */ @@ -2172,10 +2180,10 @@ Tcl_CreateObjTrace2( Tcl_Trace Tcl_CreateObjTrace( Tcl_Interp *interp, /* Tcl interpreter */ - int level, /* Maximum nesting level */ + Tcl_Size level, /* Maximum nesting level */ int flags, /* Flags, see above */ Tcl_CmdObjTraceProc *proc, /* Trace callback */ - ClientData clientData, /* Client data for the callback */ + void *clientData, /* Client data for the callback */ Tcl_CmdObjTraceDeleteProc *delProc) /* Function to call when trace is deleted */ { @@ -2235,12 +2243,12 @@ Tcl_CreateObjTrace( * void * proc(clientData, interp, level, command, cmdProc, cmdClientData, * argc, argv) - * ClientData clientData; + * void *clientData; * Tcl_Interp *interp; * int level; * char *command; * int (*cmdProc)(); - * ClientData cmdClientData; + * void *cmdClientData; * int argc; * char **argv; * { @@ -2261,11 +2269,11 @@ Tcl_CreateObjTrace( Tcl_Trace Tcl_CreateTrace( Tcl_Interp *interp, /* Interpreter in which to create trace. */ - int level, /* Only call proc for commands at nesting + Tcl_Size level, /* Only call proc for commands at nesting * level<=argument level (1=>top level). */ Tcl_CmdTraceProc *proc, /* Function to call before executing each * command. */ - ClientData clientData) /* Arbitrary value word to pass to proc. */ + void *clientData) /* Arbitrary value word to pass to proc. */ { StringTraceData *data = (StringTraceData *)ckalloc(sizeof(StringTraceData)); @@ -2293,18 +2301,18 @@ Tcl_CreateTrace( static int StringTraceProc( - ClientData clientData, + void *clientData, Tcl_Interp *interp, - int level, + Tcl_Size level, const char *command, Tcl_Command commandInfo, - int objc, + Tcl_Size objc, Tcl_Obj *const *objv) { StringTraceData *data = (StringTraceData *)clientData; Command *cmdPtr = (Command *) commandInfo; const char **argv; /* Args to pass to string trace proc */ - int i; + Tcl_Size i; /* * This is a bit messy because we have to emulate the old trace interface, @@ -2349,7 +2357,7 @@ StringTraceProc( static void StringTraceDeleteProc( - ClientData clientData) + void *clientData) { ckfree(clientData); } @@ -3239,7 +3247,7 @@ Tcl_TraceVar2( * TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc, /* Function to call when specified ops are * invoked upon varName. */ - ClientData clientData) /* Arbitrary argument to pass to proc. */ + void *clientData) /* Arbitrary argument to pass to proc. */ { VarTrace *tracePtr; int result; -- cgit v0.12 From 822d3017ef86babab61e2c2b44d6866e8d7f4349 Mon Sep 17 00:00:00 2001 From: kjnash Date: Wed, 9 Nov 2022 10:53:23 +0000 Subject: Bugfix to socketPhQueue. Add some Log commands for debugging. --- library/http/http.tcl | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index 4c9f6a7..a1d4a2b 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -1665,9 +1665,12 @@ proc http::PreparePersistentConnection {token} { set socketWrState($state(socketinfo)) $token } + # Value of socketPhQueue() may have already been set by ReplayCore. + if {![info exists socketPhQueue($state(sock))]} { + set socketPhQueue($state(sock)) {} + } set socketRdQueue($state(socketinfo)) {} set socketWrQueue($state(socketinfo)) {} - set socketPhQueue($state(sock)) {} set socketClosing($state(socketinfo)) 0 set socketPlayCmd($state(socketinfo)) {ReplayIfClose Wready {} {}} set socketCoEvent($state(socketinfo)) {} @@ -1839,7 +1842,7 @@ proc http::ConfigureNewSocket {token sockOld DoLater} { set reusing $state(reusing) set sock $state(sock) set proxyUsed $state(proxyUsed) - ##Log " ConfigureNewSocket" $token $sockOld ... -- $sock + ##Log " ConfigureNewSocket" $token $sockOld ... -- $reusing $sock $proxyUsed if {(!$reusing) && ($sock ne $sockOld)} { # Replace the placeholder value sockOld with sock. @@ -3071,6 +3074,7 @@ proc http::ReplayCore {newQueue} { if {![ReInit $token]} { Log FAILED in http::ReplayCore - NO tmp vars + Log ReplayCore reject $token Finish $token {cannot send this request again} return } @@ -3085,6 +3089,7 @@ proc http::ReplayCore {newQueue} { set state(reusing) 0 set state(ReusingPlaceholder) 0 set state(alreadyQueued) 0 + Log ReplayCore replay $token # Give the socket a placeholder name before it is created. set sock HTTP_PLACEHOLDER_[incr TmpSockCounter] @@ -3097,7 +3102,9 @@ proc http::ReplayCore {newQueue} { set ${tok}(reusing) 1 set ${tok}(sock) $sock lappend socketPhQueue($sock) $tok + Log ReplayCore replay $tok } else { + Log ReplayCore reject $tok set ${tok}(reusing) 1 set ${tok}(sock) NONE Finish $tok {cannot send this request again} -- cgit v0.12 From 7c5899368038b1f25f6d2230553986e212e49708 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 9 Nov 2022 13:15:55 +0000 Subject: update target release date --- changes | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changes b/changes index 1aa760a..4483334 100644 --- a/changes +++ b/changes @@ -9166,4 +9166,4 @@ Update bundled libtommath Many code fixes to avoid overflow or undefined behavior. Thanks chrstphrchvz. -- Released 8.6.13, Oct 28, 2022 - details at https://core.tcl-lang.org/tcl/ - +- Released 8.6.13, Nov 15, 2022 - details at https://core.tcl-lang.org/tcl/ - -- cgit v0.12 From 50f633ff289fe9ff3f3c37defa42209ecd4e24ea Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 9 Nov 2022 17:15:52 +0000 Subject: No trailing ',' --- generic/tclDisassemble.c | 2 +- generic/tclEncoding.c | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 66acade..57adcf0 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -42,7 +42,7 @@ static const Tcl_ObjType instNameType = { NULL, /* dupIntRepProc */ UpdateStringOfInstName, /* updateStringProc */ NULL, /* setFromAnyProc */ - TCL_OBJTYPE_V0, + TCL_OBJTYPE_V0 }; #define InstNameSetInternalRep(objPtr, inst) \ diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 455d7a6..76a936c 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -241,7 +241,7 @@ static const Tcl_ObjType encodingType = { DupEncodingInternalRep, NULL, NULL, - TCL_OBJTYPE_V0, + TCL_OBJTYPE_V0 }; #define EncodingSetInternalRep(objPtr, encoding) \ -- cgit v0.12 From 6065eb2868a1672cbc4285c8117db7cb451f239e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 10 Nov 2022 11:20:02 +0000 Subject: Forgot one TCL_OBJTYPE_V0 --- macosx/tclMacOSXFCmd.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index 020288f..71b98b5 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -88,7 +88,8 @@ static const Tcl_ObjType tclOSTypeType = { NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfOSType, /* updateStringProc */ - SetOSTypeFromAny /* setFromAnyProc */ + SetOSTypeFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 }; enum { -- cgit v0.12 From 874327229c5e64a52e1fc3b4da6a31936ec07ed2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 11 Nov 2022 21:09:21 +0000 Subject: Add (internal) TclNewUIntObj(), and use it to fix TCL_LINK_WIDE_UINT for big (>= 2^63) integers. With testcase --- generic/tclInt.h | 35 +++++++++++++++++++++++++++++++++++ generic/tclLink.c | 11 +++++++---- generic/tclOOBasic.c | 2 +- tests/link.test | 4 ++-- 4 files changed, 45 insertions(+), 7 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index ec82abd..036c653 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4852,6 +4852,26 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) +#define TclNewUIntObj(objPtr, uw) \ + do { \ + TclIncrObjsAllocated(); \ + TclAllocObjStorage(objPtr); \ + (objPtr)->refCount = 0; \ + (objPtr)->bytes = NULL; \ + Tcl_WideUInt uw_ = (uw); \ + if (uw_ > WIDE_MAX) { \ + mp_int bignumValue_; \ + if (mp_init_u64(&bignumValue_, uw_) != MP_OKAY) { \ + Tcl_Panic("%s: memory overflow", "TclNewUIntObj"); \ + } \ + TclSetBignumInternalRep((objPtr), &bignumValue_); \ + } else { \ + (objPtr)->internalRep.wideValue = (Tcl_WideInt)(uw_); \ + (objPtr)->typePtr = &tclIntType; \ + } \ + TCL_DTRACE_OBJ_CREATE(objPtr); \ + } while (0) + #define TclNewIndexObj(objPtr, w) \ TclNewIntObj(objPtr, w) @@ -4880,6 +4900,21 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; #define TclNewIntObj(objPtr, w) \ (objPtr) = Tcl_NewWideIntObj(w) +#define TclNewUIntObj(objPtr, uw) \ + do { \ + Tcl_WideUInt uw_ = (uw); \ + if (uw_ > WIDE_MAX) { \ + mp_int bignumValue_; \ + if (mp_init_u64(&bignumValue_, uw_) == MP_OKAY) { \ + (objPtr) = Tcl_NewBignumObj(&bignumValue_)); \ + } else { \ + (objPtr) = NULL; \ + } \ + } else { \ + (objPtr) = Tcl_NewWideIntObj(uw_); \ + } \ + } while (0) + #define TclNewIndexObj(objPtr, w) \ TclNewIntObj(objPtr, w) diff --git a/generic/tclLink.c b/generic/tclLink.c index 0d57d44..af48302 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -553,7 +553,7 @@ GetUWide( */ return 1; } -#ifdef WORDS_BIGENDIAN +#ifndef WORDS_BIGENDIAN while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } @@ -1451,12 +1451,12 @@ ObjValue( } linkPtr->lastValue.f = LinkedVar(float); return Tcl_NewDoubleObj(linkPtr->lastValue.f); - case TCL_LINK_WIDE_UINT: + case TCL_LINK_WIDE_UINT: { if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - TclNewIntObj(objv[i], (Tcl_WideInt) + TclNewUIntObj(objv[i], linkPtr->lastValue.uwPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); @@ -1464,7 +1464,10 @@ ObjValue( return resultObj; } linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt); - return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw); + Tcl_Obj *uwObj; + TclNewUIntObj(uwObj, linkPtr->lastValue.uw); + return uwObj; + } case TCL_LINK_STRING: p = LinkedVar(char *); diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 6ea4681..3593193 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -1249,7 +1249,7 @@ TclOOSelfObjCmd( } case SELF_CALL: result[0] = TclOORenderCallChain(interp, contextPtr->callPtr); - TclNewIntObj(result[1], contextPtr->index); + TclNewIndexObj(result[1], contextPtr->index); Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); return TCL_OK; } diff --git a/tests/link.test b/tests/link.test index eba359c..69ebb02 100644 --- a/tests/link.test +++ b/tests/link.test @@ -69,9 +69,9 @@ test link-2.1 {writing C variables from Tcl} -constraints {testlink} -setup { set long 34543 set ulong 567890 set float 1.0987654321 - set uwide 357357357357 + set uwide 12345678901234567890 concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide -} -result {465 -10.5 1 abcdef 135135 79 161 8000 40000 -1073628482 34543 567890 1.0987653732299805 357357357357 | 0o0721 -10.5 true abcdef 135135 79 161 8000 40000 0xc001babe 34543 567890 1.0987654321 357357357357} +} -result {465 -10.5 1 abcdef 135135 79 161 8000 40000 -1073628482 34543 567890 1.0987653732299805 -6101065172474983726 | 0o0721 -10.5 true abcdef 135135 79 161 8000 40000 0xc001babe 34543 567890 1.0987654321 12345678901234567890} test link-2.2 {writing bad values into variables} -setup { testlink delete } -constraints {testlink} -body { -- cgit v0.12 From 67e92c7ada3b079caeb029907f19ecce31906ff6 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 13 Nov 2022 06:06:43 +0000 Subject: Fix compilation error for STATS=memdbg --- generic/tclInt.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index b079364..adf02b7 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4880,7 +4880,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; if (uw_ > WIDE_MAX) { \ mp_int bignumValue_; \ if (mp_init_u64(&bignumValue_, uw_) == MP_OKAY) { \ - (objPtr) = Tcl_NewBignumObj(&bignumValue_)); \ + (objPtr) = Tcl_NewBignumObj(&bignumValue_); \ } else { \ (objPtr) = NULL; \ } \ -- cgit v0.12 From 7dc710b2f42b81cfac6a8e5b8a80f4acf35aee78 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 13 Nov 2022 06:37:55 +0000 Subject: Update Tcl_ObjType documentation --- doc/ObjectType.3 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/ObjectType.3 b/doc/ObjectType.3 index 9f8d04f..3e6d0c2 100644 --- a/doc/ObjectType.3 +++ b/doc/ObjectType.3 @@ -109,6 +109,7 @@ typedef struct Tcl_ObjType { Tcl_DupInternalRepProc *\fIdupIntRepProc\fR; Tcl_UpdateStringProc *\fIupdateStringProc\fR; Tcl_SetFromAnyProc *\fIsetFromAnyProc\fR; + size_t \fIversion\fR; } \fBTcl_ObjType\fR; .CE .SS "THE NAME FIELD" @@ -253,6 +254,10 @@ Note that if a subsidiary value has its reference count reduced to zero during the running of a \fIfreeIntRepProc\fR, that value may be not freed immediately, in order to limit stack usage. However, the value will be freed before the outermost current \fBTcl_DecrRefCount\fR returns. +.SS "THE VERSION FIELD" +.PP +The \fIversion\fR member provides for future extensibility of the structure +and should be set to \fITCL_OBJTYPE_V0\fR. .SH "REFERENCE COUNT MANAGEMENT" .PP The \fIobjPtr\fR argument to \fBTcl_AppendAllObjTypes\fR should be an unshared -- cgit v0.12 From 46a5d4b5fa40f76f18980d1995c96698335ad4b2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 13 Nov 2022 16:53:43 +0000 Subject: Fix compilation error for STATS=memdbg. Fix incorrect comment --- generic/tclInt.h | 2 +- generic/tclLink.c | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 036c653..2d29e1d 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4906,7 +4906,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; if (uw_ > WIDE_MAX) { \ mp_int bignumValue_; \ if (mp_init_u64(&bignumValue_, uw_) == MP_OKAY) { \ - (objPtr) = Tcl_NewBignumObj(&bignumValue_)); \ + (objPtr) = Tcl_NewBignumObj(&bignumValue_); \ } else { \ (objPtr) = NULL; \ } \ diff --git a/generic/tclLink.c b/generic/tclLink.c index af48302..1973067 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -557,9 +557,9 @@ GetUWide( while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } -#else /* !WORDS_BIGENDIAN */ +#else /* WORDS_BIGENDIAN */ /* - * Little-endian can read the value directly. + * Big-endian can read the value directly. */ value = scratch.value; #endif /* WORDS_BIGENDIAN */ -- cgit v0.12 From 14225bf18403da5689ee38fe70343b877b7bc571 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 13 Nov 2022 21:25:31 +0000 Subject: fix filename --- library/cookiejar/idna.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/cookiejar/idna.tcl b/library/cookiejar/idna.tcl index 658dcd6..dc25cd8 100644 --- a/library/cookiejar/idna.tcl +++ b/library/cookiejar/idna.tcl @@ -1,4 +1,4 @@ -# cookiejar.tcl -- +# idna.tcl -- # # Implementation of IDNA (Internationalized Domain Names for # Applications) encoding/decoding system, built on a punycode engine -- cgit v0.12 From 2a1443e0e07d217161b094cf6e550f63ef2cab54 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 14 Nov 2022 17:23:52 +0000 Subject: Test suite hygiene - Several tests missing the "testdstring" constraint - [package require tcltests] is fragile, and almost all test files that had it were not making use of anything it provides. Removed. --- tests/chanio.test | 1 - tests/env.test | 2 -- tests/exec.test | 2 -- tests/io.test | 1 - tests/ioCmd.test | 2 -- tests/platform.test | 1 - tests/thread.test | 3 ++- tests/util.test | 10 +++++----- 8 files changed, 7 insertions(+), 15 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index 5381a88..0f45819 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -34,7 +34,6 @@ namespace eval ::tcl::test::io { package require -exact Tcltest [info patchlevel] set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] } - package require tcltests testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] diff --git a/tests/env.test b/tests/env.test index ff111e9..6c46532 100644 --- a/tests/env.test +++ b/tests/env.test @@ -16,8 +16,6 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -package require tcltests - # [exec] is required here to see the actual environment received by child # processes. proc getenv {} { diff --git a/tests/exec.test b/tests/exec.test index 0f5db76..4cc4a05 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -19,8 +19,6 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -package require tcltests - # All tests require the "exec" command. # Skip them if exec is not defined. testConstraint exec [llength [info commands exec]] diff --git a/tests/io.test b/tests/io.test index 94d8764..cd4c954 100644 --- a/tests/io.test +++ b/tests/io.test @@ -34,7 +34,6 @@ namespace eval ::tcl::test::io { package require -exact Tcltest [info patchlevel] set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] } - package require tcltests testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 898d076..99bb464 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -21,8 +21,6 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -package require tcltests - # Custom constraints used in this file testConstraint testchannel [llength [info commands testchannel]] diff --git a/tests/platform.test b/tests/platform.test index 042469b..6b775cf 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -10,7 +10,6 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.5 -package require tcltests namespace eval ::tcl::test::platform { namespace import ::tcltest::testConstraint diff --git a/tests/thread.test b/tests/thread.test index 7c7dc27..28934a2 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -15,7 +15,8 @@ # when thread::release is used, -wait is passed in order allow the thread to # be fully finalized, which avoids valgrind "still reachable" reports. -package require tcltests +package require tcltest 2.5 +namespace import ::tcltest::* ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/util.test b/tests/util.test index d0b98a5..11ee3fa 100644 --- a/tests/util.test +++ b/tests/util.test @@ -528,7 +528,7 @@ test util-8.6 {TclNeedSpace - correct utf-8 handling} testdstring { testdstring append \} -1 list [llength [testdstring get]] [string length [testdstring get]] } {2 8} -test util-8.7 {TclNeedSpace - watch out for escaped space} { +test util-8.7 {TclNeedSpace - watch out for escaped space} testdstring { testdstring free testdstring append {\ } -1 testdstring start @@ -537,7 +537,7 @@ test util-8.7 {TclNeedSpace - watch out for escaped space} { # Should make {\ {}} list [llength [testdstring get]] [string index [testdstring get] 3] } {2 \{} -test util-8.8 {TclNeedSpace - watch out for escaped space} { +test util-8.8 {TclNeedSpace - watch out for escaped space} testdstring { testdstring free testdstring append {\\ } -1 testdstring start @@ -546,7 +546,7 @@ test util-8.8 {TclNeedSpace - watch out for escaped space} { # Should make {\\ {}} list [llength [testdstring get]] [string index [testdstring get] 3] } {2 \{} -test util-8.9 {TclNeedSpace - watch out for escaped space} { +test util-8.9 {TclNeedSpace - watch out for escaped space} testdstring { testdstring free testdstring append {\\\ } -1 testdstring start @@ -555,7 +555,7 @@ test util-8.9 {TclNeedSpace - watch out for escaped space} { # Should make {\\\ {}} list [llength [testdstring get]] [string index [testdstring get] 5] } {2 \{} -test util-8.10 {TclNeedSpace - watch out for escaped space} { +test util-8.10 {TclNeedSpace - watch out for escaped space} testdstring { testdstring free testdstring append {\\\\\\\ } -1 testdstring start @@ -564,7 +564,7 @@ test util-8.10 {TclNeedSpace - watch out for escaped space} { # Should make {\\\\\\\ {}} list [llength [testdstring get]] [string index [testdstring get] 9] } {2 \{} -test util-8.11 {TclNeedSpace - watch out for escaped space} { +test util-8.11 {TclNeedSpace - watch out for escaped space} testdstring { testdstring free testdstring append {\\\\\\\\ } -1 testdstring start -- cgit v0.12 From 79f559fdb5b42afb0b51a81227aea6038d338b15 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Nov 2022 10:57:59 +0000 Subject: Add mp_pack to the libtommath stub-table: it's easier to work with than mp_to_ubin --- generic/tclLink.c | 19 ++----------------- generic/tclStubInit.c | 6 ++++-- generic/tclTomMath.decls | 7 +++++++ generic/tclTomMathDecls.h | 22 ++++++++++++++++------ unix/Makefile.in | 12 +++++++++--- win/Makefile.in | 2 ++ win/makefile.vc | 2 ++ 7 files changed, 42 insertions(+), 28 deletions(-) diff --git a/generic/tclLink.c b/generic/tclLink.c index 1973067..397c9bc 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -537,15 +537,10 @@ GetUWide( } else if (type == TCL_NUMBER_BIG) { mp_int *numPtr = (mp_int *)clientData; Tcl_WideUInt value = 0; - union { - Tcl_WideUInt value; - unsigned char bytes[sizeof(Tcl_WideUInt)]; - } scratch; size_t numBytes; - unsigned char *bytes = scratch.bytes; - if (numPtr->sign || (MP_OKAY != mp_to_ubin(numPtr, - bytes, sizeof(Tcl_WideUInt), &numBytes))) { + if (numPtr->sign || (MP_OKAY != mp_pack(&value, 1, + &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, numPtr))) { /* * If the sign bit is set (a negative value) or if the value * can't possibly fit in the bits of an unsigned wide, there's @@ -553,16 +548,6 @@ GetUWide( */ return 1; } -#ifndef WORDS_BIGENDIAN - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } -#else /* WORDS_BIGENDIAN */ - /* - * Big-endian can read the value directly. - */ - value = scratch.value; -#endif /* WORDS_BIGENDIAN */ *uwidePtr = value; return 0; } diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 7af42d3..ad60fc3 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -232,6 +232,8 @@ int TclParseArgsObjv(Tcl_Interp *interp, #define TclBN_mp_mul_2d mp_mul_2d #define TclBN_mp_neg mp_neg #define TclBN_mp_or mp_or +#define TclBN_mp_pack mp_pack +#define TclBN_mp_pack_count mp_pack_count #define TclBN_mp_radix_size mp_radix_size #define TclBN_mp_reverse mp_reverse #define TclBN_mp_read_radix mp_read_radix @@ -1325,12 +1327,12 @@ const TclTomMathStubs tclTomMathStubs = { TclBN_mp_get_mag_u64, /* 69 */ TclBN_mp_set_i64, /* 70 */ TclBN_mp_unpack, /* 71 */ - 0, /* 72 */ + TclBN_mp_pack, /* 72 */ TclBN_mp_tc_and, /* 73 */ TclBN_mp_tc_or, /* 74 */ TclBN_mp_tc_xor, /* 75 */ TclBN_mp_signed_rsh, /* 76 */ - 0, /* 77 */ + TclBN_mp_pack_count, /* 77 */ TclBN_mp_to_ubin, /* 78 */ TclBN_mp_div_ld, /* 79 */ TclBN_mp_to_radix, /* 80 */ diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls index 3a3b9a8..27c4f98 100644 --- a/generic/tclTomMath.decls +++ b/generic/tclTomMath.decls @@ -247,6 +247,10 @@ declare 71 { mp_err MP_WUR TclBN_mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian, size_t nails, const void *op) } +declare 72 { + mp_err MP_WUR TclBN_mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order, + size_t size, mp_endian endian, size_t nails, const mp_int *op) +} # Added in libtommath 1.1.0 declare 73 {deprecated {merged with mp_and}} { @@ -261,6 +265,9 @@ declare 75 {deprecated {merged with mp_xor}} { declare 76 { mp_err MP_WUR TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c) } +declare 77 { + size_t MP_WUR TclBN_mp_pack_count(const mp_int *a, size_t nails, size_t size) +} # Added in libtommath 1.2.0 declare 78 { diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index 8d12adf..009f914 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -125,6 +125,8 @@ MODULE_SCOPE mp_err TclBN_mp_set_int(mp_int *a, unsigned long b); #define mp_mul_2d TclBN_mp_mul_2d #define mp_neg TclBN_mp_neg #define mp_or TclBN_mp_or +#define mp_pack TclBN_mp_pack +#define mp_pack_count TclBN_mp_pack_count #define mp_radix_size TclBN_mp_radix_size #define mp_read_radix TclBN_mp_read_radix #define mp_rshd TclBN_mp_rshd @@ -394,7 +396,11 @@ EXTERN mp_err TclBN_mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian, size_t nails, const void *op) MP_WUR; -/* Slot 72 is reserved */ +/* 72 */ +EXTERN mp_err TclBN_mp_pack(void *rop, size_t maxcount, + size_t *written, mp_order order, size_t size, + mp_endian endian, size_t nails, + const mp_int *op) MP_WUR; /* 73 */ TCL_DEPRECATED("merged with mp_and") mp_err TclBN_mp_tc_and(const mp_int *a, const mp_int *b, @@ -410,7 +416,9 @@ mp_err TclBN_mp_tc_xor(const mp_int *a, const mp_int *b, /* 76 */ EXTERN mp_err TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c) MP_WUR; -/* Slot 77 is reserved */ +/* 77 */ +EXTERN size_t TclBN_mp_pack_count(const mp_int *a, size_t nails, + size_t size) MP_WUR; /* 78 */ EXTERN int TclBN_mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR; @@ -497,12 +505,12 @@ typedef struct TclTomMathStubs { uint64_t (*tclBN_mp_get_mag_u64) (const mp_int *a) MP_WUR; /* 69 */ void (*tclBN_mp_set_i64) (mp_int *a, int64_t i); /* 70 */ mp_err (*tclBN_mp_unpack) (mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian, size_t nails, const void *op) MP_WUR; /* 71 */ - void (*reserved72)(void); + mp_err (*tclBN_mp_pack) (void *rop, size_t maxcount, size_t *written, mp_order order, size_t size, mp_endian endian, size_t nails, const mp_int *op) MP_WUR; /* 72 */ TCL_DEPRECATED_API("merged with mp_and") mp_err (*tclBN_mp_tc_and) (const mp_int *a, const mp_int *b, mp_int *c); /* 73 */ TCL_DEPRECATED_API("merged with mp_or") mp_err (*tclBN_mp_tc_or) (const mp_int *a, const mp_int *b, mp_int *c); /* 74 */ TCL_DEPRECATED_API("merged with mp_xor") mp_err (*tclBN_mp_tc_xor) (const mp_int *a, const mp_int *b, mp_int *c); /* 75 */ mp_err (*tclBN_mp_signed_rsh) (const mp_int *a, int b, mp_int *c) MP_WUR; /* 76 */ - void (*reserved77)(void); + size_t (*tclBN_mp_pack_count) (const mp_int *a, size_t nails, size_t size) MP_WUR; /* 77 */ int (*tclBN_mp_to_ubin) (const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR; /* 78 */ mp_err (*tclBN_mp_div_ld) (const mp_int *a, uint64_t b, mp_int *q, uint64_t *r) MP_WUR; /* 79 */ int (*tclBN_mp_to_radix) (const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) MP_WUR; /* 80 */ @@ -664,7 +672,8 @@ extern const TclTomMathStubs *tclTomMathStubsPtr; (tclTomMathStubsPtr->tclBN_mp_set_i64) /* 70 */ #define TclBN_mp_unpack \ (tclTomMathStubsPtr->tclBN_mp_unpack) /* 71 */ -/* Slot 72 is reserved */ +#define TclBN_mp_pack \ + (tclTomMathStubsPtr->tclBN_mp_pack) /* 72 */ #define TclBN_mp_tc_and \ (tclTomMathStubsPtr->tclBN_mp_tc_and) /* 73 */ #define TclBN_mp_tc_or \ @@ -673,7 +682,8 @@ extern const TclTomMathStubs *tclTomMathStubsPtr; (tclTomMathStubsPtr->tclBN_mp_tc_xor) /* 75 */ #define TclBN_mp_signed_rsh \ (tclTomMathStubsPtr->tclBN_mp_signed_rsh) /* 76 */ -/* Slot 77 is reserved */ +#define TclBN_mp_pack_count \ + (tclTomMathStubsPtr->tclBN_mp_pack_count) /* 77 */ #define TclBN_mp_to_ubin \ (tclTomMathStubsPtr->tclBN_mp_to_ubin) /* 78 */ #define TclBN_mp_div_ld \ diff --git a/unix/Makefile.in b/unix/Makefile.in index c1bfca5..edcb010 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -335,9 +335,9 @@ TOMMATH_OBJS = bn_s_mp_reverse.o bn_s_mp_mul_digs_fast.o \ bn_mp_init_i64.o bn_mp_init_u64.o \ bn_s_mp_karatsuba_sqr.o bn_s_mp_balance_mul.o \ bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mul.o bn_mp_mul_2.o \ - bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_neg.o bn_mp_or.o \ - bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_set_i64.o \ - bn_mp_read_radix.o bn_mp_rshd.o \ + bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_neg.o bn_mp_or.o bn_mp_pack.o \ + bn_mp_pack_count.o bn_mp_radix_size.o bn_mp_radix_smap.o \ + bn_mp_set_i64.o bn_mp_read_radix.o bn_mp_rshd.o \ bn_mp_set_u64.o bn_mp_shrink.o \ bn_mp_sqr.o bn_mp_sqrt.o bn_mp_sub.o bn_mp_sub_d.o \ bn_mp_signed_rsh.o \ @@ -1690,6 +1690,12 @@ bn_mp_neg.o: $(TOMMATH_DIR)/bn_mp_neg.c $(MATHHDRS) bn_mp_or.o: $(TOMMATH_DIR)/bn_mp_or.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_or.c +bn_mp_pack.o: $(TOMMATH_DIR)/bn_mp_pack.c $(MATHHDRS) + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_pack.c + +bn_mp_pack_count.o: $(TOMMATH_DIR)/bn_mp_pack_count.c $(MATHHDRS) + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_pack_count.c + bn_mp_radix_size.o: $(TOMMATH_DIR)/bn_mp_radix_size.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_radix_size.c diff --git a/win/Makefile.in b/win/Makefile.in index 0035a50..8d28c9e 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -401,6 +401,8 @@ TOMMATH_OBJS = \ bn_mp_mul_d.${OBJEXT} \ bn_mp_neg.${OBJEXT} \ bn_mp_or.${OBJEXT} \ + bn_mp_pack.${OBJEXT} \ + bn_mp_pack_count.${OBJEXT} \ bn_mp_radix_size.${OBJEXT} \ bn_mp_radix_smap.${OBJEXT} \ bn_mp_read_radix.${OBJEXT} \ diff --git a/win/makefile.vc b/win/makefile.vc index f9c9242..e583ae0 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -379,6 +379,8 @@ TOMMATHOBJS = \ $(TMP_DIR)\bn_mp_mul_d.obj \ $(TMP_DIR)\bn_mp_neg.obj \ $(TMP_DIR)\bn_mp_or.obj \ + $(TMP_DIR)\bn_mp_pack.obj \ + $(TMP_DIR)\bn_mp_pack_count.obj \ $(TMP_DIR)\bn_mp_radix_size.obj \ $(TMP_DIR)\bn_mp_radix_smap.obj \ $(TMP_DIR)\bn_mp_read_radix.obj \ -- cgit v0.12 From 386c7ea2d345ea032e96b2f0085bbaa31b204448 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Nov 2022 11:24:44 +0000 Subject: Since this FIXME! is already fixed, adapt documentation --- doc/LinkVar.3 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/doc/LinkVar.3 b/doc/LinkVar.3 index 3a41582..6d7ef12 100644 --- a/doc/LinkVar.3 +++ b/doc/LinkVar.3 @@ -239,9 +239,8 @@ The C variable, or each element of the C array, is of type \fBTcl_WideUInt\fR (which is an unsigned integer type at least 64-bits wide on all platforms that can support it.) Any value written into the Tcl variable must have a proper unsigned -integer form acceptable to \fBTcl_GetWideIntFromObj\fR (it will be -cast to unsigned); -.\" FIXME! Use bignums instead. +wideinteger form acceptable to \fBTcl_GetBignumFromObj\fR and in the +platform's defined range for the \fBTcl_WideUInt\fR type; attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/decimal/binary prefix) are accepted -- cgit v0.12 From 870cb82c96d74e93a642296f68319c777359a11d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Nov 2022 13:06:59 +0000 Subject: Change all mp_to_ubin() usages to mp_pack(). It makes the code much more clear --- generic/tclObj.c | 34 ++++++++++------------------------ 1 file changed, 10 insertions(+), 24 deletions(-) diff --git a/generic/tclObj.c b/generic/tclObj.c index ce8e610..bad3f85 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -3124,15 +3124,12 @@ Tcl_GetLongFromObj( { mp_int big; - unsigned long scratch, value = 0; - unsigned char *bytes = (unsigned char *) &scratch; + unsigned long value = 0; size_t numBytes; TclUnpackBignum(objPtr, big); - if (mp_to_ubin(&big, bytes, sizeof(long), &numBytes) == MP_OKAY) { - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } + if (mp_pack(&value, 1, + &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, &big) == MP_OKAY) { if (big.sign) { if (value <= 1 + (unsigned long)LONG_MAX) { *longPtr = (long)(-value); @@ -3364,14 +3361,10 @@ Tcl_GetWideIntFromObj( mp_int big; Tcl_WideUInt value = 0; size_t numBytes; - Tcl_WideInt scratch; - unsigned char *bytes = (unsigned char *) &scratch; TclUnpackBignum(objPtr, big); - if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes) == MP_OKAY) { - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } + if (mp_pack(&value, 1, + &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, &big) == MP_OKAY) { if (big.sign) { if (value <= 1 + ~(Tcl_WideUInt)WIDE_MIN) { *wideIntPtr = (Tcl_WideInt)(-value); @@ -3444,21 +3437,18 @@ TclGetWideBitsFromObj( mp_int big; mp_err err; - Tcl_WideUInt value = 0, scratch; + Tcl_WideUInt value = 0; size_t numBytes; - unsigned char *bytes = (unsigned char *) &scratch; Tcl_GetBignumFromObj(NULL, objPtr, &big); err = mp_mod_2d(&big, (int) (CHAR_BIT * sizeof(Tcl_WideInt)), &big); if (err == MP_OKAY) { - err = mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes); + err = mp_pack(&value, 1, + &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, &big); } if (err != MP_OKAY) { return TCL_ERROR; } - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } *wideIntPtr = !big.sign ? (Tcl_WideInt)value : -(Tcl_WideInt)value; mp_clear(&big); return TCL_OK; @@ -3828,19 +3818,15 @@ Tcl_SetBignumObj( { Tcl_WideUInt value = 0; size_t numBytes; - Tcl_WideUInt scratch; - unsigned char *bytes = (unsigned char *) &scratch; mp_int *bignumValue = (mp_int *) big; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj"); } - if (mp_to_ubin(bignumValue, bytes, sizeof(Tcl_WideUInt), &numBytes) != MP_OKAY) { + if (mp_pack(&value, 1, + &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, bignumValue) != MP_OKAY) { goto tooLargeForWide; } - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } if (value > ((Tcl_WideUInt)WIDE_MAX + bignumValue->sign)) { goto tooLargeForWide; } -- cgit v0.12 From d13a3cd5020a792d88f940a51eb79639c12331c3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Nov 2022 14:03:34 +0000 Subject: New function Tcl_GetWideUIntFromObj --- doc/IntObj.3 | 7 ++++- doc/LinkVar.3 | 3 +- generic/tcl.decls | 5 ++++ generic/tclDecls.h | 15 ++++++++++ generic/tclLink.c | 39 ++++--------------------- generic/tclObj.c | 81 +++++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclStubInit.c | 4 +++ 7 files changed, 118 insertions(+), 36 deletions(-) diff --git a/doc/IntObj.3 b/doc/IntObj.3 index d640dbb..18d867e 100644 --- a/doc/IntObj.3 +++ b/doc/IntObj.3 @@ -8,7 +8,7 @@ .so man.macros .BS .SH NAME -Tcl_NewIntObj, Tcl_NewLongObj, Tcl_NewWideIntObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_SetWideIntObj, Tcl_GetIntFromObj, Tcl_GetIntForIndex, Tcl_GetLongFromObj, Tcl_GetWideIntFromObj, Tcl_NewBignumObj, Tcl_SetBignumObj, Tcl_GetBignumFromObj, Tcl_TakeBignumFromObj \- manipulate Tcl values as integers +Tcl_NewIntObj, Tcl_NewLongObj, Tcl_NewWideIntObj, Tcl_SetIntObj, Tcl_SetLongObj, Tcl_SetWideIntObj, Tcl_GetIntFromObj, Tcl_GetIntForIndex, Tcl_GetLongFromObj, Tcl_GetWideIntFromObj, Tcl_GetWideUIntFromObj, Tcl_NewBignumObj, Tcl_SetBignumObj, Tcl_GetBignumFromObj, Tcl_TakeBignumFromObj \- manipulate Tcl values as integers .SH SYNOPSIS .nf \fB#include \fR @@ -40,6 +40,9 @@ int int \fBTcl_GetWideIntFromObj\fR(\fIinterp, objPtr, widePtr\fR) .sp +int +\fBTcl_GetWideUIntFromObj\fR(\fIinterp, objPtr, uwidePtr\fR) +.sp .sp \fB#include \fR .sp @@ -82,6 +85,8 @@ Points to place to store the integer value retrieved from \fIobjPtr\fR. Points to place to store the long integer value retrieved from \fIobjPtr\fR. .AP Tcl_WideInt *widePtr out Points to place to store the wide integer value retrieved from \fIobjPtr\fR. +.AP Tcl_WideUInt *uwidePtr out +Points to place to store the unsigned wide integer value retrieved from \fIobjPtr\fR. .AP mp_int *bigValue in/out Points to a multi-precision integer structure declared by the LibTomMath library. diff --git a/doc/LinkVar.3 b/doc/LinkVar.3 index 6d7ef12..f5e97b4 100644 --- a/doc/LinkVar.3 +++ b/doc/LinkVar.3 @@ -239,8 +239,7 @@ The C variable, or each element of the C array, is of type \fBTcl_WideUInt\fR (which is an unsigned integer type at least 64-bits wide on all platforms that can support it.) Any value written into the Tcl variable must have a proper unsigned -wideinteger form acceptable to \fBTcl_GetBignumFromObj\fR and in the -platform's defined range for the \fBTcl_WideUInt\fR type; +wideinteger form acceptable to \fBTcl_GetWideUIntFromObj\fR; attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/decimal/binary prefix) are accepted diff --git a/generic/tcl.decls b/generic/tcl.decls index 6d9fbbd..2128880 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2552,6 +2552,11 @@ declare 683 { int Tcl_GetEncodingNulLength(Tcl_Encoding encoding) } +declare 687 { + int Tcl_GetWideUIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + Tcl_WideUInt *uwidePtr) +} + # ----- BASELINE -- FOR -- 8.7.0 ----- # ############################################################################## diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 0888ecf..9c70434 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -2040,6 +2040,12 @@ EXTERN int Tcl_RemoveChannelMode(Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 683 */ EXTERN int Tcl_GetEncodingNulLength(Tcl_Encoding encoding); +/* Slot 684 is reserved */ +/* Slot 685 is reserved */ +/* Slot 686 is reserved */ +/* 687 */ +EXTERN int Tcl_GetWideUIntFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2759,6 +2765,10 @@ typedef struct TclStubs { int (*tcl_GetNumber) (Tcl_Interp *interp, const char *bytes, size_t numBytes, void **clientDataPtr, int *typePtr); /* 681 */ int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 682 */ int (*tcl_GetEncodingNulLength) (Tcl_Encoding encoding); /* 683 */ + void (*reserved684)(void); + void (*reserved685)(void); + void (*reserved686)(void); + int (*tcl_GetWideUIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); /* 687 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4157,6 +4167,11 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_RemoveChannelMode) /* 682 */ #define Tcl_GetEncodingNulLength \ (tclStubsPtr->tcl_GetEncodingNulLength) /* 683 */ +/* Slot 684 is reserved */ +/* Slot 685 is reserved */ +/* Slot 686 is reserved */ +#define Tcl_GetWideUIntFromObj \ + (tclStubsPtr->tcl_GetWideUIntFromObj) /* 687 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclLink.c b/generic/tclLink.c index 397c9bc..cd2c731 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -526,41 +526,14 @@ GetUWide( Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr) { - Tcl_WideInt *widePtr = (Tcl_WideInt *) uwidePtr; - void *clientData; - int type, intValue; - - if (Tcl_GetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) { - if (type == TCL_NUMBER_INT) { - *widePtr = *((const Tcl_WideInt *) clientData); - return (*widePtr < 0); - } else if (type == TCL_NUMBER_BIG) { - mp_int *numPtr = (mp_int *)clientData; - Tcl_WideUInt value = 0; - size_t numBytes; - - if (numPtr->sign || (MP_OKAY != mp_pack(&value, 1, - &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, numPtr))) { - /* - * If the sign bit is set (a negative value) or if the value - * can't possibly fit in the bits of an unsigned wide, there's - * no point in doing further conversion. - */ - return 1; - } - *uwidePtr = value; - return 0; - } - } - - /* - * Evil edge case fallback. - */ + if (Tcl_GetWideUIntFromObj(NULL, objPtr, uwidePtr) != TCL_OK) { + int intValue; - if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { - return 1; + if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { + return 1; + } + *uwidePtr = intValue; } - *uwidePtr = intValue; return 0; } diff --git a/generic/tclObj.c b/generic/tclObj.c index bad3f85..5a52e29 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -3394,6 +3394,87 @@ Tcl_GetWideIntFromObj( /* *---------------------------------------------------------------------- * + * Tcl_GetWideUIntFromObj -- + * + * Attempt to return a unsigned wide integer from the Tcl object "objPtr". If the + * object is not already a wide int object or a bignum object, an attempt will + * be made to convert it to one. + * + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during conversion, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * If the object is not already an int object, the conversion will free + * any old internal representation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetWideUIntFromObj( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* Object from which to get a wide int. */ + Tcl_WideUInt *wideUIntPtr) + /* Place to store resulting long. */ +{ + do { + if (objPtr->typePtr == &tclIntType) { + if (objPtr->internalRep.wideValue < 0) { + wideUIntOutOfRange: + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected unsigned integer but got \"%s\"", + TclGetString(objPtr))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); + } + return TCL_ERROR; + } + *wideUIntPtr = (Tcl_WideUInt)objPtr->internalRep.wideValue; + return TCL_OK; + } + if (objPtr->typePtr == &tclDoubleType) { + goto wideUIntOutOfRange; + } + if (objPtr->typePtr == &tclBignumType) { + /* + * Must check for those bignum values that can fit in a + * Tcl_WideInt, even when auto-narrowing is enabled. + */ + + mp_int big; + Tcl_WideUInt value = 0; + size_t numBytes; + + TclUnpackBignum(objPtr, big); + if (mp_pack(&value, 1, + &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, &big) == MP_OKAY) { + if (big.sign == MP_NEG) { + goto wideUIntOutOfRange; + } + if (value <= (Tcl_WideUInt)UWIDE_MAX) { + *wideUIntPtr = (Tcl_WideUInt)value; + return TCL_OK; + } + } + if (interp != NULL) { + const char *s = "integer value too large to represent"; + Tcl_Obj *msg = Tcl_NewStringObj(s, -1); + + Tcl_SetObjResult(interp, msg); + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); + } + return TCL_ERROR; + } + } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, + TCL_PARSE_INTEGER_ONLY)==TCL_OK); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * TclGetWideBitsFromObj -- * * Attempt to return a wide integer from the Tcl object "objPtr". If the diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index ad60fc3..e3c519b 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -2055,6 +2055,10 @@ const TclStubs tclStubs = { Tcl_GetNumber, /* 681 */ Tcl_RemoveChannelMode, /* 682 */ Tcl_GetEncodingNulLength, /* 683 */ + 0, /* 684 */ + 0, /* 685 */ + 0, /* 686 */ + Tcl_GetWideUIntFromObj, /* 687 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 9d2a40a82608f1e3d87aac7de2190dfcd92470da Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Nov 2022 14:36:01 +0000 Subject: Reserve stub entries 684/685 for TIP #648 and 686 for TIP #650 --- generic/tcl.decls | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 6d9fbbd..adaaf7c 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2552,7 +2552,22 @@ declare 683 { int Tcl_GetEncodingNulLength(Tcl_Encoding encoding) } -# ----- BASELINE -- FOR -- 8.7.0 ----- # +# TIP #648 (reserved) +#declare 684 { +# Tcl_Obj *Tcl_NewWideUIntObj(Tcl_WideUInt wideValue) +#} +#declare 685 { +# void Tcl_SetWideUIntObj(Tcl_Obj *objPtr, Tcl_WideUInt uwideValue) +#} + +# TIP #650 (reserved) +#declare 686 { +# int Tcl_GetWideUIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, +# Tcl_WideUInt *uwidePtr) +#} + + +# ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- # ############################################################################## -- cgit v0.12 From bc7b50deb01ade74b10ba048ed869537d7d8b1d1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 15 Nov 2022 22:09:09 +0000 Subject: Make httpd11.tcl work with Tcl 8.6 too --- tests/httpd11.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl index 55b52fd..b605005 100644 --- a/tests/httpd11.tcl +++ b/tests/httpd11.tcl @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcl +package require Tcl proc ::tcl::dict::get? {dict key} { if {[dict exists $dict $key]} { -- cgit v0.12 From c432e303c0b17ee4dde9a3ec3bc1e04c381b32e3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 16 Nov 2022 09:37:42 +0000 Subject: http 2.10a4 -> 2.10b1, for upcoming release --- library/http/http.tcl | 2 +- library/http/pkgIndex.tcl | 2 +- library/manifest.txt | 2 +- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 5 files changed, 7 insertions(+), 7 deletions(-) diff --git a/library/http/http.tcl b/library/http/http.tcl index a1d4a2b..1f476f3 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -11,7 +11,7 @@ package require Tcl 8.6- # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.10a4 +package provide http 2.10b1 namespace eval http { # Allow resourcing to not clobber existing data diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index 5437859..8977ef3 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.6-]} {return} -package ifneeded http 2.10a4 [list tclPkgSetup $dir http 2.10a4 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +package ifneeded http 2.10b1 [list tclPkgSetup $dir http 2.10b1 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] diff --git a/library/manifest.txt b/library/manifest.txt index 6d999e8..cc1e223 100644 --- a/library/manifest.txt +++ b/library/manifest.txt @@ -5,7 +5,7 @@ apply {{dir} { set ::test [info script] set isafe [interp issafe] foreach {safe package version file} { - 0 http 2.10a4 {http http.tcl} + 0 http 2.10b1 {http http.tcl} 1 msgcat 1.7.1 {msgcat msgcat.tcl} 1 opt 0.4.8 {opt optparse.tcl} 0 cookiejar 0.2.0 {cookiejar cookiejar.tcl} diff --git a/unix/Makefile.in b/unix/Makefile.in index edcb010..dcaf6e3 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -1041,9 +1041,9 @@ install-libraries: libraries do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \ done - @echo "Installing package http 2.10a4 as a Tcl Module" + @echo "Installing package http 2.10b1 as a Tcl Module" @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl \ - "$(MODULE_INSTALL_DIR)/8.6/http-2.10a4.tm" + "$(MODULE_INSTALL_DIR)/8.6/http-2.10b1.tm" @echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/" @for i in $(TOP_DIR)/library/opt/*.tcl; do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ diff --git a/win/Makefile.in b/win/Makefile.in index 8d28c9e..689f9b8 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -881,8 +881,8 @@ install-libraries: libraries install-tzdata install-msgs $(ROOT_DIR)/library/cookiejar/*.gz; do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \ done; - @echo "Installing package http 2.10a4 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.10a4.tm"; + @echo "Installing package http 2.10b1 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.10b1.tm"; @echo "Installing package opt 0.4.7"; @for j in $(ROOT_DIR)/library/opt/*.tcl; do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ -- cgit v0.12 From f9c4e3a8b2291e504e646c00229d5b335ab3aab8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 16 Nov 2022 20:39:34 +0000 Subject: Change 5 functions signatures from int -> size_t. Those should have been part of TIP #494 (Thanks, Gustaf!) --- generic/tcl.decls | 10 +++++----- generic/tclDecls.h | 20 ++++++++++---------- generic/tclUtf.c | 10 +++++----- 3 files changed, 20 insertions(+), 20 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 85e5082..da8ea4f 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1239,16 +1239,16 @@ declare 333 { const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr) } declare 334 { - int Tcl_UtfToLower(char *src) + Tcl_Size Tcl_UtfToLower(char *src) } declare 335 { - int Tcl_UtfToTitle(char *src) + Tcl_Size Tcl_UtfToTitle(char *src) } declare 336 { - int Tcl_UtfToChar16(const char *src, unsigned short *chPtr) + Tcl_Size Tcl_UtfToChar16(const char *src, unsigned short *chPtr) } declare 337 { - int Tcl_UtfToUpper(char *src) + Tcl_Size Tcl_UtfToUpper(char *src) } declare 338 { Tcl_Size Tcl_WriteChars(Tcl_Channel chan, const char *src, Tcl_Size srcLen) @@ -2454,7 +2454,7 @@ declare 645 { # TIP #548 declare 646 { - int Tcl_UtfToUniChar(const char *src, int *chPtr) + Tcl_Size Tcl_UtfToUniChar(const char *src, int *chPtr) } declare 647 { char *Tcl_UniCharToUtfDString(const int *uniStr, diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 8e4aa59..eebdb64 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -888,14 +888,14 @@ EXTERN char * Tcl_UtfToExternalDString(Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr); /* 334 */ -EXTERN int Tcl_UtfToLower(char *src); +EXTERN Tcl_Size Tcl_UtfToLower(char *src); /* 335 */ -EXTERN int Tcl_UtfToTitle(char *src); +EXTERN Tcl_Size Tcl_UtfToTitle(char *src); /* 336 */ -EXTERN int Tcl_UtfToChar16(const char *src, +EXTERN Tcl_Size Tcl_UtfToChar16(const char *src, unsigned short *chPtr); /* 337 */ -EXTERN int Tcl_UtfToUpper(char *src); +EXTERN Tcl_Size Tcl_UtfToUpper(char *src); /* 338 */ EXTERN Tcl_Size Tcl_WriteChars(Tcl_Channel chan, const char *src, Tcl_Size srcLen); @@ -1735,7 +1735,7 @@ EXTERN int Tcl_GetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size endValue, Tcl_Size *indexPtr); /* 646 */ -EXTERN int Tcl_UtfToUniChar(const char *src, int *chPtr); +EXTERN Tcl_Size Tcl_UtfToUniChar(const char *src, int *chPtr); /* 647 */ EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr); @@ -2197,10 +2197,10 @@ typedef struct TclStubs { const char * (*tclUtfPrev) (const char *src, const char *start); /* 331 */ int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, Tcl_Size dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */ char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, Tcl_DString *dsPtr); /* 333 */ - int (*tcl_UtfToLower) (char *src); /* 334 */ - int (*tcl_UtfToTitle) (char *src); /* 335 */ - int (*tcl_UtfToChar16) (const char *src, unsigned short *chPtr); /* 336 */ - int (*tcl_UtfToUpper) (char *src); /* 337 */ + Tcl_Size (*tcl_UtfToLower) (char *src); /* 334 */ + Tcl_Size (*tcl_UtfToTitle) (char *src); /* 335 */ + Tcl_Size (*tcl_UtfToChar16) (const char *src, unsigned short *chPtr); /* 336 */ + Tcl_Size (*tcl_UtfToUpper) (char *src); /* 337 */ Tcl_Size (*tcl_WriteChars) (Tcl_Channel chan, const char *src, Tcl_Size srcLen); /* 338 */ Tcl_Size (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */ char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */ @@ -2509,7 +2509,7 @@ typedef struct TclStubs { int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */ int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, Tcl_Size size); /* 644 */ int (*tcl_GetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size endValue, Tcl_Size *indexPtr); /* 645 */ - int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */ + Tcl_Size (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */ char * (*tcl_UniCharToUtfDString) (const int *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr); /* 647 */ int * (*tcl_UtfToUniCharDString) (const char *src, Tcl_Size length, Tcl_DString *dsPtr); /* 648 */ unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *numBytesPtr); /* 649 */ diff --git a/generic/tclUtf.c b/generic/tclUtf.c index e882f18..77a7cf2 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -447,7 +447,7 @@ static const unsigned short cp1252[32] = { }; #undef Tcl_UtfToUniChar -int +size_t Tcl_UtfToUniChar( const char *src, /* The UTF-8 string. */ int *chPtr)/* Filled with the Unicode character represented by @@ -530,7 +530,7 @@ Tcl_UtfToUniChar( return 1; } -int +size_t Tcl_UtfToChar16( const char *src, /* The UTF-8 string. */ unsigned short *chPtr)/* Filled with the Tcl_UniChar represented by @@ -1335,7 +1335,7 @@ Tcl_UtfBackslash( *---------------------------------------------------------------------- */ -int +size_t Tcl_UtfToUpper( char *str) /* String to convert in place. */ { @@ -1388,7 +1388,7 @@ Tcl_UtfToUpper( *---------------------------------------------------------------------- */ -int +size_t Tcl_UtfToLower( char *str) /* String to convert in place. */ { @@ -1442,7 +1442,7 @@ Tcl_UtfToLower( *---------------------------------------------------------------------- */ -int +size_t Tcl_UtfToTitle( char *str) /* String to convert in place. */ { -- cgit v0.12 From 197060f0971c7ba1c3148200b4c90fb0fa430859 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 16 Nov 2022 20:52:30 +0000 Subject: one more (Tcl_UniCharToUtf), and adapt documentation --- doc/ToUpper.3 | 6 +++--- doc/Utf.3 | 8 ++++---- generic/tcl.decls | 2 +- generic/tclDecls.h | 12 ++++++------ generic/tclUtf.c | 2 +- 5 files changed, 15 insertions(+), 15 deletions(-) diff --git a/doc/ToUpper.3 b/doc/ToUpper.3 index 37ebd2b..86d2f98 100644 --- a/doc/ToUpper.3 +++ b/doc/ToUpper.3 @@ -22,13 +22,13 @@ int int \fBTcl_UniCharToTitle\fR(\fIch\fR) .sp -int +size_t \fBTcl_UtfToUpper\fR(\fIstr\fR) .sp -int +size_t \fBTcl_UtfToLower\fR(\fIstr\fR) .sp -int +size_t \fBTcl_UtfToTitle\fR(\fIstr\fR) .SH ARGUMENTS .AS char *str in/out diff --git a/doc/Utf.3 b/doc/Utf.3 index 514c2dc..31cc333 100644 --- a/doc/Utf.3 +++ b/doc/Utf.3 @@ -15,16 +15,16 @@ Tcl_UniChar, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UtfToChar16, Tcl_UtfToWChar .sp typedef ... \fBTcl_UniChar\fR; .sp -int +size_t \fBTcl_UniCharToUtf\fR(\fIch, buf\fR) .sp -int +size_t \fBTcl_UtfToUniChar\fR(\fIsrc, chPtr\fR) .sp -int +size_t \fBTcl_UtfToChar16\fR(\fIsrc, uPtr\fR) .sp -int +size_t \fBTcl_UtfToWChar\fR(\fIsrc, wPtr\fR) .sp char * diff --git a/generic/tcl.decls b/generic/tcl.decls index da8ea4f..3fb1a43 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -1205,7 +1205,7 @@ declare 323 { int Tcl_UniCharToUpper(int ch) } declare 324 { - int Tcl_UniCharToUtf(int ch, char *buf) + Tcl_Size Tcl_UniCharToUtf(int ch, char *buf) } declare 325 { const char *TclUtfAtIndex(const char *src, Tcl_Size index) diff --git a/generic/tclDecls.h b/generic/tclDecls.h index eebdb64..90105bc 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -860,7 +860,7 @@ EXTERN int Tcl_UniCharToTitle(int ch); /* 323 */ EXTERN int Tcl_UniCharToUpper(int ch); /* 324 */ -EXTERN int Tcl_UniCharToUtf(int ch, char *buf); +EXTERN Tcl_Size Tcl_UniCharToUtf(int ch, char *buf); /* 325 */ EXTERN const char * TclUtfAtIndex(const char *src, Tcl_Size index); /* 326 */ @@ -2187,7 +2187,7 @@ typedef struct TclStubs { int (*tcl_UniCharToLower) (int ch); /* 321 */ int (*tcl_UniCharToTitle) (int ch); /* 322 */ int (*tcl_UniCharToUpper) (int ch); /* 323 */ - int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */ + Tcl_Size (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */ const char * (*tclUtfAtIndex) (const char *src, Tcl_Size index); /* 325 */ int (*tclUtfCharComplete) (const char *src, Tcl_Size length); /* 326 */ Tcl_Size (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */ @@ -4128,8 +4128,8 @@ extern const TclStubs *tclStubsPtr; ? (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))tclStubsPtr->tcl_UtfToUniCharDString \ : (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToChar16DString) # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ - ? (int (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToUniChar \ - : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16) + ? (Tcl_Size (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToUniChar \ + : (Tcl_Size (*)(const char *, wchar_t *))Tcl_UtfToChar16) # define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ ? (Tcl_Size (*)(wchar_t *))tclStubsPtr->tcl_UniCharLen \ : (Tcl_Size (*)(wchar_t *))Tcl_Char16Len) @@ -4169,8 +4169,8 @@ extern const TclStubs *tclStubsPtr; ? (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToUniCharDString \ : (wchar_t *(*)(const char *, Tcl_Size, Tcl_DString *))Tcl_UtfToChar16DString) # define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \ - ? (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar \ - : (int (*)(const char *, wchar_t *))Tcl_UtfToChar16) + ? (Tcl_Size (*)(const char *, wchar_t *))Tcl_UtfToUniChar \ + : (Tcl_Size (*)(const char *, wchar_t *))Tcl_UtfToChar16) # define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ ? (Tcl_Size (*)(wchar_t *))Tcl_UniCharLen \ : (Tcl_Size (*)(wchar_t *))Tcl_Char16Len) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 77a7cf2..92bcf4f 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -209,7 +209,7 @@ Invalid( */ #undef Tcl_UniCharToUtf -int +size_t Tcl_UniCharToUtf( int ch, /* The Tcl_UniChar to be stored in the * buffer. Can be or'ed with flag TCL_COMBINE */ -- cgit v0.12 From 00c7d174e45b9a5f10dc0de803dc98c4f1490061 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 17 Nov 2022 03:52:45 +0000 Subject: Reserve stub entry 687 for TIP #651 --- generic/tcl.decls | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tcl.decls b/generic/tcl.decls index adaaf7c..3f4103f 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2566,6 +2566,10 @@ declare 683 { # Tcl_WideUInt *uwidePtr) #} +# TIP 651 (reserved) +#declare 687 { +# Tcl_Obj *Tcl_DStringToObj(Tcl_DString *dsPtr) +#} # ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- # -- cgit v0.12 From e0becc6161a79eee0bcac49c6424690002100cd8 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 17 Nov 2022 04:54:02 +0000 Subject: TIP 651 implementation --- doc/DString.3 | 17 +++++++++++++++++ generic/tcl.decls | 8 ++++---- generic/tclDecls.h | 14 ++++++++++++++ generic/tclInt.h | 3 ++- generic/tclStubInit.c | 4 ++++ generic/tclTest.c | 9 +++++++-- generic/tclUtil.c | 2 +- tests/dstring.test | 39 +++++++++++++++++++++++++++++++++++++++ 8 files changed, 88 insertions(+), 8 deletions(-) diff --git a/doc/DString.3 b/doc/DString.3 index 00f1b8a..66323a7 100644 --- a/doc/DString.3 +++ b/doc/DString.3 @@ -41,6 +41,10 @@ char * \fBTcl_DStringResult\fR(\fIinterp, dsPtr\fR) .sp \fBTcl_DStringGetResult\fR(\fIinterp, dsPtr\fR) +.sp +Tcl_Obj * +\fBTcl_DStringToObj\fR(\fIdsPtr\fR) +.sp .SH ARGUMENTS .AS Tcl_DString newLength in/out .AP Tcl_DString *dsPtr in/out @@ -142,12 +146,25 @@ a pointer from \fIdsPtr\fR to the interpreter's result. This saves the cost of allocating new memory and copying the string. \fBTcl_DStringResult\fR also reinitializes the dynamic string to an empty string. +Since the dynamic string is reinitialized, there is no need to +further call \fBTcl_DStringFree\fR on it and it can be reused without +calling \fBTcl_DStringInit\fR. .PP \fBTcl_DStringGetResult\fR does the opposite of \fBTcl_DStringResult\fR. It sets the value of \fIdsPtr\fR to the result of \fIinterp\fR and it clears \fIinterp\fR's result. If possible it does this by moving a pointer rather than by copying the string. +.PP +\fBTcl_DStringToObj\fR returns a \fBTcl_Obj\fR containing the value of +the dynamic string given by \fIdsPtr\fR. It does this by moving +a pointer from \fIdsPtr\fR to a newly allocated \fBTcl_Obj\fR +and reinitializing to dynamic string to an empty string. +This saves the cost of allocating new memory and copying the string. +Since the dynamic string is reinitialized, there is no need to +further call \fBTcl_DStringFree\fR on it and it can be reused without +calling \fBTcl_DStringInit\fR. +The returned \fBTcl_Obj\fR has a reference count of 0. .SH KEYWORDS append, dynamic string, free, result diff --git a/generic/tcl.decls b/generic/tcl.decls index 3f4103f..59d0ece 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2566,10 +2566,10 @@ declare 683 { # Tcl_WideUInt *uwidePtr) #} -# TIP 651 (reserved) -#declare 687 { -# Tcl_Obj *Tcl_DStringToObj(Tcl_DString *dsPtr) -#} +# TIP 651 +declare 687 { + Tcl_Obj *Tcl_DStringToObj(Tcl_DString *dsPtr) +} # ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- # diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 0888ecf..3a57b2f 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -2040,6 +2040,11 @@ EXTERN int Tcl_RemoveChannelMode(Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 683 */ EXTERN int Tcl_GetEncodingNulLength(Tcl_Encoding encoding); +/* Slot 684 is reserved */ +/* Slot 685 is reserved */ +/* Slot 686 is reserved */ +/* 687 */ +EXTERN Tcl_Obj * Tcl_DStringToObj(Tcl_DString *dsPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2759,6 +2764,10 @@ typedef struct TclStubs { int (*tcl_GetNumber) (Tcl_Interp *interp, const char *bytes, size_t numBytes, void **clientDataPtr, int *typePtr); /* 681 */ int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 682 */ int (*tcl_GetEncodingNulLength) (Tcl_Encoding encoding); /* 683 */ + void (*reserved684)(void); + void (*reserved685)(void); + void (*reserved686)(void); + Tcl_Obj * (*tcl_DStringToObj) (Tcl_DString *dsPtr); /* 687 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4157,6 +4166,11 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_RemoveChannelMode) /* 682 */ #define Tcl_GetEncodingNulLength \ (tclStubsPtr->tcl_GetEncodingNulLength) /* 683 */ +/* Slot 684 is reserved */ +/* Slot 685 is reserved */ +/* Slot 686 is reserved */ +#define Tcl_DStringToObj \ + (tclStubsPtr->tcl_DStringToObj) /* 687 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 2d29e1d..9f0eef0 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3128,7 +3128,6 @@ MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr, Tcl_Obj *objPtr); MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, Tcl_DString *toAppendPtr); -MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp, Tcl_Obj *const *objv, int objc, int *objcPtr); MODULE_SCOPE Tcl_Obj *const *TclEnsembleGetRewriteValues(Tcl_Interp *interp); @@ -4946,6 +4945,8 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; Tcl_DStringAppend((dsPtr), (sLiteral), sizeof(sLiteral "") - 1) #define TclDStringClear(dsPtr) \ Tcl_DStringSetLength((dsPtr), 0) +/* Backward compatibility for TclDStringToObj which is now exported */ +#define TclDStringToObj Tcl_DStringToObj /* *---------------------------------------------------------------- diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index ad60fc3..b3eb0de 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -2055,6 +2055,10 @@ const TclStubs tclStubs = { Tcl_GetNumber, /* 681 */ Tcl_RemoveChannelMode, /* 682 */ Tcl_GetEncodingNulLength, /* 683 */ + 0, /* 684 */ + 0, /* 685 */ + 0, /* 686 */ + Tcl_DStringToObj, /* 687 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index c9bad56..86fd965 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -1934,6 +1934,11 @@ TestdstringCmd( goto wrongNumArgs; } Tcl_DStringResult(interp, &dstring); + } else if (strcmp(argv[1], "toobj") == 0) { + if (argc != 2) { + goto wrongNumArgs; + } + Tcl_SetObjResult(interp, Tcl_DStringToObj(&dstring)); } else if (strcmp(argv[1], "trunc") == 0) { if (argc != 3) { goto wrongNumArgs; @@ -1949,8 +1954,8 @@ TestdstringCmd( Tcl_DStringStartSublist(&dstring); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], - "\": must be append, element, end, free, get, length, " - "result, trunc, or start", NULL); + "\": must be append, element, end, free, get, gresult, length, " + "result, start, toobj, or trunc", NULL); return TCL_ERROR; } return TCL_OK; diff --git a/generic/tclUtil.c b/generic/tclUtil.c index ab97461..fc5d1cc 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3107,7 +3107,7 @@ Tcl_DStringGetResult( */ Tcl_Obj * -TclDStringToObj( +Tcl_DStringToObj( Tcl_DString *dsPtr) { Tcl_Obj *result; diff --git a/tests/dstring.test b/tests/dstring.test index 11c5754..314cee8 100644 --- a/tests/dstring.test +++ b/tests/dstring.test @@ -473,6 +473,45 @@ test dstring-6.5 {Tcl_DStringGetResult} -constraints testdstring -body { } -cleanup { testdstring free } -result {{} {This is a specially-allocated stringz}} + +test dstring-7.1 {copying to Tcl_Obj} -constraints testdstring -setup { + testdstring free +} -body { + testdstring append xyz -1 + list [testdstring toobj] [testdstring length] +} -cleanup { + testdstring free +} -result {xyz 0} +test dstring-7.2 {copying to a Tcl_Obj} -constraints testdstring -setup { + testdstring free + unset -nocomplain a +} -body { + foreach l {a b c d e f g h i j k l m n o p} { + testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1 + } + set a [testdstring toobj] + testdstring append abc -1 + list $a [testdstring get] +} -cleanup { + testdstring free +} -result {{aaaaaaaaaaaaaaaaaaaaa +bbbbbbbbbbbbbbbbbbbbb +ccccccccccccccccccccc +ddddddddddddddddddddd +eeeeeeeeeeeeeeeeeeeee +fffffffffffffffffffff +ggggggggggggggggggggg +hhhhhhhhhhhhhhhhhhhhh +iiiiiiiiiiiiiiiiiiiii +jjjjjjjjjjjjjjjjjjjjj +kkkkkkkkkkkkkkkkkkkkk +lllllllllllllllllllll +mmmmmmmmmmmmmmmmmmmmm +nnnnnnnnnnnnnnnnnnnnn +ooooooooooooooooooooo +ppppppppppppppppppppp +} abc} + # cleanup if {[testConstraint testdstring]} { -- cgit v0.12 From 8b9fe0fa5355f282642f092c269ffa174813ba73 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Nov 2022 11:18:51 +0000 Subject: doc update --- doc/OpenFileChnl.3 | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/doc/OpenFileChnl.3 b/doc/OpenFileChnl.3 index 4e42b93..e8ed521 100644 --- a/doc/OpenFileChnl.3 +++ b/doc/OpenFileChnl.3 @@ -406,10 +406,10 @@ to UTF-8 based on the channel's encoding and storing the produced data in \fIreadObjPtr\fR's string representation. The return value of \fBTcl_ReadChars\fR is the number of characters, up to \fIcharsToRead\fR, that were stored in \fIreadObjPtr\fR. If an error occurs while reading, the -return value is \-1 and \fBTcl_ReadChars\fR records a POSIX error code that +return value is TCL_INDEX_NONE and \fBTcl_ReadChars\fR records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. .PP -Setting \fIcharsToRead\fR to \fB\-1\fR will cause the command to read +Setting \fIcharsToRead\fR to TCL_INDEX_NONE will cause the command to read all characters currently available (non-blocking) or everything until eof (blocking mode). .PP @@ -471,14 +471,14 @@ character(s) are read and discarded. .PP If a line was successfully read, the return value is greater than or equal to zero and indicates the number of bytes stored in \fIlineObjPtr\fR. If an -error occurs, \fBTcl_GetsObj\fR returns \-1 and records a POSIX error code +error occurs, \fBTcl_GetsObj\fR returns TCL_INDEX_NONE and records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. \fBTcl_GetsObj\fR also -returns \-1 if the end of the file is reached; the \fBTcl_Eof\fR procedure +returns TCL_INDEX_NONE if the end of the file is reached; the \fBTcl_Eof\fR procedure can be used to distinguish an error from an end-of-file condition. .PP -If the channel is in nonblocking mode, the return value can also be \-1 if -no data was available or the data that was available did not contain an -end-of-line character. When \-1 is returned, the \fBTcl_InputBlocked\fR +If the channel is in nonblocking mode, the return value can also be TCL_INDEX_NONE +if no data was available or the data that was available did not contain an +end-of-line character. When TCL_INDEX_NONE is returned, the \fBTcl_InputBlocked\fR procedure may be invoked to determine if the channel is blocked because of input unavailability. .PP @@ -496,7 +496,7 @@ head of the queue. If \fIchannel\fR has a .QW sticky EOF set, no data will be added to the input queue. \fBTcl_Ungets\fR returns \fIinputLen\fR or -\-1 if an error occurs. +TCL_INDEX_NONE if an error occurs. .SH "TCL_WRITECHARS, TCL_WRITEOBJ, AND TCL_WRITE" .PP \fBTcl_WriteChars\fR accepts \fIbytesToWrite\fR bytes of character data at @@ -513,10 +513,10 @@ to appear as soon as a complete line is accepted for output, set the \fB\-buffering\fR option on the channel to \fBline\fR mode. .PP The return value of \fBTcl_WriteChars\fR is a count of how many bytes were -accepted for output to the channel. This is either greater than zero to -indicate success or \-1 to indicate that an error occurred. If an error -occurs, \fBTcl_WriteChars\fR records a POSIX error code that may be -retrieved with \fBTcl_GetErrno\fR. +accepted for output to the channel. This is either TCL_INDEX_NONE to +indicate that an error occurred or another number greater than +zero to indicate success. If an error occurs, \fBTcl_WriteChars\fR records +a POSIX error code that may be retrieved with \fBTcl_GetErrno\fR. .PP Newline characters in the output data are translated to platform-specific end-of-line sequences according to the \fB\-translation\fR option for the -- cgit v0.12 From b669079dd69a6f5b0027edd74d53f8b0390769f3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 17 Nov 2022 20:24:20 +0000 Subject: Add dummy TCL_OBJTYPE_V0 #define. Minimal no-op backport of TIP #644 --- generic/tcl.h | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tcl.h b/generic/tcl.h index e705cdb..800ffa1 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -752,6 +752,7 @@ typedef struct Tcl_ObjType { * to this type. Frees the internal rep of the * old type. Returns TCL_ERROR on failure. */ } Tcl_ObjType; +#define TCL_OBJTYPE_V0 /* just empty */ /* * The following structure stores an internal representation (internalrep) for -- cgit v0.12 From a65db858ffa31d266f6b08eac9d609153db39d90 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 18 Nov 2022 15:24:44 +0000 Subject: Fix bug in TIP #628: Tcl 8.x version of registry/dde dll was not correct --- win/Makefile.in | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/win/Makefile.in b/win/Makefile.in index a2b8ea7..296b398 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -150,10 +150,10 @@ TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@ TCL_DLL_FILE = @TCL_DLL_FILE@ TCL_LIB_FILE = @TCL_LIB_FILE@ DDE_DLL_FILE = tcl9dde$(DDEVER)${DLLSUFFIX} -DDE_DLL_FILE8 = dde$(DDEVER)${DLLSUFFIX} +DDE_DLL_FILE8 = tcldde$(DDEVER)${DLLSUFFIX} DDE_LIB_FILE = @LIBPREFIX@tcldde$(DDEVER)${DLLSUFFIX}${LIBSUFFIX} REG_DLL_FILE = tcl9registry$(REGVER)${DLLSUFFIX} -REG_DLL_FILE8 = registry$(REGVER)${DLLSUFFIX} +REG_DLL_FILE8 = tclregistry$(REGVER)${DLLSUFFIX} REG_LIB_FILE = @LIBPREFIX@tclregistry$(REGVER)${DLLSUFFIX}${LIBSUFFIX} TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX} TEST_EXE_FILE = tcltest${EXESUFFIX} -- cgit v0.12 From ae54d4dd89479887660e43d8189196e5ec1a2fa2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 18 Nov 2022 16:24:27 +0000 Subject: Another bug in TIP #628: dde and registry extensions didn't really load in tclsh8.7. One reason: handle TclpReaddir correctly in tcl8 compatibility mode --- generic/tclIntPlatDecls.h | 6 +----- win/Makefile.in | 14 ++++++++++---- win/tclWinDde.c | 2 +- win/tclWinReg.c | 2 +- 4 files changed, 13 insertions(+), 11 deletions(-) diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 1ec9259..cab43a4 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -140,8 +140,6 @@ EXTERN int TclWinSetSockOpt(SOCKET s, int level, int optname, EXTERN int TclpGetPid(Tcl_Pid pid); /* 9 */ EXTERN int TclWinGetPlatformId(void); -/* 10 */ -EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); /* 11 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); @@ -316,7 +314,7 @@ typedef struct TclIntPlatStubs { int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, const char *optval, int optlen); /* 7 */ int (*tclpGetPid) (Tcl_Pid pid); /* 8 */ int (*tclWinGetPlatformId) (void); /* 9 */ - Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ + void *(*tclpReaddir) (void *dir); /* 10 */ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ int (*tclpCloseFile) (TclFile file); /* 12 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ @@ -462,8 +460,6 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ #define TclWinGetPlatformId \ (tclIntPlatStubsPtr->tclWinGetPlatformId) /* 9 */ -#define TclpReaddir \ - (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ #define TclpCloseFile \ diff --git a/win/Makefile.in b/win/Makefile.in index 296b398..7a5dc09 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -593,12 +593,12 @@ ${REG_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${REG_OBJS} @MAKE_DLL@ ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) $(COPY) tclsh.exe.manifest ${REG_DLL_FILE}.manifest -${DDE_DLL_FILE8}: ${TCL_STUB_LIB_FILE} ${DDE_OBJS} - @MAKE_DLL@ -DTCL_MAJOR_VERSION=8 ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) +${DDE_DLL_FILE8}: ${TCL_STUB_LIB_FILE} tcl8WinDde.$(OBJEXT) + @MAKE_DLL@ tcl8WinDde.$(OBJEXT) $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) $(COPY) tclsh.exe.manifest ${DDE_DLL_FILE8}.manifest -${REG_DLL_FILE8}: ${TCL_STUB_LIB_FILE} ${REG_OBJS} - @MAKE_DLL@ -DTCL_MAJOR_VERSION=8 ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) +${REG_DLL_FILE8}: ${TCL_STUB_LIB_FILE} tcl8WinReg.$(OBJEXT) + @MAKE_DLL@ -DTCL_MAJOR_VERSION=8 tcl8WinReg.$(OBJEXT) $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) $(COPY) tclsh.exe.manifest ${REG_DLL_FILE8}.manifest ${TEST_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} @@ -653,9 +653,15 @@ tclWinPipe.${OBJEXT}: tclWinPipe.c tclWinReg.${OBJEXT}: tclWinReg.c $(CC) -c $(CC_SWITCHES) $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) +tcl8WinReg.${OBJEXT}: tclWinReg.c + $(CC) -o $@ -c $(CC_SWITCHES) -DTCL_MAJOR_VERSION=8 $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) + tclWinDde.${OBJEXT}: tclWinDde.c $(CC) -c $(CC_SWITCHES) $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) +tcl8WinDde.${OBJEXT}: tclWinDde.c + $(CC) -o $@ -c $(CC_SWITCHES) -DTCL_MAJOR_VERSION=8 $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) + tclAppInit.${OBJEXT}: tclAppInit.c $(CC) -c $(CC_SWITCHES) $(EXTFLAGS) -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME) diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 1c10c65..23d0bce 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -117,7 +117,7 @@ static int DdeObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -#if (TCL_MAJOR_VERSION < 9) && (TCL_MINOR_VERSION < 7) +#if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7) # if TCL_UTF_MAX > 3 # define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf((TCHAR *)(a),(b)*sizeof(WCHAR),c) # define Tcl_UtfToWCharDString(a,b,c) (WCHAR *)Tcl_WinUtfToTChar(a,b,c) diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 998521c..a3341c2 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -124,7 +124,7 @@ static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, Tcl_Obj *valueNameObj, Tcl_Obj *dataObj, Tcl_Obj *typeObj, REGSAM mode); -#if (TCL_MAJOR_VERSION < 9) && (TCL_MINOR_VERSION < 7) +#if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7) # if TCL_UTF_MAX > 3 # define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf((TCHAR *)(a),(b)*sizeof(WCHAR),c) # define Tcl_UtfToWCharDString(a,b,c) (WCHAR *)Tcl_WinUtfToTChar(a,b,c) -- cgit v0.12 From 3e4ac217aab55243d9096d19d611bfd368a4aa9b Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 18 Nov 2022 17:53:54 +0000 Subject: Bring back the common facilities of the tcltests "package", but use a less fragile method to gain access to them. --- tests/chanio.test | 1 + tests/env.test | 2 ++ tests/exec.test | 4 +--- tests/fileSystemEncoding.test | 15 +-------------- tests/io.test | 1 + tests/ioCmd.test | 1 + tests/platform.test | 1 + tests/tcltests.tcl | 3 +++ tests/thread.test | 2 +- 9 files changed, 12 insertions(+), 18 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index 0f45819..1c689fb 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -34,6 +34,7 @@ namespace eval ::tcl::test::io { package require -exact Tcltest [info patchlevel] set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] } + source [file join [file dirname [info script]] tcltests.tcl] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] diff --git a/tests/env.test b/tests/env.test index 6c46532..bc1d7e9 100644 --- a/tests/env.test +++ b/tests/env.test @@ -16,6 +16,8 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +source [file join [file dirname [info script]] tcltests.tcl] + # [exec] is required here to see the actual environment received by child # processes. proc getenv {} { diff --git a/tests/exec.test b/tests/exec.test index 4cc4a05..3c445e8 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -18,10 +18,8 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } +source [file join [file dirname [info script]] tcltests.tcl] -# All tests require the "exec" command. -# Skip them if exec is not defined. -testConstraint exec [llength [info commands exec]] # Some skips when running in a macOS CI environment testConstraint noosxCI [expr {![info exists ::env(MAC_CI)]}] diff --git a/tests/fileSystemEncoding.test b/tests/fileSystemEncoding.test index 6561bef..24003b8 100644 --- a/tests/fileSystemEncoding.test +++ b/tests/fileSystemEncoding.test @@ -15,20 +15,7 @@ namespace eval ::tcl::test::fileSystemEncoding { variable fname1 \u767b\u9e1b\u9d72\u6a13 - proc autopath {} { - global auto_path - set scriptpath [info script] - set scriptpathnorm [file dirname [file normalize $scriptpath/...]] - set dirnorm [file dirname $scriptpathnorm] - set idx [lsearch -exact $auto_path $dirnorm] - if {$idx >= 0} { - set auto_path [lreplace $auto_path[set auto_path {}] $idx $idx {}] - } - set auto_path [linsert $auto_path[set auto_path {}] 0 0 $dirnorm] - } - autopath - - package require tcltests + source [file join [file dirname [info script]] tcltests.tcl] test filesystemEncoding-1.0 { issue bcd100410465 diff --git a/tests/io.test b/tests/io.test index cd4c954..ca7bd0c 100644 --- a/tests/io.test +++ b/tests/io.test @@ -34,6 +34,7 @@ namespace eval ::tcl::test::io { package require -exact Tcltest [info patchlevel] set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] } + source [file join [file dirname [info script]] tcltests.tcl] testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 99bb464..d17dce3 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -17,6 +17,7 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } +source [file join [file dirname [info script]] tcltests.tcl] ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] diff --git a/tests/platform.test b/tests/platform.test index 6b775cf..faab6d9 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -10,6 +10,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require tcltest 2.5 +source [file join [file dirname [info script]] tcltests.tcl] namespace eval ::tcl::test::platform { namespace import ::tcltest::testConstraint diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl index 58e6bfb..1a473e9 100644 --- a/tests/tcltests.tcl +++ b/tests/tcltests.tcl @@ -1,5 +1,8 @@ #! /usr/bin/env tclsh +# Don't overwrite tcltests facilities already present +if {[package provide tcltests] ne {}} return + package require tcltest 2.5 namespace import ::tcltest::* diff --git a/tests/thread.test b/tests/thread.test index 28934a2..92f3a06 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -16,7 +16,7 @@ # be fully finalized, which avoids valgrind "still reachable" reports. package require tcltest 2.5 -namespace import ::tcltest::* +source [file join [file dirname [info script]] tcltests.tcl] ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -- cgit v0.12 From 78bce4ec934a2cce5174e894d2c845df212f71b9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 18 Nov 2022 19:17:32 +0000 Subject: Fix [bec4219123]: test utf-4.12 fails in custom builds --- generic/tclTest.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/generic/tclTest.c b/generic/tclTest.c index c9bad56..2ebbcc2 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -20,10 +20,12 @@ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif +#undef TCL_UTF_MAX #ifdef TCL_NO_DEPRECATED # define TCL_UTF_MAX 4 #else # define TCL_NO_DEPRECATED +# define TCL_UTF_MAX 3 #endif #include "tclInt.h" #ifdef TCL_WITH_EXTERNAL_TOMMATH -- cgit v0.12 From 90a23f176d6423227cc2fd2be8cd3a88ceb1c088 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 18 Nov 2022 19:43:09 +0000 Subject: Fix [https://core.tcl-lang.org/thread/tktview?name=16bf24d70b|16bf24d70b]: Installed Thread for Tcl 8.7 breaks availability of Thread in 8.6 --- generic/tcl.h | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 800ffa1..26054ea 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2405,27 +2405,14 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp, #endif #ifdef USE_TCL_STUBS -#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE # define Tcl_InitStubs(interp, version, exact) \ (Tcl_InitStubs)(interp, version, \ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ TCL_STUB_MAGIC) #else # define Tcl_InitStubs(interp, version, exact) \ - (Tcl_InitStubs)(interp, TCL_PATCH_LEVEL, \ - 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ - TCL_STUB_MAGIC) -#endif -#else -#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE -# define Tcl_InitStubs(interp, version, exact) \ Tcl_PkgInitStubsCheck(interp, version, \ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) -#else -# define Tcl_InitStubs(interp, version, exact) \ - Tcl_PkgInitStubsCheck(interp, TCL_PATCH_LEVEL, \ - 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) -#endif #endif /* -- cgit v0.12 From 0bcca87681ea390671d67a96f771697c9f5ff3be Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 18 Nov 2022 20:26:52 +0000 Subject: Backout [52a52a65f0], let's see if this fixes the Windows crash --- generic/tclLink.c | 19 +++++++++++++++++-- generic/tclObj.c | 34 ++++++++++++++++++++++++---------- 2 files changed, 41 insertions(+), 12 deletions(-) diff --git a/generic/tclLink.c b/generic/tclLink.c index 397c9bc..1973067 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -537,10 +537,15 @@ GetUWide( } else if (type == TCL_NUMBER_BIG) { mp_int *numPtr = (mp_int *)clientData; Tcl_WideUInt value = 0; + union { + Tcl_WideUInt value; + unsigned char bytes[sizeof(Tcl_WideUInt)]; + } scratch; size_t numBytes; + unsigned char *bytes = scratch.bytes; - if (numPtr->sign || (MP_OKAY != mp_pack(&value, 1, - &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, numPtr))) { + if (numPtr->sign || (MP_OKAY != mp_to_ubin(numPtr, + bytes, sizeof(Tcl_WideUInt), &numBytes))) { /* * If the sign bit is set (a negative value) or if the value * can't possibly fit in the bits of an unsigned wide, there's @@ -548,6 +553,16 @@ GetUWide( */ return 1; } +#ifndef WORDS_BIGENDIAN + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } +#else /* WORDS_BIGENDIAN */ + /* + * Big-endian can read the value directly. + */ + value = scratch.value; +#endif /* WORDS_BIGENDIAN */ *uwidePtr = value; return 0; } diff --git a/generic/tclObj.c b/generic/tclObj.c index bad3f85..ce8e610 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -3124,12 +3124,15 @@ Tcl_GetLongFromObj( { mp_int big; - unsigned long value = 0; + unsigned long scratch, value = 0; + unsigned char *bytes = (unsigned char *) &scratch; size_t numBytes; TclUnpackBignum(objPtr, big); - if (mp_pack(&value, 1, - &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, &big) == MP_OKAY) { + if (mp_to_ubin(&big, bytes, sizeof(long), &numBytes) == MP_OKAY) { + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } if (big.sign) { if (value <= 1 + (unsigned long)LONG_MAX) { *longPtr = (long)(-value); @@ -3361,10 +3364,14 @@ Tcl_GetWideIntFromObj( mp_int big; Tcl_WideUInt value = 0; size_t numBytes; + Tcl_WideInt scratch; + unsigned char *bytes = (unsigned char *) &scratch; TclUnpackBignum(objPtr, big); - if (mp_pack(&value, 1, - &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, &big) == MP_OKAY) { + if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes) == MP_OKAY) { + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } if (big.sign) { if (value <= 1 + ~(Tcl_WideUInt)WIDE_MIN) { *wideIntPtr = (Tcl_WideInt)(-value); @@ -3437,18 +3444,21 @@ TclGetWideBitsFromObj( mp_int big; mp_err err; - Tcl_WideUInt value = 0; + Tcl_WideUInt value = 0, scratch; size_t numBytes; + unsigned char *bytes = (unsigned char *) &scratch; Tcl_GetBignumFromObj(NULL, objPtr, &big); err = mp_mod_2d(&big, (int) (CHAR_BIT * sizeof(Tcl_WideInt)), &big); if (err == MP_OKAY) { - err = mp_pack(&value, 1, - &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, &big); + err = mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes); } if (err != MP_OKAY) { return TCL_ERROR; } + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } *wideIntPtr = !big.sign ? (Tcl_WideInt)value : -(Tcl_WideInt)value; mp_clear(&big); return TCL_OK; @@ -3818,15 +3828,19 @@ Tcl_SetBignumObj( { Tcl_WideUInt value = 0; size_t numBytes; + Tcl_WideUInt scratch; + unsigned char *bytes = (unsigned char *) &scratch; mp_int *bignumValue = (mp_int *) big; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj"); } - if (mp_pack(&value, 1, - &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, bignumValue) != MP_OKAY) { + if (mp_to_ubin(bignumValue, bytes, sizeof(Tcl_WideUInt), &numBytes) != MP_OKAY) { goto tooLargeForWide; } + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } if (value > ((Tcl_WideUInt)WIDE_MAX + bignumValue->sign)) { goto tooLargeForWide; } -- cgit v0.12 From 1c1ee1c59dab10aa856f9ecc8a2e9613aa69c04e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 18 Nov 2022 21:43:40 +0000 Subject: Backout [52a52a65f0], let's see if this fixes the Windows crash --- generic/tclLink.c | 54 ++++++++++++++++++++++++++++++++++++++++++++++++------ generic/tclObj.c | 49 +++++++++++++++++++++++++++++++++---------------- 2 files changed, 81 insertions(+), 22 deletions(-) diff --git a/generic/tclLink.c b/generic/tclLink.c index cd2c731..1973067 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -526,14 +526,56 @@ GetUWide( Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr) { - if (Tcl_GetWideUIntFromObj(NULL, objPtr, uwidePtr) != TCL_OK) { - int intValue; - - if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { - return 1; + Tcl_WideInt *widePtr = (Tcl_WideInt *) uwidePtr; + void *clientData; + int type, intValue; + + if (Tcl_GetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) { + if (type == TCL_NUMBER_INT) { + *widePtr = *((const Tcl_WideInt *) clientData); + return (*widePtr < 0); + } else if (type == TCL_NUMBER_BIG) { + mp_int *numPtr = (mp_int *)clientData; + Tcl_WideUInt value = 0; + union { + Tcl_WideUInt value; + unsigned char bytes[sizeof(Tcl_WideUInt)]; + } scratch; + size_t numBytes; + unsigned char *bytes = scratch.bytes; + + if (numPtr->sign || (MP_OKAY != mp_to_ubin(numPtr, + bytes, sizeof(Tcl_WideUInt), &numBytes))) { + /* + * If the sign bit is set (a negative value) or if the value + * can't possibly fit in the bits of an unsigned wide, there's + * no point in doing further conversion. + */ + return 1; + } +#ifndef WORDS_BIGENDIAN + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } +#else /* WORDS_BIGENDIAN */ + /* + * Big-endian can read the value directly. + */ + value = scratch.value; +#endif /* WORDS_BIGENDIAN */ + *uwidePtr = value; + return 0; } - *uwidePtr = intValue; } + + /* + * Evil edge case fallback. + */ + + if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { + return 1; + } + *uwidePtr = intValue; return 0; } diff --git a/generic/tclObj.c b/generic/tclObj.c index 5a52e29..cc792c7 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -3124,12 +3124,15 @@ Tcl_GetLongFromObj( { mp_int big; - unsigned long value = 0; + unsigned long scratch, value = 0; + unsigned char *bytes = (unsigned char *) &scratch; size_t numBytes; TclUnpackBignum(objPtr, big); - if (mp_pack(&value, 1, - &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, &big) == MP_OKAY) { + if (mp_to_ubin(&big, bytes, sizeof(long), &numBytes) == MP_OKAY) { + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } if (big.sign) { if (value <= 1 + (unsigned long)LONG_MAX) { *longPtr = (long)(-value); @@ -3361,10 +3364,14 @@ Tcl_GetWideIntFromObj( mp_int big; Tcl_WideUInt value = 0; size_t numBytes; + Tcl_WideInt scratch; + unsigned char *bytes = (unsigned char *) &scratch; TclUnpackBignum(objPtr, big); - if (mp_pack(&value, 1, - &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, &big) == MP_OKAY) { + if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes) == MP_OKAY) { + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } if (big.sign) { if (value <= 1 + ~(Tcl_WideUInt)WIDE_MIN) { *wideIntPtr = (Tcl_WideInt)(-value); @@ -3440,24 +3447,27 @@ Tcl_GetWideUIntFromObj( if (objPtr->typePtr == &tclBignumType) { /* * Must check for those bignum values that can fit in a - * Tcl_WideInt, even when auto-narrowing is enabled. + * Tcl_WideUInt, even when auto-narrowing is enabled. */ mp_int big; Tcl_WideUInt value = 0; size_t numBytes; + Tcl_WideUInt scratch; + unsigned char *bytes = (unsigned char *) &scratch; TclUnpackBignum(objPtr, big); - if (mp_pack(&value, 1, - &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, &big) == MP_OKAY) { if (big.sign == MP_NEG) { goto wideUIntOutOfRange; } - if (value <= (Tcl_WideUInt)UWIDE_MAX) { - *wideUIntPtr = (Tcl_WideUInt)value; - return TCL_OK; + if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideUInt), &numBytes) == MP_OKAY) { + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; } + *wideUIntPtr = (Tcl_WideUInt)value; + return TCL_OK; } + if (interp != NULL) { const char *s = "integer value too large to represent"; Tcl_Obj *msg = Tcl_NewStringObj(s, -1); @@ -3518,18 +3528,21 @@ TclGetWideBitsFromObj( mp_int big; mp_err err; - Tcl_WideUInt value = 0; + Tcl_WideUInt value = 0, scratch; size_t numBytes; + unsigned char *bytes = (unsigned char *) &scratch; Tcl_GetBignumFromObj(NULL, objPtr, &big); err = mp_mod_2d(&big, (int) (CHAR_BIT * sizeof(Tcl_WideInt)), &big); if (err == MP_OKAY) { - err = mp_pack(&value, 1, - &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, &big); + err = mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes); } if (err != MP_OKAY) { return TCL_ERROR; } + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } *wideIntPtr = !big.sign ? (Tcl_WideInt)value : -(Tcl_WideInt)value; mp_clear(&big); return TCL_OK; @@ -3899,15 +3912,19 @@ Tcl_SetBignumObj( { Tcl_WideUInt value = 0; size_t numBytes; + Tcl_WideUInt scratch; + unsigned char *bytes = (unsigned char *) &scratch; mp_int *bignumValue = (mp_int *) big; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj"); } - if (mp_pack(&value, 1, - &numBytes, 0, sizeof(Tcl_WideUInt), 0, 0, bignumValue) != MP_OKAY) { + if (mp_to_ubin(bignumValue, bytes, sizeof(Tcl_WideUInt), &numBytes) != MP_OKAY) { goto tooLargeForWide; } + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } if (value > ((Tcl_WideUInt)WIDE_MAX + bignumValue->sign)) { goto tooLargeForWide; } -- cgit v0.12 From 124340611ed97ad4347b3ce4bc6aa1d76a99f1b0 Mon Sep 17 00:00:00 2001 From: dgp Date: Sun, 20 Nov 2022 14:16:36 +0000 Subject: Newest tests must have most recent releases of http to pass. --- tests/http.test | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/tests/http.test b/tests/http.test index b0f5144..498621b 100644 --- a/tests/http.test +++ b/tests/http.test @@ -30,6 +30,8 @@ if {[catch {package require http 2} version]} { return } } +testConstraint http2.9.7 [package vsatisfies [package provide http] 2.9.7] +testConstraint http2.9.8 [package vsatisfies [package provide http] 2.9.8] proc bgerror {args} { global errorInfo @@ -119,25 +121,25 @@ test http-1.6 {http::config} -setup { test http-2.1 {http::reset} { catch {http::reset http#1} } 0 -test http-2.2 {http::CharsetToEncoding} { +test http-2.2 {http::CharsetToEncoding} http2.9.7 { http::CharsetToEncoding iso-8859-11 } iso8859-11 -test http-2.3 {http::CharsetToEncoding} { +test http-2.3 {http::CharsetToEncoding} http2.9.7 { http::CharsetToEncoding iso-2022-kr } iso2022-kr -test http-2.4 {http::CharsetToEncoding} { +test http-2.4 {http::CharsetToEncoding} http2.9.7 { http::CharsetToEncoding shift-jis } shiftjis -test http-2.5 {http::CharsetToEncoding} { +test http-2.5 {http::CharsetToEncoding} http2.9.7 { http::CharsetToEncoding windows-437 } cp437 -test http-2.6 {http::CharsetToEncoding} { +test http-2.6 {http::CharsetToEncoding} http2.9.7 { http::CharsetToEncoding latin5 } iso8859-9 -test http-2.7 {http::CharsetToEncoding} { +test http-2.7 {http::CharsetToEncoding} http2.9.7 { http::CharsetToEncoding latin1 } iso8859-1 -test http-2.8 {http::CharsetToEncoding} { +test http-2.8 {http::CharsetToEncoding} http2.9.7 { http::CharsetToEncoding latin4 } binary @@ -468,12 +470,14 @@ test http-3.33 {http::geturl application/xml is text} -body { } -cleanup { catch { http::cleanup $token } } -result {test 4660 /test} + + test http-3.34 {http::geturl -headers not a list} -returnCodes error -body { http::geturl http://test/t -headers \" -} -result {Bad value for -headers ("), must be list} +} -constraints http2.9.8 -result {Bad value for -headers ("), must be list} test http-3.35 {http::geturl -headers not even number of elements} -returnCodes error -body { http::geturl http://test/t -headers {List Length 3} -} -result {Bad value for -headers (List Length 3), number of list elements must be even} +} -constraints http2.9.8 -result {Bad value for -headers (List Length 3), number of list elements must be even} test http-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] -- cgit v0.12 From 0666836834ee47bf27a03d10a7228593d57c43b2 Mon Sep 17 00:00:00 2001 From: dgp Date: Sun, 20 Nov 2022 15:34:08 +0000 Subject: bump release date --- changes | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changes b/changes index d75258c..74e3cc0 100644 --- a/changes +++ b/changes @@ -9166,4 +9166,4 @@ Update bundled libtommath Many code fixes to avoid overflow or undefined behavior. Thanks chrstphrchvz. -- Released 8.6.13, Nov 16, 2022 - details at https://core.tcl-lang.org/tcl/ - +- Released 8.6.13, Nov 22, 2022 - details at https://core.tcl-lang.org/tcl/ - -- cgit v0.12 From b71ebc2746c2c92514bfd0dd8b9ad48019ac2e16 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 20 Nov 2022 19:29:53 +0000 Subject: Constraints http2.9.x make no sense, when testing http2.10 --- tests/http.test | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/tests/http.test b/tests/http.test index 46242bd..08195a6 100644 --- a/tests/http.test +++ b/tests/http.test @@ -15,11 +15,9 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } -source [file join [file dirname [info script]] tcltests.tcl] +package require tcltests package require http 2.10 -testConstraint http2.9.7 [package vsatisfies [package provide http] 2.9.7] -testConstraint http2.9.8 [package vsatisfies [package provide http] 2.9.8] proc bgerror {args} { global errorInfo @@ -128,25 +126,25 @@ test http-1.6.$ThreadLevel {http::config} -setup { test http-2.1.$ThreadLevel {http::reset} { catch {http::reset http#1} } 0 -test http-2.2.$ThreadLevel {http::CharsetToEncoding} http2.9.7 { +test http-2.2.$ThreadLevel {http::CharsetToEncoding} { http::CharsetToEncoding iso-8859-11 } iso8859-11 -test http-2.3.$ThreadLevel {http::CharsetToEncoding} http2.9.7 { +test http-2.3.$ThreadLevel {http::CharsetToEncoding} { http::CharsetToEncoding iso-2022-kr } iso2022-kr -test http-2.4.$ThreadLevel {http::CharsetToEncoding} http2.9.7 { +test http-2.4.$ThreadLevel {http::CharsetToEncoding} { http::CharsetToEncoding shift-jis } shiftjis -test http-2.5.$ThreadLevel {http::CharsetToEncoding} http2.9.7 { +test http-2.5.$ThreadLevel {http::CharsetToEncoding} { http::CharsetToEncoding windows-437 } cp437 -test http-2.6.$ThreadLevel {http::CharsetToEncoding} http2.9.7 { +test http-2.6.$ThreadLevel {http::CharsetToEncoding} { http::CharsetToEncoding latin5 } iso8859-9 -test http-2.7.$ThreadLevel {http::CharsetToEncoding} http2.9.7 { +test http-2.7.$ThreadLevel {http::CharsetToEncoding} { http::CharsetToEncoding latin1 } iso8859-1 -test http-2.8.$ThreadLevel {http::CharsetToEncoding} http2.9.7 { +test http-2.8.$ThreadLevel {http::CharsetToEncoding} { http::CharsetToEncoding latin4 } binary @@ -483,10 +481,10 @@ test http-3.33.$ThreadLevel {http::geturl application/xml is text} -body { } -result {test 4660 /test} test http-3.34.$ThreadLevel {http::geturl -headers not a list} -returnCodes error -body { http::geturl http://test/t -headers \" -} -constraints http2.9.8 -result {Bad value for -headers ("), must be list} +} -result {Bad value for -headers ("), must be list} test http-3.35.$ThreadLevel {http::geturl -headers not even number of elements} -returnCodes error -body { http::geturl http://test/t -headers {List Length 3} -} -constraints http2.9.8 -result {Bad value for -headers (List Length 3), number of list elements must be even} +} -result {Bad value for -headers (List Length 3), number of list elements must be even} test http-4.1.$ThreadLevel {http::Event} -body { set token [http::geturl $url -keepalive 0] -- cgit v0.12 From bfdd211de9210e8b9cf5af6cf3aa03a4698ef0ee Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 20 Nov 2022 19:33:00 +0000 Subject: Don't use "package require tcltests" any more, as in other tests --- tests/http.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/http.test b/tests/http.test index 08195a6..587e6e4 100644 --- a/tests/http.test +++ b/tests/http.test @@ -15,7 +15,7 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } -package require tcltests +source [file join [file dirname [info script]] tcltests.tcl] package require http 2.10 -- cgit v0.12 From 8f9ddfae668df094f955bb9763bbf7569be015ca Mon Sep 17 00:00:00 2001 From: dgp Date: Sun, 20 Nov 2022 21:39:43 +0000 Subject: missing constraints --- tests/listRep.test | 72 +++++++++++++++++++++++++++--------------------------- 1 file changed, 36 insertions(+), 36 deletions(-) diff --git a/tests/listRep.test b/tests/listRep.test index 7883a21..02ff18f 100644 --- a/tests/listRep.test +++ b/tests/listRep.test @@ -472,7 +472,7 @@ test listrep-1.10.1 { test listrep-1.11 { Append elements to large unshared list is optimized as lappend so no free space in front - lreplace version -} -body { +} -constraints testlistrep -body { # Note $end, not end else byte code compiler short-cuts set l [lreplace [freeSpaceNone 1000] $end+1 $end+1 1000] validate $l @@ -482,7 +482,7 @@ test listrep-1.11 { test listrep-1.11.1 { Append elements to large unshared list is optimized as lappend so no free space in front - linsert version -} -body { +} -constraints testlistrep -body { # Note $end, not end else byte code compiler short-cuts set l [linsert [freeSpaceNone 1000] $end+1 1000] validate $l @@ -492,7 +492,7 @@ test listrep-1.11.1 { test listrep-1.11.2 { Append elements to large unshared list leaves no free space in front - lappend version -} -body { +} -constraints testlistrep -body { # Note $end, not end else byte code compiler short-cuts set l [freeSpaceNone 1000] lappend l 1000 1001 @@ -504,7 +504,7 @@ test listrep-1.11.2 { test listrep-1.12 { Replacement of elements at front with same number elements in unshared list is in-place - lreplace version -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceNone] $zero $one 10 11] validate $l list $l [leadSpace $l] [tailSpace $l] @@ -513,7 +513,7 @@ test listrep-1.12 { test listrep-1.12.1 { Replacement of elements at front with same number elements in unshared list is in-place - lset version -} -body { +} -constraints testlistrep -body { set l [freeSpaceNone] lset l 0 -1 validate $l @@ -523,7 +523,7 @@ test listrep-1.12.1 { test listrep-1.13 { Replacement of elements at front with fewer elements in unshared list results in a spanned list with space only in front -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceNone] $zero $four 10] validate $l list $l [leadSpace $l] [tailSpace $l] @@ -532,7 +532,7 @@ test listrep-1.13 { test listrep-1.14 { Replacement of elements at front with more elements in unshared list results in a reallocated spanned list with space at front and back -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceNone] $zero $one 10 11 12] validate $l list $l [spaceEqual $l] @@ -541,7 +541,7 @@ test listrep-1.14 { test listrep-1.15 { Replacement of elements in middle with same number elements in unshared list is in-place - lreplace version -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceNone] $one $two 10 11] validate $l list $l [leadSpace $l] [tailSpace $l] @@ -550,7 +550,7 @@ test listrep-1.15 { test listrep-1.15.1 { Replacement of elements in middle with same number elements in unshared list is in-place - lset version -} -body { +} -constraints testlistrep -body { set l [freeSpaceNone] lset l $two -1 validate $l @@ -560,7 +560,7 @@ test listrep-1.15.1 { test listrep-1.16 { Replacement of elements in front half with fewer elements in unshared list results in a spanned list with space only in front since smaller segment moved -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceNone] $one $four 10] validate $l list $l [leadSpace $l] [tailSpace $l] @@ -569,7 +569,7 @@ test listrep-1.16 { test listrep-1.17 { Replacement of elements in back half with fewer elements in unshared list results in a spanned list with space only at back -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceNone] end-$four end-$one 10] validate $l list $l [leadSpace $l] [tailSpace $l] @@ -578,7 +578,7 @@ test listrep-1.17 { test listrep-1.18 { Replacement of elements in middle more elements in unshared list results in a reallocated spanned list with space at front and back -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceNone] $one $two 10 11 12] validate $l list $l [spaceEqual $l] @@ -587,7 +587,7 @@ test listrep-1.18 { test listrep-1.19 { Replacement of elements at back with same number elements in unshared list is in-place - lreplace version -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceNone] $end-1 $end 10 11] validate $l list $l [leadSpace $l] [tailSpace $l] @@ -596,7 +596,7 @@ test listrep-1.19 { test listrep-1.19.1 { Replacement of elements at back with same number elements in unshared list is in-place - lset version -} -body { +} -constraints testlistrep -body { set l [freeSpaceNone] lset l $end 10 validate $l @@ -606,7 +606,7 @@ test listrep-1.19.1 { test listrep-1.20 { Replacement of elements at back with fewer elements in unshared list is in-place with space only at the back -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceNone] $end-2 $end 10] validate $l list $l [leadSpace $l] [tailSpace $l] @@ -615,7 +615,7 @@ test listrep-1.20 { test listrep-1.21 { Replacement of elements at back with more elements in unshared list allocates new representation with equal space at front and back -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceNone] $end-1 $end 10 11 12] validate $l list $l [spaceEqual $l] @@ -1667,7 +1667,7 @@ test listrep-3.22.1 { test listrep-3.23 { Replacement of elements at front with same number elements in unshared spanned list is in-place - lreplace version -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceBoth] $zero $one 10 11] list $l [leadSpace $l] [tailSpace $l] } -result [list {10 11 2 3 4 5 6 7} 3 3] @@ -1675,7 +1675,7 @@ test listrep-3.23 { test listrep-3.23.1 { Replacement of elements at front with same number elements in unshared spanned list is in-place - lset version -} -body { +} -constraints testlistrep -body { set l [freeSpaceBoth] lset l $zero 10 list $l [leadSpace $l] [tailSpace $l] @@ -1684,7 +1684,7 @@ test listrep-3.23.1 { test listrep-3.24 { Replacement of elements at front with fewer elements in unshared spanned list expands leading space - lreplace version -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceBoth] $zero $four 10] list $l [leadSpace $l] [tailSpace $l] } -result [list {10 5 6 7} 7 3] @@ -1692,7 +1692,7 @@ test listrep-3.24 { test listrep-3.25 { Replacement of elements at front with more elements in unshared spanned list with sufficient leading space shrinks leading space -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceBoth] $zero $one 10 11 12] list $l [leadSpace $l] [tailSpace $l] } -result [list {10 11 12 2 3 4 5 6 7} 2 3] @@ -1719,7 +1719,7 @@ test listrep-3.27 { test listrep-3.28 { Replacement of elements at back with same number of elements in unshared spanned list is in-place - lreplace version -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceBoth] $end-1 $end 10 11] validate $l list $l [leadSpace $l] [tailSpace $l] @@ -1728,7 +1728,7 @@ test listrep-3.28 { test listrep-3.28.1 { Replacement of elements at back with same number of elements in unshared spanned list is in-place - lset version -} -body { +} -constraints testlistrep -body { set l [freeSpaceBoth] lset l $end 10 validate $l @@ -1738,7 +1738,7 @@ test listrep-3.28.1 { test listrep-3.29 { Replacement of elements at back with fewer elements in unshared spanned list expands tail space -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceBoth] $end-2 $end 10] validate $l list $l [leadSpace $l] [tailSpace $l] @@ -1747,7 +1747,7 @@ test listrep-3.29 { test listrep-3.30 { Replacement of elements at back with more elements in unshared spanned list with sufficient tail space shrinks tailspace -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceBoth] $end-1 $end 10 11 12] validate $l list $l [leadSpace $l] [tailSpace $l] @@ -1756,7 +1756,7 @@ test listrep-3.30 { test listrep-3.31 { Replacement of elements at back with more elements in unshared spanned list with insufficient tail space but enough total free space moves up the span -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceBoth 8 2 2] $end-1 $end 10 11 12 13 14] validate $l list $l [leadSpace $l] [tailSpace $l] @@ -1766,7 +1766,7 @@ test listrep-3.32 { Replacement of elements at back with more elements in unshared spanned list with insufficient total space reallocates with more room in the tail because of realloc() -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceBoth 8 1 1] $end-1 $end 10 11 12 13 14] validate $l list $l [leadSpace $l] [tailSpace $l] @@ -1775,7 +1775,7 @@ test listrep-3.32 { test listrep-3.33 { Replacement of elements in the middle in an unshared spanned list with the same number of elements - lreplace version -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceBoth] $two $four 10 11 12] validate $l list $l [leadSpace $l] [tailSpace $l] @@ -1784,7 +1784,7 @@ test listrep-3.33 { test listrep-3.33.1 { Replacement of elements in the middle in an unshared spanned list with the same number of elements - lset version -} -body { +} -constraints testlistrep -body { set l [freeSpaceBoth] lset l $two 10 validate $l @@ -1794,7 +1794,7 @@ test listrep-3.33.1 { test listrep-3.34 { Replacement of elements in an unshared spanned list with fewer elements in the front half moves the front (smaller) segment -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceBoth] $two $four 10 11] validate $l list $l [leadSpace $l] [tailSpace $l] @@ -1803,7 +1803,7 @@ test listrep-3.34 { test listrep-3.35 { Replacement of elements in an unshared spanned list with fewer elements in the back half moves the tail (smaller) segment -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceBoth] $end-2 $end-1 10] validate $l list $l [leadSpace $l] [tailSpace $l] @@ -1813,7 +1813,7 @@ test listrep-3.36 { Replacement of elements in an unshared spanned list with more elements when both front and back have room should move the smaller segment (front case) -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceBoth] $one $two 8 9 10] validate $l list $l [leadSpace $l] [tailSpace $l] @@ -1823,7 +1823,7 @@ test listrep-3.37 { Replacement of elements in an unshared spanned list with more elements when both front and back have room should move the smaller segment (back case) -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceBoth] $end-2 $end-1 8 9 10] validate $l list $l [leadSpace $l] [tailSpace $l] @@ -1832,7 +1832,7 @@ test listrep-3.37 { test listrep-3.38 { Replacement of elements in an unshared spanned list with more elements when only front has room -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceBoth 8 3 1] $end-1 $end-1 8 9 10] validate $l list $l [leadSpace $l] [tailSpace $l] @@ -1841,7 +1841,7 @@ test listrep-3.38 { test listrep-3.39 { Replacement of elements in an unshared spanned list with more elements when only back has room -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceBoth 8 1 3] $one $one 8 9 10] validate $l list $l [leadSpace $l] [tailSpace $l] @@ -1850,7 +1850,7 @@ test listrep-3.39 { test listrep-3.40 { Replacement of elements in an unshared spanned list with more elements when neither send has enough room by itself -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceBoth] $one $one 8 9 10 11 12] validate $l list $l [leadSpace $l] [tailSpace $l] @@ -1860,7 +1860,7 @@ test listrep-3.41 { Replacement of elements in an unshared spanned list with more elements when there is not enough free space results in new allocation. The back end has more space because of realloc() -} -body { +} -constraints testlistrep -body { set l [lreplace [freeSpaceBoth 8 1 1] $one $one 8 9 10 11 12] validate $l list $l [leadSpace $l] [tailSpace $l] -- cgit v0.12 From 49cb764a5a3c9a06ea2bebcbe8d7f46cca7472f5 Mon Sep 17 00:00:00 2001 From: dgp Date: Sun, 20 Nov 2022 22:08:19 +0000 Subject: In most testing scenarios, the TCL_LIBRARY variable is masking a bug in system encoding discovery. Adapted test unixInit-3.2 to stop shielding this problem from view. --- tests/unixInit.test | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/unixInit.test b/tests/unixInit.test index 2ea7d8e..69c3eac 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.test @@ -346,6 +346,8 @@ test unixInit-3.1 {TclpSetInitialEncodings} -constraints { } -match regexp -result {^(iso8859-15?|utf-8)$} test unixInit-3.2 {TclpSetInitialEncodings} -setup { catch {set oldlc_all $env(LC_ALL)} + catch {set oldtcl_library $env(TCL_LIBRARY)} + unset -nocomplain env(TCL_LIBRARY) } -constraints {unix stdio} -body { set env(LANG) japanese set env(LC_ALL) japanese @@ -364,6 +366,7 @@ test unixInit-3.2 {TclpSetInitialEncodings} -setup { } -cleanup { unset -nocomplain env(LANG) env(LC_ALL) catch {set env(LC_ALL) $oldlc_all} + catch {set env(TCL_LIBRARY) $oldtcl_library} } -result 0 test unixInit-4.1 {TclpSetVariables} {unix} { -- cgit v0.12 From 91e64fb4758b08118646d3a4cb707a9288e920f3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 20 Nov 2022 23:27:09 +0000 Subject: indenting --- generic/tclIO.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 6b9b48d..d5fbd18 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -5518,8 +5518,8 @@ FilterInputBytes( &gsPtr->bytesWrote, &gsPtr->charsWrote); if (result == TCL_CONVERT_UNKNOWN || result == TCL_CONVERT_SYNTAX) { - SetFlag(statePtr, CHANNEL_ENCODING_ERROR); - result = TCL_OK; + SetFlag(statePtr, CHANNEL_ENCODING_ERROR); + result = TCL_OK; } /* @@ -6351,7 +6351,7 @@ ReadChars( dst, dstLimit, &srcRead, &dstDecoded, &numChars); if (code == TCL_CONVERT_UNKNOWN || code == TCL_CONVERT_SYNTAX) { - SetFlag(statePtr, CHANNEL_ENCODING_ERROR); + SetFlag(statePtr, CHANNEL_ENCODING_ERROR); code = TCL_OK; } -- cgit v0.12 From 23ef10a6a40fd66b675102e65fe948610b8fe224 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 21 Nov 2022 16:18:56 +0000 Subject: There is no guarantee that sizeof(Tcl_WideInt) == sizeof(double), so the offset of 'isDouble' in the struct could vary between ArithSeries and ArithSeriesDbl. Solution: put those fields last --- generic/tclArithSeries.h | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h index af4777c..f7f2fa8 100644 --- a/generic/tclArithSeries.h +++ b/generic/tclArithSeries.h @@ -16,20 +16,20 @@ * but it's faster to cache it inside the internal representation. */ typedef struct ArithSeries { + Tcl_WideInt len; + Tcl_Obj **elements; + int isDouble; Tcl_WideInt start; Tcl_WideInt end; Tcl_WideInt step; +} ArithSeries; +typedef struct ArithSeriesDbl { Tcl_WideInt len; Tcl_Obj **elements; int isDouble; -} ArithSeries; -typedef struct ArithSeriesDbl { double start; double end; double step; - Tcl_WideInt len; - Tcl_Obj **elements; - int isDouble; } ArithSeriesDbl; -- cgit v0.12 From 338c6692672696a76b6cb4073820426406c6f3f9 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 21 Nov 2022 17:37:38 +0000 Subject: improve accuracy of a changes line --- changes | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/changes b/changes index 74e3cc0..f3d0120 100644 --- a/changes +++ b/changes @@ -9132,7 +9132,7 @@ See RFC 2045 2022-04-26 (bug)[27520c] test error-9.6 (goth,sebres) -2022-05-04 (bug)[8eb64b] http package support for Content-encoding: br +2022-05-04 (bug)[8eb64b] http package tolerant again invalid reply header 2022-05-11 (bug)[6898f9] http package failed detection of shiftjis charset -- cgit v0.12 From 0fd21c5dd08de33ecb24bef9bcf700a40b3d2db3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 21 Nov 2022 23:22:03 +0000 Subject: TCL_OUT_LINE_COMPILE is deprecated --- generic/tclInt.h | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 8c5d1da..31c7fcb 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1428,7 +1428,9 @@ struct CompileEnv; * sake of old code only. */ -#define TCL_OUT_LINE_COMPILE TCL_ERROR +#ifndef TCL_NO_DEPRECATED +# define TCL_OUT_LINE_COMPILE TCL_ERROR +#endif typedef int (CompileProc)(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct Command *cmdPtr, struct CompileEnv *compEnvPtr); -- cgit v0.12 From b1432e6e0d74f34378a92c4768734ec92c9b6b23 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 21 Nov 2022 23:52:36 +0000 Subject: Mark unixInit-3.2 as "knownBug". See [fccb9f322f] --- tests/unixInit.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/unixInit.test b/tests/unixInit.test index 69c3eac..8e64c7a 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.test @@ -348,7 +348,7 @@ test unixInit-3.2 {TclpSetInitialEncodings} -setup { catch {set oldlc_all $env(LC_ALL)} catch {set oldtcl_library $env(TCL_LIBRARY)} unset -nocomplain env(TCL_LIBRARY) -} -constraints {unix stdio} -body { +} -constraints {unix stdio knownBug} -body { set env(LANG) japanese set env(LC_ALL) japanese set f [open "|[list [interpreter]]" w+] -- cgit v0.12 From eddb2b2801aceda76f3fef6cbcd93c2b1241f165 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 22 Nov 2022 20:08:07 +0000 Subject: Unused stub entries up to Tcl_DStringToObj() (for Tcl 8.7/9.0) --- generic/tcl.decls | 4 +++- generic/tclDecls.h | 18 +++++++++++++++--- generic/tclStubInit.c | 6 +++++- 3 files changed, 23 insertions(+), 5 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index a933d95..379280a 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2112,10 +2112,12 @@ declare 579 { # ----- BASELINE -- FOR -- 8.5.0 ----- # -declare 683 { +declare 687 { void TclUnusedStubEntry(void) } +# ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- # + ############################################################################## # Define the platform specific public Tcl interface. These functions are only diff --git a/generic/tclDecls.h b/generic/tclDecls.h index d8ec374..66b4782 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -3515,9 +3515,13 @@ EXTERN void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, /* Slot 680 is reserved */ /* Slot 681 is reserved */ /* Slot 682 is reserved */ +/* Slot 683 is reserved */ +/* Slot 684 is reserved */ +/* Slot 685 is reserved */ +/* Slot 686 is reserved */ #ifndef TclUnusedStubEntry_TCL_DECLARED #define TclUnusedStubEntry_TCL_DECLARED -/* 683 */ +/* 687 */ EXTERN void TclUnusedStubEntry(void); #endif @@ -4238,7 +4242,11 @@ typedef struct TclStubs { VOID *reserved680; VOID *reserved681; VOID *reserved682; - void (*tclUnusedStubEntry) (void); /* 683 */ + VOID *reserved683; + VOID *reserved684; + VOID *reserved685; + VOID *reserved686; + void (*tclUnusedStubEntry) (void); /* 687 */ } TclStubs; extern TclStubs *tclStubsPtr; @@ -6694,9 +6702,13 @@ extern TclStubs *tclStubsPtr; /* Slot 680 is reserved */ /* Slot 681 is reserved */ /* Slot 682 is reserved */ +/* Slot 683 is reserved */ +/* Slot 684 is reserved */ +/* Slot 685 is reserved */ +/* Slot 686 is reserved */ #ifndef TclUnusedStubEntry #define TclUnusedStubEntry \ - (tclStubsPtr->tclUnusedStubEntry) /* 683 */ + (tclStubsPtr->tclUnusedStubEntry) /* 687 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 9502ba2..4d0e10a 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1484,7 +1484,11 @@ TclStubs tclStubs = { NULL, /* 680 */ NULL, /* 681 */ NULL, /* 682 */ - TclUnusedStubEntry, /* 683 */ + NULL, /* 683 */ + NULL, /* 684 */ + NULL, /* 685 */ + NULL, /* 686 */ + TclUnusedStubEntry, /* 687 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From d942525e228c522b5f0101ced6a494e80c2cd06d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 22 Nov 2022 22:25:46 +0000 Subject: Better -strict checking, with testcases --- generic/tclEncoding.c | 4 ++-- tests/encoding.test | 17 ++++++++++------- tests/io.test | 21 +++++++++++++++++++-- 3 files changed, 31 insertions(+), 11 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 1df5e93..eb217b4 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2428,8 +2428,8 @@ UtfToUtfProc( int low; const char *saveSrc = src; size_t len = TclUtfToUCS4(src, &ch); - if ((len < 2) && (ch != 0) && STOPONERROR - && (flags & TCL_ENCODING_MODIFIED)) { + if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_MODIFIED) + && (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT))) { result = TCL_CONVERT_SYNTAX; break; } diff --git a/tests/encoding.test b/tests/encoding.test index b4f35db..9aa123d 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -674,16 +674,19 @@ test encoding-24.23 {Syntax error, two encodings} -body { encoding convertto iso8859-1 utf-8 "ZX\uD800" } -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} test encoding-24.24 {Parse invalid utf-8 with -strict} -body { - encoding convertfrom -strict utf-8 "\xC0\x80" + encoding convertfrom -strict utf-8 "\xC0\x80\x00\x00" } -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'} test encoding-24.25 {Parse invalid utf-8 with -strict} -body { - encoding convertfrom -strict utf-8 "\x80" -} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\x80'} -test encoding-24.26 {Parse invalid utf-8 with -strict} -body { - encoding convertfrom -strict utf-8 "\xF0" -} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xF0'} + encoding convertfrom -strict utf-8 "\x40\x80\x00\x00" +} -returnCodes 1 -result {unexpected byte sequence starting at index 1: '\x80'} +test encoding-24.26 {Parse valid utf-8 with -strict} -body { + encoding convertfrom -strict utf-8 "\xF1\x80\x80\x80" +} -result \U40000 test encoding-24.27 {Parse invalid utf-8 with -strict} -body { - encoding convertfrom -strict utf-8 "\xFF" + encoding convertfrom -strict utf-8 "\xF0\x80\x80\x80" +} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xF0'} +test encoding-24.28 {Parse invalid utf-8 with -strict} -body { + encoding convertfrom -strict utf-8 "\xFF\x00\x00" } -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xFF'} file delete [file join [temporaryDirectory] iso2022.txt] diff --git a/tests/io.test b/tests/io.test index 9ae25bb..ef9e14d 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9029,11 +9029,10 @@ test io-75.4 {shiftjis encoding error read results in raw bytes} -setup { removeFile io-75.4 } -result "4181ff41" -test io-75.5 {incomplete shiftjis encoding read is ignored} -setup { +test io-75.5 {invalid utf-8 encoding read is ignored} -setup { set fn [makeFile {} io-75.5] set f [open $fn w+] fconfigure $f -encoding binary - # \x81 announces a two byte sequence. puts -nonewline $f "A\x81" flush $f seek $f 0 @@ -9047,6 +9046,24 @@ test io-75.5 {incomplete shiftjis encoding read is ignored} -setup { removeFile io-75.5 } -result "4181" +test io-75.6 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} -setup { + set fn [makeFile {} io-75.6] + set f [open $fn w+] + fconfigure $f -encoding binary + # \x81 is invalid in utf-8 + puts -nonewline $f "A\x81" + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -strictencoding 1 +} -body { + set d [read $f] + binary scan $d H* hd + lappend hd [catch {read $f} msg] + close $f + lappend hd $msg +} -cleanup { + removeFile io-75.6 +} -result "41 0 {}" ; # Here, an exception should be thrown # ### ### ### ######### ######### ######### -- cgit v0.12 From 13eb211d5add69c9c05892fd9dff2dc5aa7dbaf0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Nov 2022 00:19:46 +0000 Subject: leave unixInit-3.2 as-is --- tests/unixInit.test | 3 +++ 1 file changed, 3 insertions(+) diff --git a/tests/unixInit.test b/tests/unixInit.test index 16d9e64..8e64c7a 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.test @@ -346,6 +346,8 @@ test unixInit-3.1 {TclpSetInitialEncodings} -constraints { } -match regexp -result {^(iso8859-15?|utf-8)$} test unixInit-3.2 {TclpSetInitialEncodings} -setup { catch {set oldlc_all $env(LC_ALL)} + catch {set oldtcl_library $env(TCL_LIBRARY)} + unset -nocomplain env(TCL_LIBRARY) } -constraints {unix stdio knownBug} -body { set env(LANG) japanese set env(LC_ALL) japanese @@ -364,6 +366,7 @@ test unixInit-3.2 {TclpSetInitialEncodings} -setup { } -cleanup { unset -nocomplain env(LANG) env(LC_ALL) catch {set env(LC_ALL) $oldlc_all} + catch {set env(TCL_LIBRARY) $oldtcl_library} } -result 0 test unixInit-4.1 {TclpSetVariables} {unix} { -- cgit v0.12 From 7129a50b10269174f1d8f247449abe6df0dc890a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Nov 2022 07:36:49 +0000 Subject: Re-generate configure scripts (with correct autoconf version) --- unix/configure | 1 + win/configure | 23 +++++++++++++---------- 2 files changed, 14 insertions(+), 10 deletions(-) diff --git a/unix/configure b/unix/configure index 57d5081..043da1c 100755 --- a/unix/configure +++ b/unix/configure @@ -2823,6 +2823,7 @@ cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include +#include #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) diff --git a/win/configure b/win/configure index 2765e6c..25bc18a 100755 --- a/win/configure +++ b/win/configure @@ -2729,6 +2729,7 @@ cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ #include +#include #if ((' ' & 0x0FF) == 0x020) # define ISLOWER(c) ('a' <= (c) && (c) <= 'z') # define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) @@ -3031,24 +3032,26 @@ fi echo "$as_me:$LINENO: checking whether ${MAKE-make} sets \$(MAKE)" >&5 echo $ECHO_N "checking whether ${MAKE-make} sets \$(MAKE)... $ECHO_C" >&6 -set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y,:./+-,___p_,'` +set x ${MAKE-make} +ac_make=`echo "" | sed 'y,:./+-,___p_,'` if eval "test \"\${ac_cv_prog_make_${ac_make}_set+set}\" = set"; then echo $ECHO_N "(cached) $ECHO_C" >&6 else cat >conftest.make <<\_ACEOF +SHELL = /bin/sh all: - @echo 'ac_maketemp="$(MAKE)"' + @echo '@@@%%%=$(MAKE)=@@@%%%' _ACEOF -# GNU make sometimes prints "make[1]: Entering...", which would confuse us. -eval `${MAKE-make} -f conftest.make 2>/dev/null | grep temp=` -if test -n "$ac_maketemp"; then - eval ac_cv_prog_make_${ac_make}_set=yes -else - eval ac_cv_prog_make_${ac_make}_set=no -fi +# GNU make sometimes prints "make[1]: Entering ...", which would confuse us. +case `${MAKE-make} -f conftest.make 2>/dev/null` in + *@@@%%%=?*=@@@%%%*) + eval ac_cv_prog_make_${ac_make}_set=yes;; + *) + eval ac_cv_prog_make_${ac_make}_set=no;; +esac rm -f conftest.make fi -if eval "test \"`echo '$ac_cv_prog_make_'${ac_make}_set`\" = yes"; then +if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then echo "$as_me:$LINENO: result: yes" >&5 echo "${ECHO_T}yes" >&6 SET_MAKE= -- cgit v0.12 From 86f51a0a0b0c3eb9945f12e6aa8972d3878c67ff Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Nov 2022 07:38:49 +0000 Subject: Add mp_pack, mp_pack_count and mp_unpack to the libtommath stub table. Not used by Tcl, but can be used by extensions (backported from 8.7) --- generic/tclStubInit.c | 6 +++--- generic/tclTomMath.decls | 11 +++++++++++ generic/tclTomMathDecls.h | 34 +++++++++++++++++++++++++--------- unix/Makefile.in | 30 ++++++++++++++++++------------ win/Makefile.in | 3 +++ win/makefile.vc | 3 +++ 6 files changed, 63 insertions(+), 24 deletions(-) diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 89a33e4..ee0412a 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -948,13 +948,13 @@ const TclTomMathStubs tclTomMathStubs = { TclBN_mp_set_ull, /* 68 */ TclBN_mp_get_mag_ull, /* 69 */ TclBN_mp_set_ll, /* 70 */ - 0, /* 71 */ - 0, /* 72 */ + TclBN_mp_unpack, /* 71 */ + TclBN_mp_pack, /* 72 */ TclBN_mp_tc_and, /* 73 */ TclBN_mp_tc_or, /* 74 */ TclBN_mp_tc_xor, /* 75 */ TclBN_mp_signed_rsh, /* 76 */ - 0, /* 77 */ + TclBN_mp_pack_count, /* 77 */ TclBN_mp_to_ubin, /* 78 */ TclBN_mp_div_ld, /* 79 */ TclBN_mp_to_radix, /* 80 */ diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls index 0aa9a42..27afefd 100644 --- a/generic/tclTomMath.decls +++ b/generic/tclTomMath.decls @@ -243,6 +243,14 @@ declare 69 { declare 70 { void TclBN_mp_set_ll(mp_int *a, Tcl_WideInt i) } +declare 71 { + mp_err TclBN_mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size, + mp_endian endian, size_t nails, const void *op) +} +declare 72 { + mp_err TclBN_mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order, + size_t size, mp_endian endian, size_t nails, const mp_int *op) +} # Added in libtommath 1.1.0 declare 73 { @@ -257,6 +265,9 @@ declare 75 { declare 76 { mp_err TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c) } +declare 77 { + size_t TclBN_mp_pack_count(const mp_int *a, size_t nails, size_t size) +} # Added in libtommath 1.2.0 declare 78 { diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index 6991643..e6f23aa 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -89,6 +89,8 @@ #define mp_mul_d TclBN_mp_mul_d #define mp_neg TclBN_mp_neg #define mp_or TclBN_mp_or +#define mp_pack TclBN_mp_pack +#define mp_pack_count TclBN_mp_pack_count #define mp_radix_size TclBN_mp_radix_size #define mp_read_radix TclBN_mp_read_radix #define mp_rshd TclBN_mp_rshd @@ -114,6 +116,7 @@ #define mp_toradix_n TclBN_mp_toradix_n #define mp_to_radix TclBN_mp_to_radix #define mp_to_ubin TclBN_mp_to_ubin +#define mp_unpack TclBN_mp_unpack #define mp_ubin_size TclBN_mp_unsigned_bin_size #define mp_unsigned_bin_size(a) ((int)TclBN_mp_unsigned_bin_size(a)) #define mp_xor TclBN_mp_xor @@ -329,8 +332,16 @@ EXTERN void TclBN_mp_set_ull(mp_int *a, Tcl_WideUInt i); EXTERN Tcl_WideUInt TclBN_mp_get_mag_ull(const mp_int *a); /* 70 */ EXTERN void TclBN_mp_set_ll(mp_int *a, Tcl_WideInt i); -/* Slot 71 is reserved */ -/* Slot 72 is reserved */ +/* 71 */ +EXTERN mp_err TclBN_mp_unpack(mp_int *rop, size_t count, + mp_order order, size_t size, + mp_endian endian, size_t nails, + const void *op); +/* 72 */ +EXTERN mp_err TclBN_mp_pack(void *rop, size_t maxcount, + size_t *written, mp_order order, size_t size, + mp_endian endian, size_t nails, + const mp_int *op); /* 73 */ EXTERN mp_err TclBN_mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c); @@ -343,7 +354,9 @@ EXTERN mp_err TclBN_mp_tc_xor(const mp_int *a, const mp_int *b, /* 76 */ EXTERN mp_err TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c); -/* Slot 77 is reserved */ +/* 77 */ +EXTERN size_t TclBN_mp_pack_count(const mp_int *a, size_t nails, + size_t size); /* 78 */ EXTERN int TclBN_mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written); @@ -429,13 +442,13 @@ typedef struct TclTomMathStubs { void (*tclBN_mp_set_ull) (mp_int *a, Tcl_WideUInt i); /* 68 */ Tcl_WideUInt (*tclBN_mp_get_mag_ull) (const mp_int *a); /* 69 */ void (*tclBN_mp_set_ll) (mp_int *a, Tcl_WideInt i); /* 70 */ - void (*reserved71)(void); - void (*reserved72)(void); + mp_err (*tclBN_mp_unpack) (mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian, size_t nails, const void *op); /* 71 */ + mp_err (*tclBN_mp_pack) (void *rop, size_t maxcount, size_t *written, mp_order order, size_t size, mp_endian endian, size_t nails, const mp_int *op); /* 72 */ mp_err (*tclBN_mp_tc_and) (const mp_int *a, const mp_int *b, mp_int *c); /* 73 */ mp_err (*tclBN_mp_tc_or) (const mp_int *a, const mp_int *b, mp_int *c); /* 74 */ mp_err (*tclBN_mp_tc_xor) (const mp_int *a, const mp_int *b, mp_int *c); /* 75 */ mp_err (*tclBN_mp_signed_rsh) (const mp_int *a, int b, mp_int *c); /* 76 */ - void (*reserved77)(void); + size_t (*tclBN_mp_pack_count) (const mp_int *a, size_t nails, size_t size); /* 77 */ int (*tclBN_mp_to_ubin) (const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written); /* 78 */ mp_err (*tclBN_mp_div_ld) (const mp_int *a, Tcl_WideUInt b, mp_int *q, Tcl_WideUInt *r); /* 79 */ int (*tclBN_mp_to_radix) (const mp_int *a, char *str, size_t maxlen, size_t *written, int radix); /* 80 */ @@ -595,8 +608,10 @@ extern const TclTomMathStubs *tclTomMathStubsPtr; (tclTomMathStubsPtr->tclBN_mp_get_mag_ull) /* 69 */ #define TclBN_mp_set_ll \ (tclTomMathStubsPtr->tclBN_mp_set_ll) /* 70 */ -/* Slot 71 is reserved */ -/* Slot 72 is reserved */ +#define TclBN_mp_unpack \ + (tclTomMathStubsPtr->tclBN_mp_unpack) /* 71 */ +#define TclBN_mp_pack \ + (tclTomMathStubsPtr->tclBN_mp_pack) /* 72 */ #define TclBN_mp_tc_and \ (tclTomMathStubsPtr->tclBN_mp_tc_and) /* 73 */ #define TclBN_mp_tc_or \ @@ -605,7 +620,8 @@ extern const TclTomMathStubs *tclTomMathStubsPtr; (tclTomMathStubsPtr->tclBN_mp_tc_xor) /* 75 */ #define TclBN_mp_signed_rsh \ (tclTomMathStubsPtr->tclBN_mp_signed_rsh) /* 76 */ -/* Slot 77 is reserved */ +#define TclBN_mp_pack_count \ + (tclTomMathStubsPtr->tclBN_mp_pack_count) /* 77 */ #define TclBN_mp_to_ubin \ (tclTomMathStubsPtr->tclBN_mp_to_ubin) /* 78 */ #define TclBN_mp_div_ld \ diff --git a/unix/Makefile.in b/unix/Makefile.in index 0a99998..eac47a6 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -332,13 +332,12 @@ TOMMATH_OBJS = bn_s_mp_reverse.o bn_s_mp_mul_digs_fast.o \ bn_mp_init_size.o bn_s_mp_karatsuba_mul.o \ bn_s_mp_karatsuba_sqr.o bn_s_mp_balance_mul.o \ bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mul.o bn_mp_mul_2.o \ - bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_neg.o bn_mp_or.o \ - bn_mp_radix_size.o bn_mp_radix_smap.o \ - bn_mp_read_radix.o bn_mp_rshd.o bn_mp_set.o \ - bn_mp_shrink.o \ + bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_neg.o bn_mp_or.o bn_mp_pack.o \ + bn_mp_pack_count.o bn_mp_radix_size.o bn_mp_radix_smap.o \ + bn_mp_read_radix.o bn_mp_rshd.o bn_mp_shrink.o \ + bn_mp_set.o \ bn_mp_sqr.o bn_mp_sqrt.o bn_mp_sub.o bn_mp_sub_d.o \ - bn_mp_signed_rsh.o \ - bn_mp_to_ubin.o \ + bn_mp_signed_rsh.o bn_mp_to_ubin.o bn_mp_unpack.o \ bn_s_mp_toom_mul.o bn_s_mp_toom_sqr.o bn_mp_to_radix.o \ bn_mp_ubin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \ bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o @@ -1573,6 +1572,12 @@ bn_mp_neg.o: $(TOMMATH_DIR)/bn_mp_neg.c $(MATHHDRS) bn_mp_or.o: $(TOMMATH_DIR)/bn_mp_or.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_or.c +bn_mp_pack.o: $(TOMMATH_DIR)/bn_mp_pack.c $(MATHHDRS) + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_pack.c + +bn_mp_pack_count.o: $(TOMMATH_DIR)/bn_mp_pack_count.c $(MATHHDRS) + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_pack_count.c + bn_mp_radix_size.o: $(TOMMATH_DIR)/bn_mp_radix_size.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_radix_size.c @@ -1621,6 +1626,9 @@ bn_mp_to_radix.o: $(TOMMATH_DIR)/bn_mp_to_radix.c $(MATHHDRS) bn_mp_ubin_size.o: $(TOMMATH_DIR)/bn_mp_ubin_size.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_ubin_size.c +bn_mp_unpack.o: $(TOMMATH_DIR)/bn_mp_unpack.c $(MATHHDRS) + $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_unpack.c + bn_mp_xor.o: $(TOMMATH_DIR)/bn_mp_xor.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_xor.c @@ -2100,8 +2108,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in gen @mkdir $(DISTDIR)/library/msgs cp -p $(TOP_DIR)/library/msgs/*.msg $(DISTDIR)/library/msgs @echo cp -r $(TOP_DIR)/library/tzdata $(DISTDIR)/library/tzdata - @( cd $(TOP_DIR); \ - find library/tzdata -name CVS -prune -o -type f -print ) \ + @( cd $(TOP_DIR); find library/tzdata -type f -print ) \ | ( cd $(TOP_DIR) ; xargs tar cf - ) \ | ( cd $(DISTDIR) ; tar xfp - ) @mkdir $(DISTDIR)/doc @@ -2112,10 +2119,11 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in gen $(COMPAT_DIR)/README $(DISTDIR)/compat @mkdir $(DISTDIR)/compat/zlib @echo cp -r $(COMPAT_DIR)/zlib $(DISTDIR)/compat/zlib - @( cd $(COMPAT_DIR)/zlib; \ - find . -name CVS -prune -o -type f -print ) \ + @( cd $(COMPAT_DIR)/zlib; find . -type f -print ) \ | ( cd $(COMPAT_DIR)/zlib ; xargs tar cf - ) \ | ( cd $(DISTDIR)/compat/zlib ; tar xfp - ) + @mkdir $(DISTDIR)/libtommath + cp -p $(TOMMATH_SRCS) $(TOMMATH_DIR)/*.h $(DISTDIR)/libtommath @mkdir $(DISTDIR)/tests cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \ @@ -2175,8 +2183,6 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in gen $(TOOL_DIR)/*.tcl $(TOOL_DIR)/man2tcl.c \ $(TOOL_DIR)/*.bmp $(TOOL_DIR)/tcl.hpj.in \ $(DISTDIR)/tools - @mkdir $(DISTDIR)/libtommath - cp -p $(TOMMATH_SRCS) $(TOMMATH_DIR)/*.h $(DISTDIR)/libtommath @mkdir $(DISTDIR)/pkgs cp -p $(TOP_DIR)/pkgs/README $(DISTDIR)/pkgs cp -p $(TOP_DIR)/pkgs/package.list.txt $(DISTDIR)/pkgs diff --git a/win/Makefile.in b/win/Makefile.in index 7d444a7..33a1e2c 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -350,6 +350,8 @@ TOMMATH_OBJS = \ bn_mp_mul_d.${OBJEXT} \ bn_mp_neg.${OBJEXT} \ bn_mp_or.${OBJEXT} \ + bn_mp_pack.${OBJEXT} \ + bn_mp_pack_count.${OBJEXT} \ bn_mp_radix_size.${OBJEXT} \ bn_mp_radix_smap.${OBJEXT} \ bn_mp_read_radix.${OBJEXT} \ @@ -364,6 +366,7 @@ TOMMATH_OBJS = \ bn_mp_to_ubin.${OBJEXT} \ bn_mp_to_radix.${OBJEXT} \ bn_mp_ubin_size.${OBJEXT} \ + bn_mp_unpack.${OBJEXT} \ bn_mp_xor.${OBJEXT} \ bn_mp_zero.${OBJEXT} \ bn_s_mp_add.${OBJEXT} \ diff --git a/win/makefile.vc b/win/makefile.vc index 011546a..aa5dd54 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -355,6 +355,8 @@ TOMMATHOBJS = \ $(TMP_DIR)\bn_mp_mul_d.obj \ $(TMP_DIR)\bn_mp_neg.obj \ $(TMP_DIR)\bn_mp_or.obj \ + $(TMP_DIR)\bn_mp_pack.obj \ + $(TMP_DIR)\bn_mp_pack_count.obj \ $(TMP_DIR)\bn_mp_radix_size.obj \ $(TMP_DIR)\bn_mp_radix_smap.obj \ $(TMP_DIR)\bn_mp_read_radix.obj \ @@ -369,6 +371,7 @@ TOMMATHOBJS = \ $(TMP_DIR)\bn_mp_to_ubin.obj \ $(TMP_DIR)\bn_mp_to_radix.obj \ $(TMP_DIR)\bn_mp_ubin_size.obj \ + $(TMP_DIR)\bn_mp_unpack.obj \ $(TMP_DIR)\bn_mp_xor.obj \ $(TMP_DIR)\bn_mp_zero.obj \ $(TMP_DIR)\bn_s_mp_add.obj \ -- cgit v0.12 From 5b4f454e1cb62b2e67262392eb4c641b1e1f1226 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Nov 2022 09:24:06 +0000 Subject: Change assert, since the new flag CHANNEL_ENCODING_ERROR could be set as well --- generic/tclIO.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclIO.c b/generic/tclIO.c index d5fbd18..652043c 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -6142,6 +6142,7 @@ DoReadChars( assert(!GotFlag(statePtr, CHANNEL_EOF) || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || GotFlag(statePtr, CHANNEL_ENCODING_ERROR) || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) == (CHANNEL_EOF|CHANNEL_BLOCKED))); -- cgit v0.12 From b432766202acec5c8414a7a3409d64807a652564 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Nov 2022 12:15:24 +0000 Subject: Make "read" throwing a "illegal byte sequence" exception. Doesn't work for "gets" yet. --- generic/tclIO.c | 32 ++++++++++++++++++++++++++------ tests/io.test | 2 +- 2 files changed, 27 insertions(+), 7 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 652043c..f5344b3 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -397,9 +397,9 @@ ChanClose( * calling Tcl_GetErrno(). * * Side effects: - * The CHANNEL_BLOCKED and CHANNEL_EOF flags of the channel state are set - * as appropriate. On EOF, the inputEncodingFlags are set to perform - * ending operations on decoding. + * The CHANNEL_ENCODING_ERROR, CHANNEL_BLOCKED and CHANNEL_EOF flags + * of the channel state are set as appropriate. On EOF, the + * inputEncodingFlags are set to perform ending operations on decoding. * * TODO - Is this really the right place for that? * @@ -4661,6 +4661,12 @@ Tcl_GetsObj( char *dst, *dstEnd, *eol, *eof; Tcl_EncodingState oldState; + if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { + UpdateInterest(chanPtr); + Tcl_SetErrno(EILSEQ); + return TCL_INDEX_NONE; + } + if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) { return TCL_INDEX_NONE; } @@ -5031,6 +5037,7 @@ Tcl_GetsObj( done: assert(!GotFlag(statePtr, CHANNEL_EOF) || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || GotFlag(statePtr, CHANNEL_ENCODING_ERROR) || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) == (CHANNEL_EOF|CHANNEL_BLOCKED))); @@ -6016,6 +6023,12 @@ DoReadChars( } } + if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { + /* TODO: We don't need this call? */ + UpdateInterest(chanPtr); + Tcl_SetErrno(EILSEQ); + return -1; + } /* * Early out when next read will see eofchar. * @@ -10108,6 +10121,11 @@ DoRead( * too. Keep on keeping on for now. */ + if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { + UpdateInterest(chanPtr); + Tcl_SetErrno(EILSEQ); + return -1; + } if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { SetFlag(statePtr, CHANNEL_EOF); assert(statePtr->inputEncodingFlags & TCL_ENCODING_END); @@ -10205,10 +10223,10 @@ DoRead( } /* - * 1) We're @EOF because we saw eof char. + * 1) We're @EOF because we saw eof char, or there was an encoding error. */ - if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { + if (GotFlag(statePtr, CHANNEL_STICKY_EOF|CHANNEL_ENCODING_ERROR)) { break; } @@ -10293,6 +10311,7 @@ DoRead( assert(!GotFlag(statePtr, CHANNEL_EOF) || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || GotFlag(statePtr, CHANNEL_ENCODING_ERROR) || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) == (CHANNEL_EOF|CHANNEL_BLOCKED))); @@ -11566,8 +11585,8 @@ DumpFlags( char *str, int flags) { - char buf[20]; int i = 0; + char buf[24]; #define ChanFlag(chr, bit) (buf[i++] = ((flags & (bit)) ? (chr) : '_')) @@ -11580,6 +11599,7 @@ DumpFlags( ChanFlag('c', CHANNEL_CLOSED); ChanFlag('E', CHANNEL_EOF); ChanFlag('S', CHANNEL_STICKY_EOF); + ChanFlag('U', CHANNEL_ENCODING_ERROR); ChanFlag('B', CHANNEL_BLOCKED); ChanFlag('/', INPUT_SAW_CR); ChanFlag('D', CHANNEL_DEAD); diff --git a/tests/io.test b/tests/io.test index ef9e14d..d5f10a5 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9063,7 +9063,7 @@ test io-75.6 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} -s lappend hd $msg } -cleanup { removeFile io-75.6 -} -result "41 0 {}" ; # Here, an exception should be thrown +} -match glob -result {41 1 {error reading "*": illegal byte sequence}} # ### ### ### ######### ######### ######### -- cgit v0.12 From d8dac38437604bf1c0e6ae5126069ca094edee37 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Nov 2022 15:21:29 +0000 Subject: Proposed fix for [da63e4c1e]. First version, not 100% as expected yet. --- generic/tclBinary.c | 2 +- generic/tclIO.c | 35 +++++++++++++++++++++-------------- generic/tclInt.h | 1 - tests/chanio.test | 4 ++-- tests/io.test | 4 ++-- 5 files changed, 26 insertions(+), 20 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 84188ef..07c78a8 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -530,7 +530,7 @@ MakeByteArray( return proper; } -Tcl_Obj * +static Tcl_Obj * TclNarrowToBytes( Tcl_Obj *objPtr) { diff --git a/generic/tclIO.c b/generic/tclIO.c index b7cfb45..f20a387 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4149,13 +4149,13 @@ Tcl_WriteChars( Tcl_Channel chan, /* The channel to buffer output for. */ const char *src, /* UTF-8 characters to queue in output * buffer. */ - size_t len) /* Length of string in bytes, or -1 for + size_t len) /* Length of string in bytes, or TCL_INDEX_NONE for * strlen(). */ { Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* State info for channel */ - int result; - Tcl_Obj *objPtr, *copy; + size_t result; + Tcl_Obj *objPtr; if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) { return TCL_INDEX_NONE; @@ -4182,11 +4182,15 @@ Tcl_WriteChars( } objPtr = Tcl_NewStringObj(src, len); - copy = TclNarrowToBytes(objPtr); - src = (char *) Tcl_GetByteArrayFromObj(copy, &len); + Tcl_IncrRefCount(objPtr); + src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len); + if (src == NULL) { + Tcl_SetErrno(EILSEQ); + result = TCL_INDEX_NONE; + } else { + result = WriteBytes(chanPtr, src, len); + } TclDecrRefCount(objPtr); - result = WriteBytes(chanPtr, src, len); - TclDecrRefCount(copy); return result; } @@ -4205,8 +4209,8 @@ Tcl_WriteChars( * line buffering mode. * * Results: - * The number of bytes written or -1 in case of error. If -1, - * Tcl_GetErrno() will return the error code. + * The number of bytes written or TCL_INDEX_NONE in case of error. If + * TCL_INDEX_NONE, Tcl_GetErrno() will return the error code. * * Side effects: * May buffer up output and may cause output to be produced on the @@ -4236,12 +4240,15 @@ Tcl_WriteObj( return TCL_INDEX_NONE; } if (statePtr->encoding == NULL) { - int result; - Tcl_Obj *copy = TclNarrowToBytes(objPtr); + size_t result; - src = (char *) Tcl_GetByteArrayFromObj(copy, &srcLen); - result = WriteBytes(chanPtr, src, srcLen); - Tcl_DecrRefCount(copy); + src = (char *) Tcl_GetByteArrayFromObj(objPtr, &srcLen); + if (src == NULL) { + Tcl_SetErrno(EILSEQ); + result = TCL_INDEX_NONE; + } else { + result = WriteBytes(chanPtr, src, srcLen); + } return result; } else { src = Tcl_GetStringFromObj(objPtr, &srcLen); diff --git a/generic/tclInt.h b/generic/tclInt.h index 554d642..650ea2d 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3230,7 +3230,6 @@ MODULE_SCOPE int TclMaxListLength(const char *bytes, size_t numBytes, MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, int *codePtr, int *levelPtr); -MODULE_SCOPE Tcl_Obj * TclNarrowToBytes(Tcl_Obj *objPtr); MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options); MODULE_SCOPE int TclNokia770Doubles(void); MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr); diff --git a/tests/chanio.test b/tests/chanio.test index 49ac471..1d0b225 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -116,7 +116,7 @@ set path(test1) [makeFile {} test1] test chan-io-1.6 {Tcl_WriteChars: WriteBytes} { set f [open $path(test1) w] chan configure $f -encoding binary - chan puts -nonewline $f "a乍\x00" + chan puts -nonewline $f "a\x4D\x00" chan close $f contents $path(test1) } "aM\x00" @@ -432,7 +432,7 @@ test chan-io-6.3 {Tcl_GetsObj: how many have we used?} -body { test chan-io-6.4 {Tcl_GetsObj: encoding == NULL} -body { set f [open $path(test1) w] chan configure $f -translation binary - chan puts $f "\x81\u1234\x00" + chan puts $f "\x81\x34\x00" chan close $f set f [open $path(test1)] chan configure $f -translation binary diff --git a/tests/io.test b/tests/io.test index b2c79d2..4eb62e3 100644 --- a/tests/io.test +++ b/tests/io.test @@ -108,7 +108,7 @@ set path(test1) [makeFile {} test1] test io-1.6 {Tcl_WriteChars: WriteBytes} { set f [open $path(test1) w] fconfigure $f -encoding binary - puts -nonewline $f "a乍\x00" + puts -nonewline $f "a\x4D\x00" close $f contents $path(test1) } "a\x4D\x00" @@ -466,7 +466,7 @@ test io-6.3 {Tcl_GetsObj: how many have we used?} { test io-6.4 {Tcl_GetsObj: encoding == NULL} { set f [open $path(test1) w] fconfigure $f -translation binary - puts $f "\x81\u1234\x00" + puts $f "\x81\x34\x00" close $f set f [open $path(test1)] fconfigure $f -translation binary -- cgit v0.12 From 826db93d76965d85df64187e05ec05095a6eae56 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Nov 2022 17:04:18 +0000 Subject: Internal abstract list, don't let "llength" shimmer any more. --- generic/tclArithSeries.c | 29 +++++++------- generic/tclArithSeries.h | 10 ++--- generic/tclBasic.c | 14 +++---- generic/tclBinary.c | 4 +- generic/tclClock.c | 2 +- generic/tclCmdAH.c | 4 +- generic/tclCmdIL.c | 8 ++-- generic/tclCmdMZ.c | 12 +++--- generic/tclCompExpr.c | 2 +- generic/tclDictObj.c | 30 +++++++------- generic/tclExecute.c | 18 ++++----- generic/tclInt.h | 58 +++++++++++++++------------ generic/tclLink.c | 2 +- generic/tclListObj.c | 59 ++++++++++++++++++--------- generic/tclObj.c | 102 +++++++++++++++++++++++++---------------------- generic/tclScan.c | 2 +- generic/tclStrToD.c | 12 +++--- generic/tclUtil.c | 15 ++++--- generic/tclVar.c | 8 +++- 19 files changed, 217 insertions(+), 174 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 3fa9792..ccae8aa 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -29,7 +29,7 @@ #define ArithSeriesGetInternalRep(objPtr, arithRepPtr) \ do { \ const Tcl_ObjInternalRep *irPtr; \ - irPtr = TclFetchInternalRep((objPtr), &tclArithSeriesType); \ + irPtr = TclFetchInternalRep((objPtr), &tclArithSeriesType.objType); \ (arithRepPtr) = irPtr ? (ArithSeries *)irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) @@ -70,13 +70,14 @@ static void UpdateStringOfArithSeries (Tcl_Obj *listPtr); * are valid and will be equivalent to the empty list. */ -const Tcl_ObjType tclArithSeriesType = { - "arithseries", /* name */ +const TclObjTypeWithAbstractList tclArithSeriesType = { + {"arithseries", /* name */ FreeArithSeriesInternalRep, /* freeIntRepProc */ DupArithSeriesInternalRep, /* dupIntRepProc */ UpdateStringOfArithSeries, /* updateStringProc */ SetArithSeriesFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + TCL_OBJTYPE_V0_1}, + TclArithSeriesObjLength }; /* @@ -154,7 +155,7 @@ TclNewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_W arithSeriesRepPtr->elements = NULL; arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL; - arithSeriesPtr->typePtr = &tclArithSeriesType; + arithSeriesPtr->typePtr = &tclArithSeriesType.objType; if (length > 0) Tcl_InvalidateStringRep(arithSeriesPtr); @@ -201,7 +202,7 @@ TclNewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) arithSeriesRepPtr->elements = NULL; arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL; - arithSeriesPtr->typePtr = &tclArithSeriesType; + arithSeriesPtr->typePtr = &tclArithSeriesType.objType; if (length > 0) Tcl_InvalidateStringRep(arithSeriesPtr); @@ -387,7 +388,7 @@ TclArithSeriesObjStep( { ArithSeries *arithSeriesRepPtr; - if (arithSeriesPtr->typePtr != &tclArithSeriesType) { + if (arithSeriesPtr->typePtr != &tclArithSeriesType.objType) { Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); } arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesPtr); @@ -427,11 +428,11 @@ TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **ele { ArithSeries *arithSeriesRepPtr; - if (arithSeriesPtr->typePtr != &tclArithSeriesType) { + if (arithSeriesPtr->typePtr != &tclArithSeriesType.objType) { Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); } arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesPtr); - if (index < 0 || index >= arithSeriesRepPtr->len) { + if ((unsigned long long)index >= arithSeriesRepPtr->len) { return TCL_ERROR; } /* List[i] = Start + (Step * index) */ @@ -460,7 +461,7 @@ TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **ele * *---------------------------------------------------------------------- */ -Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr) +unsigned long long TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr) { ArithSeries *arithSeriesRepPtr = (ArithSeries*) arithSeriesPtr->internalRep.twoPtrValue.ptr1; @@ -491,7 +492,7 @@ FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesPtr) ArithSeries *arithSeriesRepPtr = (ArithSeries *) arithSeriesPtr->internalRep.twoPtrValue.ptr1; if (arithSeriesRepPtr->elements) { - Tcl_WideInt i; + unsigned long long i; Tcl_Obj**elmts = arithSeriesRepPtr->elements; for(i=0; ilen; i++) { if (elmts[i]) { @@ -538,7 +539,7 @@ DupArithSeriesInternalRep( copyArithSeriesRepPtr->elements = NULL; copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesRepPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - copyPtr->typePtr = &tclArithSeriesType; + copyPtr->typePtr = &tclArithSeriesType.objType; } /* @@ -576,7 +577,7 @@ UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr) (ArithSeries*) arithSeriesPtr->internalRep.twoPtrValue.ptr1; char *elem, *p; Tcl_Obj *elemObj; - Tcl_WideInt i; + unsigned long long i; Tcl_WideInt length = 0; int slen; @@ -845,7 +846,7 @@ TclArithSeriesGetElements( Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of * pointers to the list's objects. */ { - if (TclHasInternalRep(objPtr,&tclArithSeriesType)) { + if (TclHasInternalRep(objPtr,&tclArithSeriesType.objType)) { ArithSeries *arithSeriesRepPtr; Tcl_Obj **objv; int i, objc; diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h index f7f2fa8..8392a57 100644 --- a/generic/tclArithSeries.h +++ b/generic/tclArithSeries.h @@ -15,16 +15,16 @@ * Note that the len can in theory be always computed by start,end,step * but it's faster to cache it inside the internal representation. */ -typedef struct ArithSeries { - Tcl_WideInt len; +typedef struct { + unsigned long long len; Tcl_Obj **elements; int isDouble; Tcl_WideInt start; Tcl_WideInt end; Tcl_WideInt step; } ArithSeries; -typedef struct ArithSeriesDbl { - Tcl_WideInt len; +typedef struct { + unsigned long long len; Tcl_Obj **elements; int isDouble; double start; @@ -39,7 +39,7 @@ MODULE_SCOPE int TclArithSeriesObjStep(Tcl_Obj *arithSeriesPtr, Tcl_Obj **stepObj); MODULE_SCOPE int TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **elementObj); -MODULE_SCOPE Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); +MODULE_SCOPE unsigned long long TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Interp *interp, Tcl_Obj *arithSeriesPtr, Tcl_Size fromIdx, Tcl_Size toIdx); MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Interp *interp, diff --git a/generic/tclBasic.c b/generic/tclBasic.c index cd1bfc8..0f968e1 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -7031,7 +7031,7 @@ ExprCeilFunc( code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN if (code != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType.objType); if (irPtr) { Tcl_SetObjResult(interp, objv[1]); @@ -7071,7 +7071,7 @@ ExprFloorFunc( code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN if (code != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType.objType); if (irPtr) { Tcl_SetObjResult(interp, objv[1]); @@ -7217,7 +7217,7 @@ ExprSqrtFunc( code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN if (code != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType.objType); if (irPtr) { Tcl_SetObjResult(interp, objv[1]); @@ -7271,7 +7271,7 @@ ExprUnaryFunc( code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN if (code != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType.objType); if (irPtr) { d = irPtr->doubleValue; @@ -7335,7 +7335,7 @@ ExprBinaryFunc( code = Tcl_GetDoubleFromObj(interp, objv[1], &d1); #ifdef ACCEPT_NAN if (code != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType.objType); if (irPtr) { d1 = irPtr->doubleValue; @@ -7350,7 +7350,7 @@ ExprBinaryFunc( code = Tcl_GetDoubleFromObj(interp, objv[2], &d2); #ifdef ACCEPT_NAN if (code != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objv[1], &tclDoubleType.objType); if (irPtr) { d2 = irPtr->doubleValue; @@ -7511,7 +7511,7 @@ ExprDoubleFunc( } if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) { #ifdef ACCEPT_NAN - if (TclHasInternalRep(objv[1], &tclDoubleType)) { + if (TclHasInternalRep(objv[1], &tclDoubleType.objType)) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 84188ef..975b8e6 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2017,7 +2017,7 @@ FormatNumber( */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType.objType); if (irPtr == NULL) { return TCL_ERROR; } @@ -2037,7 +2037,7 @@ FormatNumber( */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType.objType); if (irPtr == NULL) { return TCL_ERROR; diff --git a/generic/tclClock.c b/generic/tclClock.c index 6fd8327..36f82e6 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -432,7 +432,7 @@ ClockGetdatefieldsObjCmd( * that it isn't. */ - if (TclHasInternalRep(objv[1], &tclBignumType)) { + if (TclHasInternalRep(objv[1], &tclBignumType.objType)) { Tcl_SetObjResult(interp, lit[LIT_INTEGER_VALUE_TOO_LARGE]); return TCL_ERROR; } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index a5384fd..928b68f 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2726,7 +2726,7 @@ EachloopCmd( } /* Values */ - if (TclHasInternalRep(objv[2+i*2],&tclArithSeriesType)) { + if (TclHasInternalRep(objv[2+i*2],&tclArithSeriesType.objType)) { /* Special case for Arith Series */ statePtr->aCopyList[i] = TclArithSeriesObjCopy(interp, objv[2+i*2]); if (statePtr->aCopyList[i] == NULL) { @@ -2868,7 +2868,7 @@ ForeachAssignments( Tcl_Obj *valuePtr, *varValuePtr; for (i=0 ; inumLists ; i++) { - int isarithseries = TclHasInternalRep(statePtr->aCopyList[i],&tclArithSeriesType); + int isarithseries = TclHasInternalRep(statePtr->aCopyList[i],&tclArithSeriesType.objType); for (v=0 ; vvarcList[i] ; v++) { k = statePtr->index[i]++; if (k < statePtr->argcList[i]) { diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 1ca6c5e..befcb9a 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2215,7 +2215,7 @@ Tcl_JoinObjCmd( * pointer to its array of element pointers. */ - if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { + if (TclHasInternalRep(objv[1],&tclArithSeriesType.objType)) { isArithSeries = 1; listLen = TclArithSeriesObjLength(objv[1]); } else { @@ -2746,7 +2746,7 @@ Tcl_LrangeObjCmd( return result; } - if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { + if (TclHasInternalRep(objv[1],&tclArithSeriesType.objType)) { Tcl_Obj *rangeObj; rangeObj = TclArithSeriesObjRange(interp, objv[1], first, last); if (rangeObj) { @@ -3145,7 +3145,7 @@ Tcl_LreverseObjCmd( * Handle ArithSeries special case - don't shimmer a series into a list * just to reverse it. */ - if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { + if (TclHasInternalRep(objv[1],&tclArithSeriesType.objType)) { Tcl_Obj *resObj = TclArithSeriesObjReverse(interp, objv[1]); if (resObj) { Tcl_SetObjResult(interp, resObj); @@ -4728,7 +4728,7 @@ Tcl_LsortObjCmd( sortInfo.compareCmdPtr = newCommandPtr; } - if (TclHasInternalRep(listObj,&tclArithSeriesType)) { + if (TclHasInternalRep(listObj,&tclArithSeriesType.objType)) { sortInfo.resultCode = TclArithSeriesGetElements(interp, listObj, &length, &listObjPtrs); } else { diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 8abf166..7506e66 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1612,7 +1612,7 @@ StringIsCmd( case STR_IS_BOOL: case STR_IS_TRUE: case STR_IS_FALSE: - if (!TclHasInternalRep(objPtr, &tclBooleanType) + if (!TclHasInternalRep(objPtr, &tclBooleanType.objType) && (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) { if (strict) { result = 0; @@ -1682,9 +1682,9 @@ StringIsCmd( chcomp = Tcl_UniCharIsDigit; break; case STR_IS_DOUBLE: { - if (TclHasInternalRep(objPtr, &tclDoubleType) || - TclHasInternalRep(objPtr, &tclIntType) || - TclHasInternalRep(objPtr, &tclBignumType)) { + if (TclHasInternalRep(objPtr, &tclDoubleType.objType) || + TclHasInternalRep(objPtr, &tclIntType.objType) || + TclHasInternalRep(objPtr, &tclBignumType.objType)) { break; } string1 = Tcl_GetStringFromObj(objPtr, &length1); @@ -1713,8 +1713,8 @@ StringIsCmd( break; case STR_IS_INT: case STR_IS_ENTIER: - if (TclHasInternalRep(objPtr, &tclIntType) || - TclHasInternalRep(objPtr, &tclBignumType)) { + if (TclHasInternalRep(objPtr, &tclIntType.objType) || + TclHasInternalRep(objPtr, &tclBignumType.objType)) { break; } string1 = Tcl_GetStringFromObj(objPtr, &length1); diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index fbd59d8..5e7806d 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2111,7 +2111,7 @@ ParseLexeme( * Example: Inf + luence + () becomes a valid function call. * [Bug 3401704] */ - if (TclHasInternalRep(literal, &tclDoubleType)) { + if (TclHasInternalRep(literal, &tclDoubleType.objType)) { const char *p = start; while (p < end) { diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 26f98e1..a7e6bbf 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -136,20 +136,6 @@ typedef struct Dict { * dictionaries. */ } Dict; -/* - * The structure below defines the dictionary object type by means of - * functions that can be invoked by generic object code. - */ - -const Tcl_ObjType tclDictType = { - "dict", - FreeDictInternalRep, /* freeIntRepProc */ - DupDictInternalRep, /* dupIntRepProc */ - UpdateStringOfDict, /* updateStringProc */ - SetDictFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0 -}; - #define DictSetInternalRep(objPtr, dictRepPtr) \ do { \ Tcl_ObjInternalRep ir; \ @@ -166,6 +152,20 @@ const Tcl_ObjType tclDictType = { } while (0) /* + * The structure below defines the dictionary object type by means of + * functions that can be invoked by generic object code. + */ + +const Tcl_ObjType tclDictType = { + "dict", + FreeDictInternalRep, /* freeIntRepProc */ + DupDictInternalRep, /* dupIntRepProc */ + UpdateStringOfDict, /* updateStringProc */ + SetDictFromAny, /* setFromAnyProc */ + TCL_OBJTYPE_V0 +}; + +/* * The type of the specially adapted version of the Tcl_Obj*-containing hash * table defined in the tclObj.c code. This version differs in that it * allocates a bit more space in each hash entry in order to hold the pointers @@ -603,7 +603,7 @@ SetDictFromAny( * the conversion from lists to dictionaries. */ - if (TclHasInternalRep(objPtr, &tclListType)) { + if (TclHasInternalRep(objPtr, &tclListType.objType)) { size_t objc, i; Tcl_Obj **objv; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 926fd61..610b88e 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -452,11 +452,11 @@ VarHashCreateVar( */ #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ - ((TclHasInternalRep((objPtr), &tclIntType)) \ + ((TclHasInternalRep((objPtr), &tclIntType.objType)) \ ? (*(tPtr) = TCL_NUMBER_INT, \ *(ptrPtr) = (void *) \ (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ - TclHasInternalRep((objPtr), &tclDoubleType) \ + TclHasInternalRep((objPtr), &tclDoubleType.objType) \ ? (((isnan((objPtr)->internalRep.doubleValue)) \ ? (*(tPtr) = TCL_NUMBER_NAN) \ : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ @@ -4660,7 +4660,7 @@ TEBCresume( /* special case for ArithSeries */ - if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { + if (TclHasInternalRep(valuePtr,&tclArithSeriesType.objType)) { length = TclArithSeriesObjLength(valuePtr); if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { CACHE_STACK_INFO(); @@ -4681,7 +4681,7 @@ TEBCresume( */ if ((TclListObjGetElementsM(interp, valuePtr, &objc, &objv) == TCL_OK) - && !TclHasInternalRep(value2Ptr, &tclListType)) { + && !TclHasInternalRep(value2Ptr, &tclListType.objType)) { int code; DECACHE_STACK_INFO(); @@ -4723,7 +4723,7 @@ TEBCresume( TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd)); /* special case for ArithSeries */ - if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { + if (TclHasInternalRep(valuePtr,&tclArithSeriesType.objType)) { length = TclArithSeriesObjLength(valuePtr); /* Decode end-offset index values. */ @@ -4943,7 +4943,7 @@ TEBCresume( fromIdx = TclIndexDecode(fromIdx, objc - 1); - if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { + if (TclHasInternalRep(valuePtr,&tclArithSeriesType.objType)) { objResultPtr = TclArithSeriesObjRange(interp, valuePtr, fromIdx, toIdx); if (objResultPtr == NULL) { TRACE_ERROR(interp); @@ -4971,7 +4971,7 @@ TEBCresume( if (length > 0) { size_t i = 0; Tcl_Obj *o; - int isArithSeries = TclHasInternalRep(value2Ptr,&tclArithSeriesType); + int isArithSeries = TclHasInternalRep(value2Ptr,&tclArithSeriesType.objType); /* * An empty list doesn't match anything. */ @@ -6337,7 +6337,7 @@ TEBCresume( case INST_TRY_CVT_TO_BOOLEAN: valuePtr = OBJ_AT_TOS; - if (TclHasInternalRep(valuePtr, &tclBooleanType)) { + if (TclHasInternalRep(valuePtr, &tclBooleanType.objType)) { objResultPtr = TCONST(1); } else { int res = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK); @@ -8357,7 +8357,7 @@ ExecuteExtendedBinaryMathOp( overflowExpon: if ((TclGetWideIntFromObj(NULL, value2Ptr, &w2) != TCL_OK) - || (value2Ptr->typePtr != &tclIntType) + || (value2Ptr->typePtr != &tclIntType.objType) || (Tcl_WideUInt)w2 >= (1<<28)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "exponent too large", -1)); diff --git a/generic/tclInt.h b/generic/tclInt.h index 554d642..8d850db 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1076,6 +1076,14 @@ typedef struct ActiveInterpTrace { * in reverse order. */ } ActiveInterpTrace; + +#define TCL_OBJTYPE_V0_1 ((size_t)1) /* For internal core use only */ + +typedef struct { /* For internal core use only */ + Tcl_ObjType objType; + unsigned long long (*lengthProc)(Tcl_Obj *obj); +} TclObjTypeWithAbstractList; + /* * Flag values designating types of execution traces. See tclTrace.c for * related flag values. @@ -2613,7 +2621,7 @@ typedef struct ListRep { * converted to a list. */ #define TclListObjGetElementsM(interp_, listObj_, objcPtr_, objvPtr_) \ - (((listObj_)->typePtr == &tclListType) \ + (((listObj_)->typePtr == &tclListType.objType) \ ? ((ListObjGetElements((listObj_), *(objcPtr_), *(objvPtr_))), \ TCL_OK) \ : Tcl_ListObjGetElements( \ @@ -2625,12 +2633,12 @@ typedef struct ListRep { * Tcl_Obj cannot be converted to a list. */ #define TclListObjLengthM(interp_, listObj_, lenPtr_) \ - (((listObj_)->typePtr == &tclListType) \ + (((listObj_)->typePtr == &tclListType.objType) \ ? ((ListObjLength((listObj_), *(lenPtr_))), TCL_OK) \ : Tcl_ListObjLength((interp_), (listObj_), (lenPtr_))) #define TclListObjIsCanonical(listObj_) \ - (((listObj_)->typePtr == &tclListType) ? ListObjIsCanonical((listObj_)) : 0) + (((listObj_)->typePtr == &tclListType.objType) ? ListObjIsCanonical((listObj_)) : 0) /* * Modes for collecting (or not) in the implementations of TclNRForeachCmd, @@ -2650,27 +2658,27 @@ typedef struct ListRep { #if TCL_MAJOR_VERSION > 8 #define TclGetBooleanFromObj(interp, objPtr, intPtr) \ - (((objPtr)->typePtr == &tclIntType \ - || (objPtr)->typePtr == &tclBooleanType) \ + (((objPtr)->typePtr == &tclIntType.objType \ + || (objPtr)->typePtr == &tclBooleanType.objType) \ ? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ : Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr))) #else #define TclGetBooleanFromObj(interp, objPtr, intPtr) \ - (((objPtr)->typePtr == &tclIntType) \ + (((objPtr)->typePtr == &tclIntType.objType) \ ? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ - : ((objPtr)->typePtr == &tclBooleanType) \ + : ((objPtr)->typePtr == &tclBooleanType.objType) \ ? (*(intPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ : Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr))) #endif #ifdef TCL_WIDE_INT_IS_LONG #define TclGetLongFromObj(interp, objPtr, longPtr) \ - (((objPtr)->typePtr == &tclIntType) \ + (((objPtr)->typePtr == &tclIntType.objType) \ ? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetLongFromObj((interp), (objPtr), (longPtr))) #else #define TclGetLongFromObj(interp, objPtr, longPtr) \ - (((objPtr)->typePtr == &tclIntType \ + (((objPtr)->typePtr == &tclIntType.objType \ && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(LONG_MIN) \ && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(LONG_MAX)) \ ? ((*(longPtr) = (long)(objPtr)->internalRep.wideValue), TCL_OK) \ @@ -2678,13 +2686,13 @@ typedef struct ListRep { #endif #define TclGetIntFromObj(interp, objPtr, intPtr) \ - (((objPtr)->typePtr == &tclIntType \ + (((objPtr)->typePtr == &tclIntType.objType \ && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(INT_MIN) \ && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \ ? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetIntFromObj((interp), (objPtr), (intPtr))) #define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \ - ((((objPtr)->typePtr == &tclIntType) && ((objPtr)->internalRep.wideValue >= 0) \ + ((((objPtr)->typePtr == &tclIntType.objType) && ((objPtr)->internalRep.wideValue >= 0) \ && ((Tcl_WideUInt)(objPtr)->internalRep.wideValue <= (Tcl_WideUInt)(endValue + 1))) \ ? ((*(idxPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) @@ -2698,7 +2706,7 @@ typedef struct ListRep { */ #define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ - (((objPtr)->typePtr == &tclIntType) \ + (((objPtr)->typePtr == &tclIntType.objType) \ ? (*(wideIntPtr) = \ ((objPtr)->internalRep.wideValue), TCL_OK) : \ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) @@ -2876,13 +2884,13 @@ MODULE_SCOPE void *tclTimeClientData; * Variables denoting the Tcl object types defined in the core. */ -MODULE_SCOPE const Tcl_ObjType tclBignumType; -MODULE_SCOPE const Tcl_ObjType tclBooleanType; +MODULE_SCOPE const TclObjTypeWithAbstractList tclBignumType; +MODULE_SCOPE const TclObjTypeWithAbstractList tclBooleanType; MODULE_SCOPE const Tcl_ObjType tclByteCodeType; -MODULE_SCOPE const Tcl_ObjType tclDoubleType; -MODULE_SCOPE const Tcl_ObjType tclIntType; -MODULE_SCOPE const Tcl_ObjType tclListType; -MODULE_SCOPE const Tcl_ObjType tclArithSeriesType; +MODULE_SCOPE const TclObjTypeWithAbstractList tclDoubleType; +MODULE_SCOPE const TclObjTypeWithAbstractList tclIntType; +MODULE_SCOPE const TclObjTypeWithAbstractList tclListType; +MODULE_SCOPE const TclObjTypeWithAbstractList tclArithSeriesType; MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; @@ -4764,7 +4772,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; Tcl_ObjInternalRep ir; \ ir.wideValue = (Tcl_WideInt) i; \ TclInvalidateStringRep(objPtr); \ - Tcl_StoreInternalRep(objPtr, &tclIntType, &ir); \ + Tcl_StoreInternalRep(objPtr, &tclIntType.objType, &ir); \ } while (0) #define TclSetDoubleObj(objPtr, d) \ @@ -4772,7 +4780,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; Tcl_ObjInternalRep ir; \ ir.doubleValue = (double) d; \ TclInvalidateStringRep(objPtr); \ - Tcl_StoreInternalRep(objPtr, &tclDoubleType, &ir); \ + Tcl_StoreInternalRep(objPtr, &tclDoubleType.objType, &ir); \ } while (0) /* @@ -4797,7 +4805,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; (objPtr)->refCount = 0; \ (objPtr)->bytes = NULL; \ (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \ - (objPtr)->typePtr = &tclIntType; \ + (objPtr)->typePtr = &tclIntType.objType; \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) @@ -4816,7 +4824,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; TclSetBignumInternalRep((objPtr), &bignumValue_); \ } else { \ (objPtr)->internalRep.wideValue = (Tcl_WideInt)(uw_); \ - (objPtr)->typePtr = &tclIntType; \ + (objPtr)->typePtr = &tclIntType.objType; \ } \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) @@ -4830,7 +4838,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; Tcl_WideUInt uw_ = (uw); \ if (uw_ >= TCL_INDEX_NONE) { \ (objPtr)->internalRep.wideValue = -1; \ - (objPtr)->typePtr = &tclIntType; \ + (objPtr)->typePtr = &tclIntType.objType; \ } else if (uw_ > WIDE_MAX) { \ mp_int bignumValue_; \ if (mp_init_u64(&bignumValue_, uw_) != MP_OKAY) { \ @@ -4839,7 +4847,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; TclSetBignumInternalRep((objPtr), &bignumValue_); \ } else { \ (objPtr)->internalRep.wideValue = (Tcl_WideInt)(uw_); \ - (objPtr)->typePtr = &tclIntType; \ + (objPtr)->typePtr = &tclIntType.objType; \ } \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) @@ -4851,7 +4859,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; (objPtr)->refCount = 0; \ (objPtr)->bytes = NULL; \ (objPtr)->internalRep.doubleValue = (double)(d); \ - (objPtr)->typePtr = &tclDoubleType; \ + (objPtr)->typePtr = &tclDoubleType.objType; \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) diff --git a/generic/tclLink.c b/generic/tclLink.c index a0212ee..a28a030 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -547,7 +547,7 @@ GetDouble( return 0; } else { #ifdef ACCEPT_NAN - Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &tclDoubleType); + Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &tclDoubleType.objType); if (irPtr != NULL) { *dblPtr = irPtr->doubleValue; diff --git a/generic/tclListObj.c b/generic/tclListObj.c index ea5afac..d9fcada 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -68,7 +68,7 @@ /* Checks for when caller should have already converted to internal list type */ #define LIST_ASSERT_TYPE(listObj_) \ - LIST_ASSERT((listObj_)->typePtr == &tclListType); + LIST_ASSERT((listObj_)->typePtr == &tclListType.objType); /* @@ -142,6 +142,7 @@ static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeListInternalRep(Tcl_Obj *listPtr); static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfList(Tcl_Obj *listPtr); +static unsigned long long ListLength(Tcl_Obj *listPtr); /* * The structure below defines the list Tcl object type by means of functions @@ -150,13 +151,14 @@ static void UpdateStringOfList(Tcl_Obj *listPtr); * The internal representation of a list object is ListRep defined in tcl.h. */ -const Tcl_ObjType tclListType = { - "list", /* name */ +const TclObjTypeWithAbstractList tclListType = { + {"list", /* name */ FreeListInternalRep, /* freeIntRepProc */ DupListInternalRep, /* dupIntRepProc */ UpdateStringOfList, /* updateStringProc */ SetListFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + TCL_OBJTYPE_V0_1}, + ListLength }; /* Macros to manipulate the List internal rep */ @@ -202,7 +204,7 @@ const Tcl_ObjType tclListType = { do { \ (objPtr_)->internalRep.twoPtrValue.ptr1 = (repPtr_)->storePtr; \ (objPtr_)->internalRep.twoPtrValue.ptr2 = (repPtr_)->spanPtr; \ - (objPtr_)->typePtr = &tclListType; \ + (objPtr_)->typePtr = &tclListType.objType; \ } while (0) #define ListObjOverwriteRep(objPtr_, repPtr_) \ @@ -1272,7 +1274,7 @@ TclListObjGetRep( * to be returned. */ ListRep *repPtr) /* Location to store descriptor */ { - if (!TclHasInternalRep(listObj, &tclListType)) { + if (!TclHasInternalRep(listObj, &tclListType.objType)) { int result; result = SetListFromAny(interp, listObj); if (result != TCL_OK) { @@ -1366,8 +1368,8 @@ TclListObjCopy( { Tcl_Obj *copyObj; - if (!TclHasInternalRep(listObj, &tclListType)) { - if (TclHasInternalRep(listObj,&tclArithSeriesType)) { + if (!TclHasInternalRep(listObj, &tclListType.objType)) { + if (TclHasInternalRep(listObj,&tclArithSeriesType.objType)) { return TclArithSeriesObjCopy(interp, listObj); } if (SetListFromAny(interp, listObj) != TCL_OK) { @@ -1663,7 +1665,7 @@ Tcl_ListObjGetElements( { ListRep listRep; - if (TclHasInternalRep(objPtr,&tclArithSeriesType)) { + if (TclHasInternalRep(objPtr,&tclArithSeriesType.objType)) { return TclArithSeriesGetElements(interp, objPtr, objcPtr, objvPtr); } @@ -1991,11 +1993,19 @@ Tcl_ListObjLength( Tcl_Obj *listObj, /* List object whose #elements to return. */ Tcl_Size *lenPtr) /* The resulting int is stored here. */ { - ListRep listRep; - - if (TclHasInternalRep(listObj,&tclArithSeriesType)) { - *lenPtr = TclArithSeriesObjLength(listObj); - return TCL_OK; + if (listObj->typePtr && (listObj->typePtr->version == TCL_OBJTYPE_V0_1)) { + const TclObjTypeWithAbstractList *objType = (const TclObjTypeWithAbstractList *)listObj->typePtr; + if (objType->lengthProc) { + unsigned long long len = objType->lengthProc(listObj); + if (len >= TCL_INDEX_NONE) { + if (interp) { + Tcl_AppendResult(interp, "List too large"); + } + return TCL_ERROR; + } + *lenPtr = len; + return TCL_OK; + } } /* @@ -2005,12 +2015,23 @@ Tcl_ListObjLength( * other hand, this code will be faster for the case where the object * is currently a dict. Benchmark the two cases. */ + ListRep listRep; + if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) { return TCL_ERROR; } *lenPtr = ListRepLength(&listRep); return TCL_OK; } + +unsigned long long ListLength( + Tcl_Obj *listPtr) +{ + ListRep listRep; + ListObjGetRep(listPtr, &listRep); + + return ListRepLength(&listRep); +} /* *---------------------------------------------------------------------- @@ -2553,7 +2574,7 @@ TclLindexList( * shimmering; if internal rep is already a list do not shimmer it. * see TIP#22 and TIP#33 for the details. */ - if (!TclHasInternalRep(argObj, &tclListType) + if (!TclHasInternalRep(argObj, &tclListType.objType) && TclGetIntForIndexM(NULL, argObj, ListSizeT_MAX - 1, &index) == TCL_OK) { /* @@ -2626,7 +2647,7 @@ TclLindexFlat( Tcl_Size i; /* Handle ArithSeries as special case */ - if (TclHasInternalRep(listObj,&tclArithSeriesType)) { + if (TclHasInternalRep(listObj,&tclArithSeriesType.objType)) { Tcl_WideInt listLen = TclArithSeriesObjLength(listObj); Tcl_Size index; Tcl_Obj *elemObj = NULL; @@ -2744,7 +2765,7 @@ TclLsetList( * shimmering; see TIP #22 and #23 for details. */ - if (!TclHasInternalRep(indexArgObj, &tclListType) + if (!TclHasInternalRep(indexArgObj, &tclListType.objType) && TclGetIntForIndexM(NULL, indexArgObj, ListSizeT_MAX - 1, &index) == TCL_OK) { /* indexArgPtr designates a single index. */ @@ -3274,7 +3295,7 @@ SetListFromAny( Tcl_IncrRefCount(valuePtr); Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); } - } else if (TclHasInternalRep(objPtr,&tclArithSeriesType)) { + } else if (TclHasInternalRep(objPtr,&tclArithSeriesType.objType)) { /* * Convertion from Arithmetic Series is a special case * because it can be done an order of magnitude faster @@ -3382,7 +3403,7 @@ fail: TclFreeInternalRep(objPtr); objPtr->internalRep.twoPtrValue.ptr1 = listRep.storePtr; objPtr->internalRep.twoPtrValue.ptr2 = listRep.spanPtr; - objPtr->typePtr = &tclListType; + objPtr->typePtr = &tclListType.objType; return TCL_OK; } diff --git a/generic/tclObj.c b/generic/tclObj.c index 76f1627..5e3f4f1 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -225,37 +225,43 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); * implementations. */ -const Tcl_ObjType tclBooleanType = { - "boolean", /* name */ +static unsigned long long LengthOne(TCL_UNUSED(Tcl_Obj *)) {return 1;} + +const TclObjTypeWithAbstractList tclBooleanType= { + {"boolean", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ TclSetBooleanFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + TCL_OBJTYPE_V0_1}, + LengthOne }; -const Tcl_ObjType tclDoubleType = { - "double", /* name */ +const TclObjTypeWithAbstractList tclDoubleType= { + {"double", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfDouble, /* updateStringProc */ SetDoubleFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + TCL_OBJTYPE_V0_1}, + LengthOne }; -const Tcl_ObjType tclIntType = { - "int", /* name */ +const TclObjTypeWithAbstractList tclIntType = { + {"int", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfInt, /* updateStringProc */ SetIntFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + TCL_OBJTYPE_V0_1}, + LengthOne }; -const Tcl_ObjType tclBignumType = { - "bignum", /* name */ +const TclObjTypeWithAbstractList tclBignumType = { + {"bignum", /* name */ FreeBignum, /* freeIntRepProc */ DupBignum, /* dupIntRepProc */ UpdateStringOfBignum, /* updateStringProc */ NULL, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + TCL_OBJTYPE_V0_1}, + LengthOne }; /* @@ -365,9 +371,9 @@ TclInitObjSubsystem(void) Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&tableMutex); - Tcl_RegisterObjType(&tclDoubleType); + Tcl_RegisterObjType(&tclDoubleType.objType); Tcl_RegisterObjType(&tclStringType); - Tcl_RegisterObjType(&tclListType); + Tcl_RegisterObjType(&tclListType.objType); Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); Tcl_RegisterObjType(&tclCmdNameType); @@ -2007,11 +2013,11 @@ Tcl_GetBoolFromObj( return TCL_ERROR; } do { - if (objPtr->typePtr == &tclIntType || objPtr->typePtr == &tclBooleanType) { + if (objPtr->typePtr == &tclIntType.objType || objPtr->typePtr == &tclBooleanType.objType) { result = (objPtr->internalRep.wideValue != 0); goto boolEnd; } - if (objPtr->typePtr == &tclDoubleType) { + if (objPtr->typePtr == &tclDoubleType.objType) { /* * Caution: Don't be tempted to check directly for the "double" * Tcl_ObjType and then compare the internalrep to 0.0. This isn't @@ -2028,7 +2034,7 @@ Tcl_GetBoolFromObj( result = (d != 0.0); goto boolEnd; } - if (objPtr->typePtr == &tclBignumType) { + if (objPtr->typePtr == &tclBignumType.objType) { result = 1; boolEnd: if (charPtr != NULL) { @@ -2096,18 +2102,18 @@ TclSetBooleanFromAny( */ if (objPtr->bytes == NULL) { - if (objPtr->typePtr == &tclIntType) { + if (objPtr->typePtr == &tclIntType.objType) { if ((Tcl_WideUInt)objPtr->internalRep.wideValue < 2) { return TCL_OK; } goto badBoolean; } - if (objPtr->typePtr == &tclBignumType) { + if (objPtr->typePtr == &tclBignumType.objType) { goto badBoolean; } - if (objPtr->typePtr == &tclDoubleType) { + if (objPtr->typePtr == &tclDoubleType.objType) { goto badBoolean; } } @@ -2238,13 +2244,13 @@ ParseBoolean( goodBoolean: TclFreeInternalRep(objPtr); objPtr->internalRep.wideValue = newBool; - objPtr->typePtr = &tclBooleanType; + objPtr->typePtr = &tclBooleanType.objType; return TCL_OK; numericBoolean: TclFreeInternalRep(objPtr); objPtr->internalRep.wideValue = newBool; - objPtr->typePtr = &tclIntType; + objPtr->typePtr = &tclIntType.objType; return TCL_OK; } @@ -2336,7 +2342,7 @@ Tcl_DbNewDoubleObj( objPtr->bytes = NULL; objPtr->internalRep.doubleValue = dblValue; - objPtr->typePtr = &tclDoubleType; + objPtr->typePtr = &tclDoubleType.objType; return objPtr; } @@ -2409,7 +2415,7 @@ Tcl_GetDoubleFromObj( double *dblPtr) /* Place to store resulting double. */ { do { - if (objPtr->typePtr == &tclDoubleType) { + if (objPtr->typePtr == &tclDoubleType.objType) { if (isnan(objPtr->internalRep.doubleValue)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -2422,11 +2428,11 @@ Tcl_GetDoubleFromObj( *dblPtr = (double) objPtr->internalRep.doubleValue; return TCL_OK; } - if (objPtr->typePtr == &tclIntType) { + if (objPtr->typePtr == &tclIntType.objType) { *dblPtr = (double) objPtr->internalRep.wideValue; return TCL_OK; } - if (objPtr->typePtr == &tclBignumType) { + if (objPtr->typePtr == &tclBignumType.objType) { mp_int big; TclUnpackBignum(objPtr, big); @@ -2640,12 +2646,12 @@ Tcl_GetLongFromObj( { do { #ifdef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclIntType) { + if (objPtr->typePtr == &tclIntType.objType) { *longPtr = objPtr->internalRep.wideValue; return TCL_OK; } #else - if (objPtr->typePtr == &tclIntType) { + if (objPtr->typePtr == &tclIntType.objType) { /* * We return any integer in the range LONG_MIN to ULONG_MAX * converted to a long, ignoring overflow. The rule preserves @@ -2664,7 +2670,7 @@ Tcl_GetLongFromObj( goto tooLarge; } #endif - if (objPtr->typePtr == &tclDoubleType) { + if (objPtr->typePtr == &tclDoubleType.objType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", @@ -2673,7 +2679,7 @@ Tcl_GetLongFromObj( } return TCL_ERROR; } - if (objPtr->typePtr == &tclBignumType) { + if (objPtr->typePtr == &tclBignumType.objType) { /* * Must check for those bignum values that can fit in a long, even * when auto-narrowing is enabled. Only those values in the signed @@ -2901,11 +2907,11 @@ Tcl_GetWideIntFromObj( /* Place to store resulting long. */ { do { - if (objPtr->typePtr == &tclIntType) { + if (objPtr->typePtr == &tclIntType.objType) { *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; } - if (objPtr->typePtr == &tclDoubleType) { + if (objPtr->typePtr == &tclDoubleType.objType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", @@ -2914,7 +2920,7 @@ Tcl_GetWideIntFromObj( } return TCL_ERROR; } - if (objPtr->typePtr == &tclBignumType) { + if (objPtr->typePtr == &tclBignumType.objType) { /* * Must check for those bignum values that can fit in a * Tcl_WideInt, even when auto-narrowing is enabled. @@ -2986,7 +2992,7 @@ Tcl_GetWideUIntFromObj( /* Place to store resulting long. */ { do { - if (objPtr->typePtr == &tclIntType) { + if (objPtr->typePtr == &tclIntType.objType) { if (objPtr->internalRep.wideValue < 0) { wideUIntOutOfRange: if (interp != NULL) { @@ -3000,10 +3006,10 @@ Tcl_GetWideUIntFromObj( *wideUIntPtr = (Tcl_WideUInt)objPtr->internalRep.wideValue; return TCL_OK; } - if (objPtr->typePtr == &tclDoubleType) { + if (objPtr->typePtr == &tclDoubleType.objType) { goto wideUIntOutOfRange; } - if (objPtr->typePtr == &tclBignumType) { + if (objPtr->typePtr == &tclBignumType.objType) { /* * Must check for those bignum values that can fit in a * Tcl_WideUInt, even when auto-narrowing is enabled. @@ -3070,11 +3076,11 @@ TclGetWideBitsFromObj( Tcl_WideInt *wideIntPtr) /* Place to store resulting wide integer. */ { do { - if (objPtr->typePtr == &tclIntType) { + if (objPtr->typePtr == &tclIntType.objType) { *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; } - if (objPtr->typePtr == &tclDoubleType) { + if (objPtr->typePtr == &tclDoubleType.objType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", @@ -3083,7 +3089,7 @@ TclGetWideBitsFromObj( } return TCL_ERROR; } - if (objPtr->typePtr == &tclBignumType) { + if (objPtr->typePtr == &tclBignumType.objType) { mp_int big; mp_err err; @@ -3162,7 +3168,7 @@ DupBignum( mp_int bignumVal; mp_int bignumCopy; - copyPtr->typePtr = &tclBignumType; + copyPtr->typePtr = &tclBignumType.objType; TclUnpackBignum(srcPtr, bignumVal); if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) { Tcl_Panic("initialization failure in DupBignum"); @@ -3332,7 +3338,7 @@ GetBignumFromObj( mp_int *bignumValue) /* Returned bignum value. */ { do { - if (objPtr->typePtr == &tclBignumType) { + if (objPtr->typePtr == &tclBignumType.objType) { if (copy || Tcl_IsShared(objPtr)) { mp_int temp; @@ -3357,14 +3363,14 @@ GetBignumFromObj( } return TCL_OK; } - if (objPtr->typePtr == &tclIntType) { + if (objPtr->typePtr == &tclIntType.objType) { if (mp_init_i64(bignumValue, objPtr->internalRep.wideValue) != MP_OKAY) { return TCL_ERROR; } return TCL_OK; } - if (objPtr->typePtr == &tclDoubleType) { + if (objPtr->typePtr == &tclDoubleType.objType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", @@ -3524,7 +3530,7 @@ TclSetBignumInternalRep( void *big) { mp_int *bignumValue = (mp_int *)big; - objPtr->typePtr = &tclBignumType; + objPtr->typePtr = &tclBignumType.objType; PACK_BIGNUM(*bignumValue, objPtr); /* @@ -3567,7 +3573,7 @@ Tcl_GetNumberFromObj( int *typePtr) { do { - if (objPtr->typePtr == &tclDoubleType) { + if (objPtr->typePtr == &tclDoubleType.objType) { if (isnan(objPtr->internalRep.doubleValue)) { *typePtr = TCL_NUMBER_NAN; } else { @@ -3576,12 +3582,12 @@ Tcl_GetNumberFromObj( *clientDataPtr = &objPtr->internalRep.doubleValue; return TCL_OK; } - if (objPtr->typePtr == &tclIntType) { + if (objPtr->typePtr == &tclIntType.objType) { *typePtr = TCL_NUMBER_INT; *clientDataPtr = &objPtr->internalRep.wideValue; return TCL_OK; } - if (objPtr->typePtr == &tclBignumType) { + if (objPtr->typePtr == &tclBignumType.objType) { static Tcl_ThreadDataKey bignumKey; mp_int *bigPtr = (mp_int *)Tcl_GetThreadData(&bignumKey, sizeof(mp_int)); @@ -4520,7 +4526,7 @@ Tcl_RepresentationCmd( objv[1]->refCount, objv[1]); if (objv[1]->typePtr) { - if (objv[1]->typePtr == &tclDoubleType) { + if (objv[1]->typePtr == &tclDoubleType.objType) { Tcl_AppendPrintfToObj(descObj, ", internal representation %g", objv[1]->internalRep.doubleValue); } else { diff --git a/generic/tclScan.c b/generic/tclScan.c index 0a8e9ae..3e9cfae 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -1019,7 +1019,7 @@ Tcl_ScanObjCmd( if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) { #ifdef ACCEPT_NAN const Tcl_ObjInternalRep *irPtr - = TclFetchInternalRep(objPtr, &tclDoubleType); + = TclFetchInternalRep(objPtr, &tclDoubleType.objType); if (irPtr) { dvalue = irPtr->doubleValue; } else diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index a816062..fed2aea 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -554,7 +554,7 @@ TclParseNumber( /* A dict can never be a (single) number */ return TCL_ERROR; } - if (TclHasInternalRep(objPtr, &tclListType)) { + if (TclHasInternalRep(objPtr, &tclListType.objType)) { size_t length; /* A list can only be a (single) number if its length == 1 */ TclListObjLengthM(NULL, objPtr, &length); @@ -1377,7 +1377,7 @@ TclParseNumber( octalSignificandWide); octalSignificandOverflow = 1; } else { - objPtr->typePtr = &tclIntType; + objPtr->typePtr = &tclIntType.objType; if (signum) { objPtr->internalRep.wideValue = (Tcl_WideInt)(-octalSignificandWide); @@ -1413,7 +1413,7 @@ TclParseNumber( significandWide); significandOverflow = 1; } else { - objPtr->typePtr = &tclIntType; + objPtr->typePtr = &tclIntType.objType; if (signum) { objPtr->internalRep.wideValue = (Tcl_WideInt)(-significandWide); @@ -1445,7 +1445,7 @@ TclParseNumber( * k = numTrailZeros+exponent-numDigitsAfterDp. */ - objPtr->typePtr = &tclDoubleType; + objPtr->typePtr = &tclDoubleType.objType; if (exponentSignum) { /* * At this point exponent>=0, so the following calculation @@ -1496,14 +1496,14 @@ TclParseNumber( } else { objPtr->internalRep.doubleValue = HUGE_VAL; } - objPtr->typePtr = &tclDoubleType; + objPtr->typePtr = &tclDoubleType.objType; break; #ifdef IEEE_FLOATING_POINT case sNAN: case sNANFINISH: objPtr->internalRep.doubleValue = MakeNaN(signum, significandWide); - objPtr->typePtr = &tclDoubleType; + objPtr->typePtr = &tclDoubleType.objType; break; #endif case INITIAL: diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 0b898f1..b23d134 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -122,13 +122,16 @@ static int FindElement(Tcl_Interp *interp, const char *string, * is unregistered, so has no need of a setFromAnyProc either. */ -static const Tcl_ObjType endOffsetType = { - "end-offset", /* name */ +static unsigned long long LengthOne(TCL_UNUSED(Tcl_Obj *)) {return 1;} + +static const TclObjTypeWithAbstractList endOffsetType = { + {"end-offset", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + TCL_OBJTYPE_V0_1}, + LengthOne }; /* @@ -3455,7 +3458,7 @@ GetEndOffsetFromObj( Tcl_WideInt offset = -1; /* Offset in the "end-offset" expression - 1 */ void *cd; - while ((irPtr = TclFetchInternalRep(objPtr, &endOffsetType)) == NULL) { + while ((irPtr = TclFetchInternalRep(objPtr, &endOffsetType.objType)) == NULL) { Tcl_ObjInternalRep ir; size_t length; const char *bytes = Tcl_GetStringFromObj(objPtr, &length); @@ -3641,7 +3644,7 @@ GetEndOffsetFromObj( parseOK: /* Success. Store the new internal rep. */ ir.wideValue = offset; - Tcl_StoreInternalRep(objPtr, &endOffsetType, &ir); + Tcl_StoreInternalRep(objPtr, &endOffsetType.objType, &ir); } offset = irPtr->wideValue; @@ -3743,7 +3746,7 @@ TclIndexEncode( int idx; if (TCL_OK == GetWideForIndex(interp, objPtr, (unsigned)TCL_INDEX_END , &wide)) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &endOffsetType); + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &endOffsetType.objType); if (irPtr && irPtr->wideValue >= 0) { /* "int[+-]int" syntax, works the same here as "int" */ irPtr = NULL; diff --git a/generic/tclVar.c b/generic/tclVar.c index 6226e1e..f7ec7c8 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -4042,8 +4042,7 @@ ArraySetCmd( size_t elemLen; Tcl_Obj **elemPtrs, *copyListObj; - result = TclListObjGetElementsM(interp, arrayElemObj, - &elemLen, &elemPtrs); + result = TclListObjLengthM(interp, arrayElemObj, &elemLen); if (result != TCL_OK) { return result; } @@ -4056,6 +4055,11 @@ ArraySetCmd( if (elemLen == 0) { goto ensureArray; } + result = TclListObjGetElementsM(interp, arrayElemObj, + &elemLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } /* * We needn't worry about traces invalidating arrayPtr: should that be -- cgit v0.12 From e4f687d97860f2ec8767e5d978fc4cb71013c488 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Nov 2022 20:41:34 +0000 Subject: -1 -> TCL_INDEX_NONE --- generic/tclIO.c | 126 ++++++++++++++++++++++++++++---------------------------- 1 file changed, 63 insertions(+), 63 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 652043c..045f0e5 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -125,12 +125,12 @@ typedef struct { * ChannelState exists per set of stacked * channels. */ Tcl_Channel stdinChannel; /* Static variable for the stdin channel. */ - int stdinInitialized; Tcl_Channel stdoutChannel; /* Static variable for the stdout channel. */ - int stdoutInitialized; Tcl_Channel stderrChannel; /* Static variable for the stderr channel. */ - int stderrInitialized; Tcl_Encoding binaryEncoding; + int stdinInitialized; + int stdoutInitialized; + int stderrInitialized; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; @@ -393,7 +393,7 @@ ChanClose( * Results: * The return value of the driver inputProc, * - number of bytes stored at dst, ot - * - -1 on error, with a Posix error code available to the caller by + * - TCL_INDEX_NONE on error, with a Posix error code available to the caller by * calling Tcl_GetErrno(). * * Side effects: @@ -431,7 +431,7 @@ ChanRead( ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF); chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END; if (WillRead(chanPtr) < 0) { - return -1; + return TCL_INDEX_NONE; } bytesRead = chanPtr->typePtr->inputProc(chanPtr->instanceData, @@ -486,14 +486,14 @@ ChanSeek( #ifndef TCL_NO_DEPRECATED if (offsetLONG_MAX) { *errnoPtr = EOVERFLOW; - return -1; + return TCL_INDEX_NONE; } return Tcl_ChannelSeekProc(chanPtr->typePtr)(chanPtr->instanceData, offset, mode, errnoPtr); #else *errnoPtr = EINVAL; - return -1; + return TCL_INDEX_NONE; #endif } @@ -1237,7 +1237,7 @@ Tcl_UnregisterChannel( if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "illegal recursive call to close through close-handler" - " of channel", -1)); + " of channel", TCL_INDEX_NONE)); } return TCL_ERROR; } @@ -2720,7 +2720,7 @@ CheckForDeadChannel( Tcl_SetErrno(EINVAL); if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unable to access channel: invalid channel", -1)); + "unable to access channel: invalid channel", TCL_INDEX_NONE)); } return 1; } @@ -2918,7 +2918,7 @@ FlushChannel( if (interp != NULL && !TclChanCaughtErrorBypass(interp, (Tcl_Channel) chanPtr)) { Tcl_SetObjResult(interp, - Tcl_NewStringObj(Tcl_PosixError(interp), -1)); + Tcl_NewStringObj(Tcl_PosixError(interp), TCL_INDEX_NONE)); } /* @@ -3493,7 +3493,7 @@ Tcl_Close( if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "illegal recursive call to close through close-handler" - " of channel", -1)); + " of channel", TCL_INDEX_NONE)); } return TCL_ERROR; } @@ -3606,7 +3606,7 @@ Tcl_Close( Tcl_SetErrno(stickyError); if (interp != NULL) { Tcl_SetObjResult(interp, - Tcl_NewStringObj(Tcl_PosixError(interp), -1)); + Tcl_NewStringObj(Tcl_PosixError(interp), TCL_INDEX_NONE)); } return TCL_ERROR; } @@ -3624,7 +3624,7 @@ Tcl_Close( && 0 == TclGetCharLength(Tcl_GetObjResult(interp))) { Tcl_SetErrno(result); Tcl_SetObjResult(interp, - Tcl_NewStringObj(Tcl_PosixError(interp), -1)); + Tcl_NewStringObj(Tcl_PosixError(interp), TCL_INDEX_NONE)); } if (result != 0) { return TCL_ERROR; @@ -3696,7 +3696,7 @@ Tcl_CloseEx( if (chanPtr != statePtr->topChanPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "half-close not applicable to stack of transformations", -1)); + "half-close not applicable to stack of transformations", TCL_INDEX_NONE)); return TCL_ERROR; } @@ -3729,7 +3729,7 @@ Tcl_CloseEx( if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "illegal recursive call to close through close-handler" - " of channel", -1)); + " of channel", TCL_INDEX_NONE)); } return TCL_ERROR; } @@ -4111,7 +4111,7 @@ Tcl_Write( chanPtr = statePtr->topChanPtr; if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) { - return -1; + return TCL_INDEX_NONE; } if (srcLen < 0) { @@ -4208,7 +4208,7 @@ Tcl_WriteChars( Tcl_Channel chan, /* The channel to buffer output for. */ const char *src, /* UTF-8 characters to queue in output * buffer. */ - int len) /* Length of string in bytes, or < 0 for + int len) /* Length of string in bytes, or TCL_INDEX_NONE for * strlen(). */ { Channel *chanPtr = (Channel *) chan; @@ -4330,7 +4330,7 @@ WillRead( DiscardInputQueued(chanPtr->state, 0); Tcl_SetErrno(EINVAL); - return -1; + return TCL_INDEX_NONE; } if (((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL) #ifndef TCL_NO_DEPRECATED @@ -4348,7 +4348,7 @@ WillRead( */ if (FlushChannel(NULL, chanPtr, 0) != 0) { - return -1; + return TCL_INDEX_NONE; } } return 0; @@ -4365,7 +4365,7 @@ WillRead( * ready e.g. if it contains a newline and we are in line buffering mode. * * Results: - * The number of bytes written or -1 in case of error. If -1, + * The number of bytes written or TCL_INDEX_NONE in case of error. If TCL_INDEX_NONE, * Tcl_GetErrno will return the error code. * * Side effects: @@ -4394,7 +4394,7 @@ Write( } /* - * Transfer encoding strict/nocomplain option to the encoding flags + * Transfer encoding nocomplain/strict option to the encoding flags */ if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) { @@ -4546,7 +4546,7 @@ Write( if (IsBufferFull(bufPtr)) { if (FlushChannel(NULL, chanPtr, 0) != 0) { - return -1; + return TCL_INDEX_NONE; } flushed += statePtr->bufSize; @@ -4569,7 +4569,7 @@ Write( if (((flushed < total) && GotFlag(statePtr, CHANNEL_UNBUFFERED)) || (needNlFlush && GotFlag(statePtr, CHANNEL_LINEBUFFERED))) { if (FlushChannel(NULL, chanPtr, 0) != 0) { - return -1; + return TCL_INDEX_NONE; } } @@ -4577,7 +4577,7 @@ Write( if (encodingError) { Tcl_SetErrno(EILSEQ); - return -1; + return TCL_INDEX_NONE; } return total; } @@ -4590,8 +4590,8 @@ Write( * Reads a complete line of input from the channel into a Tcl_DString. * * Results: - * Length of line read (in characters) or -1 if error, EOF, or blocked. - * If -1, use Tcl_GetErrno() to retrieve the POSIX error code for the + * Length of line read (in characters) or TCL_INDEX_NONE if error, EOF, or blocked. + * If TCL_INDEX_NONE, use Tcl_GetErrno() to retrieve the POSIX error code for the * error or condition that occurred. * * Side effects: @@ -4631,8 +4631,8 @@ Tcl_Gets( * converted to UTF-8 using the encoding specified by the channel. * * Results: - * Number of characters accumulated in the object or -1 if error, - * blocked, or EOF. If -1, use Tcl_GetErrno() to retrieve the POSIX error + * Number of characters accumulated in the object or TCL_INDEX_NONE if error, + * blocked, or EOF. If TCL_INDEX_NONE, use Tcl_GetErrno() to retrieve the POSIX error * code for the error or condition that occurred. * * Side effects: @@ -5064,8 +5064,8 @@ Tcl_GetsObj( * may be called when an -eofchar is set on the channel. * * Results: - * Number of characters accumulated in the object or -1 if error, - * blocked, or EOF. If -1, use Tcl_GetErrno() to retrieve the POSIX error + * Number of characters accumulated in the object or TCL_INDEX_NONE if error, + * blocked, or EOF. If TCL_INDEX_NONE, use Tcl_GetErrno() to retrieve the POSIX error * code for the error or condition that occurred. * * Side effects: @@ -5213,12 +5213,12 @@ TclGetsObjBinary( if ((dst == dstEnd) && (byteLen == oldLength)) { /* * If we didn't append any bytes before encountering EOF, - * caller needs to see -1. + * caller needs to see TCL_INDEX_NONE. */ byteArray = Tcl_SetByteArrayLength(objPtr, oldLength); CommonGetsCleanup(chanPtr); - copiedTotal = -1; + copiedTotal = TCL_INDEX_NONE; ResetFlag(statePtr, CHANNEL_BLOCKED); goto done; } @@ -5307,7 +5307,7 @@ TclGetsObjBinary( */ SetFlag(statePtr, CHANNEL_NEED_MORE_DATA); - copiedTotal = -1; + copiedTotal = TCL_INDEX_NONE; /* * Update the notifier state so we don't block while there is still data @@ -5741,7 +5741,7 @@ CommonGetsCleanup( * No encoding conversions are applied to the bytes being read. * * Results: - * The number of bytes read, or -1 on error. Use Tcl_GetErrno() to + * The number of bytes read, or TCL_INDEX_NONE on error. Use Tcl_GetErrno() to * retrieve the error code for the error that occurred. * * Side effects: @@ -5786,7 +5786,7 @@ Tcl_Read( * No encoding conversions are applied to the bytes being read. * * Results: - * The number of bytes read, or -1 on error. Use Tcl_GetErrno() to + * The number of bytes read, or TCL_INDEX_NONE on error. Use Tcl_GetErrno() to * retrieve the error code for the error that occurred. * * Side effects: @@ -5874,7 +5874,7 @@ Tcl_ReadRaw( */ if (!GotFlag(statePtr, CHANNEL_BLOCKED) || copied == 0) { - copied = -1; + copied = TCL_INDEX_NONE; } } else if (nread > 0) { /* @@ -5904,7 +5904,7 @@ Tcl_ReadRaw( * object. * * Results: - * The number of characters read, or -1 on error. Use Tcl_GetErrno() to + * The number of characters read, or TCL_INDEX_NONE on error. Use Tcl_GetErrno() to * retrieve the error code for the error that occurred. * * Side effects: @@ -5918,7 +5918,7 @@ Tcl_ReadChars( Tcl_Channel chan, /* The channel to read. */ Tcl_Obj *objPtr, /* Input data is stored in this object. */ int toRead, /* Maximum number of characters to store, or - * -1 to read all available data (up to EOF or + * TCL_INDEX_NONE to read all available data (up to EOF or * when channel blocks). */ int appendFlag) /* If non-zero, data read from the channel * will be appended to the object. Otherwise, @@ -5942,7 +5942,7 @@ Tcl_ReadChars( */ UpdateInterest(chanPtr); - return -1; + return TCL_INDEX_NONE; } return DoReadChars(chanPtr, objPtr, toRead, appendFlag); @@ -5960,7 +5960,7 @@ Tcl_ReadChars( * object. * * Results: - * The number of characters read, or -1 on error. Use Tcl_GetErrno() to + * The number of characters read, or TCL_INDEX_NONE on error. Use Tcl_GetErrno() to * retrieve the error code for the error that occurred. * * Side effects: @@ -5974,7 +5974,7 @@ DoReadChars( Channel *chanPtr, /* The channel to read. */ Tcl_Obj *objPtr, /* Input data is stored in this object. */ int toRead, /* Maximum number of characters to store, or - * -1 to read all available data (up to EOF or + * TCL_INDEX_NONE to read all available data (up to EOF or * when channel blocks). */ int appendFlag) /* If non-zero, data read from the channel * will be appended to the object. Otherwise, @@ -6064,7 +6064,7 @@ DoReadChars( ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; for (copied = 0; (unsigned) toRead > 0; ) { - copiedNow = -1; + copiedNow = TCL_INDEX_NONE; if (statePtr->inQueueHead != NULL) { if (binaryMode) { copiedNow = ReadBytes(statePtr, objPtr, toRead); @@ -6104,7 +6104,7 @@ DoReadChars( } if (result != 0) { if (!GotFlag(statePtr, CHANNEL_BLOCKED)) { - copied = -1; + copied = TCL_INDEX_NONE; } break; } @@ -6166,7 +6166,7 @@ DoReadChars( * * Results: * The return value is the number of bytes appended to the object, or - * -1 to indicate that zero bytes were read due to an EOF. + * TCL_INDEX_NONE to indicate that zero bytes were read due to an EOF. * * Side effects: * The storage of bytes in objPtr can cause (re-)allocation of memory. @@ -6235,7 +6235,7 @@ ReadChars( * allocated to hold data, not how many bytes * of data have been stored in the object. */ int charsToRead, /* Maximum number of characters to store, or - * -1 to get all available characters. + * TCL_INDEX_NONE to get all available characters. * Characters are obtained from the first * buffer in the queue -- even if this number * is larger than the number of characters @@ -6383,12 +6383,12 @@ ReadChars( * the stopping, but the value of dstRead does not include it. * * Also rather bizarre, our caller can only notice an EOF - * condition if we return the value -1 as the number of chars + * condition if we return the value TCL_INDEX_NONE as the number of chars * read. This forces us to perform a 2-call dance where the * first call can read all the chars up to the eof char, and * the second call is solely for consuming the encoded eof * char then pointed at by src so that we can return that - * magic -1 value. This seems really wasteful, especially + * magic TCL_INDEX_NONE value. This seems really wasteful, especially * since the first decoding pass of each call is likely to * decode many bytes beyond that eof char that's all we care * about. @@ -6403,7 +6403,7 @@ ReadChars( */ Tcl_SetObjLength(objPtr, numBytes); - return -1; + return TCL_INDEX_NONE; } { @@ -6578,7 +6578,7 @@ ReadChars( SetFlag(statePtr, CHANNEL_NEED_MORE_DATA); } Tcl_SetObjLength(objPtr, numBytes); - return -1; + return TCL_INDEX_NONE; } /* @@ -7856,10 +7856,10 @@ Tcl_BadChannelOption( Tcl_Obj *errObj; Tcl_DStringInit(&ds); - Tcl_DStringAppend(&ds, genericopt, -1); + Tcl_DStringAppend(&ds, genericopt, TCL_INDEX_NONE); if (optionList && (*optionList)) { TclDStringAppendLiteral(&ds, " "); - Tcl_DStringAppend(&ds, optionList, -1); + Tcl_DStringAppend(&ds, optionList, TCL_INDEX_NONE); } if (Tcl_SplitList(interp, Tcl_DStringValue(&ds), &argc, &argv) != TCL_OK) { @@ -8178,7 +8178,7 @@ Tcl_SetChannelOption( if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "unable to set channel options: background copy in" - " progress", -1)); + " progress", TCL_INDEX_NONE)); } return TCL_ERROR; } @@ -8229,7 +8229,7 @@ Tcl_SetChannelOption( } else if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -buffering: must be one of" - " full, line, or none", -1)); + " full, line, or none", TCL_INDEX_NONE)); return TCL_ERROR; } return TCL_OK; @@ -8292,7 +8292,7 @@ Tcl_SetChannelOption( if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -eofchar: must be non-NUL ASCII" - " character", -1)); + " character", TCL_INDEX_NONE)); } ckfree(argv); return TCL_ERROR; @@ -8307,7 +8307,7 @@ Tcl_SetChannelOption( if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -eofchar: should be a list of zero," - " one, or two elements", -1)); + " one, or two elements", TCL_INDEX_NONE)); } ckfree(argv); return TCL_ERROR; @@ -8382,7 +8382,7 @@ Tcl_SetChannelOption( if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -translation: must be a one or two" - " element list", -1)); + " element list", TCL_INDEX_NONE)); } ckfree(argv); return TCL_ERROR; @@ -8412,7 +8412,7 @@ Tcl_SetChannelOption( if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -translation: must be one of " - "auto, binary, cr, lf, crlf, or platform", -1)); + "auto, binary, cr, lf, crlf, or platform", TCL_INDEX_NONE)); } ckfree(argv); return TCL_ERROR; @@ -8462,7 +8462,7 @@ Tcl_SetChannelOption( if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -translation: must be one of " - "auto, binary, cr, lf, crlf, or platform", -1)); + "auto, binary, cr, lf, crlf, or platform", TCL_INDEX_NONE)); } ckfree(argv); return TCL_ERROR; @@ -10067,7 +10067,7 @@ CopyData( * * Results: * The number of bytes actually stored (<= bytesToRead), - * or -1 if there is an error in reading the channel. Use + * or TCL_INDEX_NONE if there is an error in reading the channel. Use * Tcl_GetErrno() to retrieve the error code for the error * that occurred. * @@ -10076,7 +10076,7 @@ CopyData( * - EOF is reached on the channel; or * - the channel is non-blocking, and we've read all we can * without blocking. - * - a channel reading error occurs (and we return -1) + * - a channel reading error occurs (and we return TCL_INDEX_NONE) * * Side effects: * May cause input to be buffered. @@ -10175,7 +10175,7 @@ DoRead( UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); - return -1; + return TCL_INDEX_NONE; } assert(IsBufferFull(bufPtr)); @@ -10583,7 +10583,7 @@ Tcl_GetChannelNamesEx( && (pattern[2] == 'd'))) { if ((Tcl_FindHashEntry(hTblPtr, pattern) != NULL) && (Tcl_ListObjAppendElement(interp, resultPtr, - Tcl_NewStringObj(pattern, -1)) != TCL_OK)) { + Tcl_NewStringObj(pattern, TCL_INDEX_NONE)) != TCL_OK)) { goto error; } goto done; @@ -10610,7 +10610,7 @@ Tcl_GetChannelNamesEx( if (((pattern == NULL) || Tcl_StringMatch(name, pattern)) && (Tcl_ListObjAppendElement(interp, resultPtr, - Tcl_NewStringObj(name, -1)) != TCL_OK)) { + Tcl_NewStringObj(name, TCL_INDEX_NONE)) != TCL_OK)) { error: TclDecrRefCount(resultPtr); return TCL_ERROR; -- cgit v0.12 From 9c802c440b678f7596b6167240964a4e5320565b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 23 Nov 2022 20:42:38 +0000 Subject: Writing characters > \xFF to a binary channel is deprecated, this will start throwing an exception in Tcl 9.0 --- tests/chanio.test | 4 ++-- tests/io.test | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index 787d926..2189cc4 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -116,7 +116,7 @@ set path(test1) [makeFile {} test1] test chan-io-1.6 {Tcl_WriteChars: WriteBytes} { set f [open $path(test1) w] chan configure $f -encoding binary - chan puts -nonewline $f "a乍\x00" + chan puts -nonewline $f "a\x4D\x00" chan close $f contents $path(test1) } "aM\x00" @@ -432,7 +432,7 @@ test chan-io-6.3 {Tcl_GetsObj: how many have we used?} -body { test chan-io-6.4 {Tcl_GetsObj: encoding == NULL} -body { set f [open $path(test1) w] chan configure $f -translation binary - chan puts $f "\x81\u1234\x00" + chan puts $f "\x81\x34\x00" chan close $f set f [open $path(test1)] chan configure $f -translation binary diff --git a/tests/io.test b/tests/io.test index ef9e14d..24fda19 100644 --- a/tests/io.test +++ b/tests/io.test @@ -108,7 +108,7 @@ set path(test1) [makeFile {} test1] test io-1.6 {Tcl_WriteChars: WriteBytes} { set f [open $path(test1) w] fconfigure $f -encoding binary - puts -nonewline $f "a乍\x00" + puts -nonewline $f "a\x4D\x00" close $f contents $path(test1) } "a\x4D\x00" @@ -466,7 +466,7 @@ test io-6.3 {Tcl_GetsObj: how many have we used?} { test io-6.4 {Tcl_GetsObj: encoding == NULL} { set f [open $path(test1) w] fconfigure $f -translation binary - puts $f "\x81\u1234\x00" + puts $f "\x81\x34\x00" close $f set f [open $path(test1)] fconfigure $f -translation binary -- cgit v0.12 From 2a569c94ef1b7bac9236da247c9f02f96992eec3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Nov 2022 10:17:51 +0000 Subject: Since Tcl 9.0 throws exceptions on an illegal byte sequence (no longer simply truncates it), adapt test-case for that --- tests/ioCmd.test | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 690b196..50cdcf5 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -491,9 +491,15 @@ test iocmd-12.10 {POSIX open access modes: BINARY} { close $f set result } 5 -test iocmd-12.11 {POSIX open access modes: BINARY} { +test iocmd-12.11 {POSIX open access modes: BINARY} -body { set f [open $path(test1) {WRONLY BINARY TRUNC}] - puts $f Ɉ ;# gets truncated to H + puts $f Ɉ ;# throws an exception +} -cleanup { + close $f +} -returnCodes 1 -match glob -result {error writing "*": illegal byte sequence} +test iocmd-12.12 {POSIX open access modes: BINARY} { + set f [open $path(test1) {WRONLY BINARY TRUNC}] + puts $f H close $f set f [open $path(test1) r] fconfigure $f -translation binary -- cgit v0.12 From ddf4a5f1583b7a5c030020dcf4a1e712b5d465f2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Nov 2022 14:05:58 +0000 Subject: Use Tcl_GetByteArrayFromObj(... in stead of Tcl_GetBytesFromObj(NULL,.... Add some more error-checking for invalid byte-arrays --- generic/tclBinary.c | 14 +++++++------- generic/tclConfig.c | 5 ++++- generic/tclExecute.c | 4 ++-- generic/tclIO.c | 8 ++++++-- generic/tclIORChan.c | 2 +- generic/tclLink.c | 4 +++- generic/tclStringObj.c | 6 +++--- generic/tclZipfs.c | 2 +- generic/tclZlib.c | 10 ++++++++-- 9 files changed, 35 insertions(+), 20 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 07c78a8..28cf31d 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -912,9 +912,9 @@ BinaryFormatCmd( goto badIndex; } if (count == BINARY_ALL) { - Tcl_Obj *copy = TclNarrowToBytes(objv[arg]); - (void)Tcl_GetByteArrayFromObj(copy, &count); - Tcl_DecrRefCount(copy); + if (Tcl_GetByteArrayFromObj(objv[arg], &count) == NULL) { + count = Tcl_GetCharLength(objv[arg]); + } } else if (count == BINARY_NOCOUNT) { count = 1; } @@ -2524,7 +2524,7 @@ BinaryDecodeHex( } TclNewObj(resultObj); - data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count); + data = Tcl_GetByteArrayFromObj(objv[objc - 1], &count); if (data == NULL) { pure = 0; data = (unsigned char *) Tcl_GetStringFromObj(objv[objc - 1], &count); @@ -2657,7 +2657,7 @@ BinaryEncode64( } break; case OPT_WRAPCHAR: - wrapchar = (const char *)Tcl_GetBytesFromObj(NULL, + wrapchar = (const char *)Tcl_GetByteArrayFromObj( objv[i + 1], &wrapcharlen); if (wrapchar == NULL) { purewrap = 0; @@ -2928,7 +2928,7 @@ BinaryDecodeUu( } TclNewObj(resultObj); - data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count); + data = Tcl_GetByteArrayFromObj(objv[objc - 1], &count); if (data == NULL) { pure = 0; data = (unsigned char *) Tcl_GetStringFromObj(objv[objc - 1], &count); @@ -3103,7 +3103,7 @@ BinaryDecode64( } TclNewObj(resultObj); - data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count); + data = Tcl_GetByteArrayFromObj(objv[objc - 1], &count); if (data == NULL) { pure = 0; data = (unsigned char *) Tcl_GetStringFromObj(objv[objc - 1], &count); diff --git a/generic/tclConfig.c b/generic/tclConfig.c index fcd991a..1ece31c 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -258,7 +258,10 @@ QueryConfigObjCmd( * Value is stored as-is in a byte array, see Bug [9b2e636361], * so we have to decode it first. */ - value = (const char *) Tcl_GetByteArrayFromObj(val, &n); + value = (const char *) Tcl_GetBytesFromObj(interp, val, &n); + if (value == NULL) { + return TCL_ERROR; + } value = Tcl_ExternalToUtfDString(venc, value, n, &conv); Tcl_SetObjResult(interp, Tcl_NewStringObj(value, Tcl_DStringLength(&conv))); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 926fd61..950cabe 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -5274,7 +5274,7 @@ TEBCresume( TclNewObj(objResultPtr); } else if (TclIsPureByteArray(valuePtr)) { objResultPtr = Tcl_NewByteArrayObj( - Tcl_GetBytesFromObj(NULL, valuePtr, (size_t *)NULL)+index, 1); + Tcl_GetByteArrayFromObj(valuePtr, (size_t *)NULL)+index, 1); } else if (valuePtr->bytes && slength == valuePtr->length) { objResultPtr = Tcl_NewStringObj((const char *) valuePtr->bytes+index, 1); @@ -5536,7 +5536,7 @@ TEBCresume( ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); match = TclUniCharMatch(ustring1, slength, ustring2, length2, nocase); - } else if (TclIsPureByteArray(valuePtr) && !nocase) { + } else if (TclIsPureByteArray(valuePtr) && TclIsPureByteArray(value2Ptr) && !nocase) { unsigned char *bytes1, *bytes2; size_t wlen1 = 0, wlen2 = 0; diff --git a/generic/tclIO.c b/generic/tclIO.c index 26db2f4..1541390 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4638,7 +4638,7 @@ Tcl_GetsObj( if ((statePtr->encoding == NULL) && ((statePtr->inputTranslation == TCL_TRANSLATE_LF) || (statePtr->inputTranslation == TCL_TRANSLATE_CR)) - && Tcl_GetBytesFromObj(NULL, objPtr, (size_t *)NULL) != NULL) { + && Tcl_GetByteArrayFromObj(objPtr, (size_t *)NULL) != NULL) { return TclGetsObjBinary(chan, objPtr); } @@ -5057,6 +5057,10 @@ TclGetsObjBinary( */ byteArray = Tcl_GetByteArrayFromObj(objPtr, &byteLen); + if (byteArray == NULL) { + Tcl_SetErrno(EILSEQ); + return -1; + } oldFlags = statePtr->inputEncodingFlags; oldRemoved = BUFFER_PADDING; oldLength = byteLen; @@ -5945,7 +5949,7 @@ DoReadChars( && (statePtr->inEofChar == '\0'); if (appendFlag) { - if (binaryMode && (NULL == Tcl_GetBytesFromObj(NULL, objPtr, (size_t *)NULL))) { + if (binaryMode && (NULL == Tcl_GetByteArrayFromObj(objPtr, (size_t *)NULL))) { binaryMode = 0; } } else { diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 67abca6..5bf7ea4 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -1387,7 +1387,7 @@ ReflectInput( if (bytev == NULL) { SetChannelErrorStr(rcPtr->chan, msg_read_nonbyte); - goto invalid; + goto invalid; } else if ((size_t)toRead < bytec) { SetChannelErrorStr(rcPtr->chan, msg_read_toomuch); goto invalid; diff --git a/generic/tclLink.c b/generic/tclLink.c index a0212ee..0088950 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -880,7 +880,9 @@ LinkTraceProc( case TCL_LINK_BINARY: value = (char *) Tcl_GetByteArrayFromObj(valueObj, &valueLength); - if (valueLength != linkPtr->bytes) { + if (value == NULL) { + return (char *) "invalid binary value"; + } else if (valueLength != linkPtr->bytes) { return (char *) "wrong size of binary value"; } if (linkPtr->flags & LINK_ALLOC_LAST) { diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 743f0ed..545a1e0 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -1471,7 +1471,7 @@ Tcl_AppendObjToObj( */ TclAppendBytesToByteArray(objPtr, - Tcl_GetBytesFromObj(NULL, appendObjPtr, (size_t *)NULL), lengthSrc); + Tcl_GetByteArrayFromObj(appendObjPtr, (size_t *)NULL), lengthSrc); return; } @@ -3000,7 +3000,7 @@ TclStringRepeat( done *= 2; } TclAppendBytesToByteArray(objResultPtr, - Tcl_GetBytesFromObj(NULL, objResultPtr, (size_t *)NULL), + Tcl_GetByteArrayFromObj(objResultPtr, (size_t *)NULL), (count - done) * length); } else if (unichar) { /* @@ -3884,7 +3884,7 @@ TclStringReverse( if (!inPlace || Tcl_IsShared(objPtr)) { objPtr = Tcl_NewByteArrayObj(NULL, numBytes); } - ReverseBytes(Tcl_GetBytesFromObj(NULL, objPtr, (size_t *)NULL), from, numBytes); + ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, (size_t *)NULL), from, numBytes); return objPtr; } diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index c7bf4f9..45f65fe 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -2409,7 +2409,7 @@ ZipFSMkKeyObjCmd( } passObj = Tcl_NewByteArrayObj(NULL, 264); - passBuf = Tcl_GetBytesFromObj(NULL, passObj, (size_t *)NULL); + passBuf = Tcl_GetByteArrayFromObj(passObj, (size_t *)NULL); while (len > 0) { int ch = pw[len - 1]; diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 1077b7c..5a6dbc4 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -597,6 +597,9 @@ SetInflateDictionary( size_t length = 0; unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length); + if (bytes == NULL) { + return Z_DATA_ERROR; + } return inflateSetDictionary(strm, bytes, length); } return Z_OK; @@ -611,6 +614,9 @@ SetDeflateDictionary( size_t length = 0; unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length); + if (bytes == NULL) { + return Z_DATA_ERROR; + } return deflateSetDictionary(strm, bytes, length); } return Z_OK; @@ -1154,7 +1160,7 @@ Tcl_ZlibStreamSetCompressionDictionary( { ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; - if (compressionDictionaryObj && (NULL == Tcl_GetBytesFromObj(NULL, + if (compressionDictionaryObj && (NULL == Tcl_GetByteArrayFromObj( compressionDictionaryObj, (size_t *)NULL))) { /* Missing or invalid compression dictionary */ compressionDictionaryObj = NULL; @@ -3722,7 +3728,7 @@ ZlibStackChannelTransform( if (compDictObj != NULL) { cd->compDictObj = Tcl_DuplicateObj(compDictObj); Tcl_IncrRefCount(cd->compDictObj); - Tcl_GetBytesFromObj(NULL, cd->compDictObj, (size_t *)NULL); + Tcl_GetByteArrayFromObj(cd->compDictObj, (size_t *)NULL); } if (format == TCL_ZLIB_FORMAT_RAW) { -- cgit v0.12 From ec4cf7a9950b3987b1736ee072b787c0b5494d7f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Nov 2022 16:16:53 +0000 Subject: Use some more TCL_INDEX_NONE and Tcl_Size --- macosx/tclMacOSXFCmd.c | 2 +- win/tclWinFCmd.c | 20 ++++++------ win/tclWinFile.c | 47 +++++++++++++-------------- win/tclWinLoad.c | 14 ++++---- win/tclWinPipe.c | 88 ++++++++++++++++++++++++++------------------------ win/tclWinSock.c | 8 ++--- 6 files changed, 90 insertions(+), 89 deletions(-) diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c index 02e57f1..60cb7f3 100644 --- a/macosx/tclMacOSXFCmd.c +++ b/macosx/tclMacOSXFCmd.c @@ -708,7 +708,7 @@ UpdateStringOfOSType( src[4] = '\0'; encoding = Tcl_GetEncoding(NULL, "macRoman"); - Tcl_ExternalToUtf(NULL, encoding, src, -1, /* flags */ 0, + Tcl_ExternalToUtf(NULL, encoding, src, TCL_INDEX_NONE, /* flags */ 0, /* statePtr */ NULL, dst, size, /* srcReadPtr */ NULL, /* dstWrotePtr */ &written, /* dstCharsPtr */ NULL); Tcl_FreeEncoding(encoding); diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 656db04..7f8cfd1 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -915,8 +915,8 @@ TclpObjCopyDirectory( Tcl_DStringInit(&srcString); Tcl_DStringInit(&dstString); - Tcl_UtfToWCharDString(Tcl_GetString(normSrcPtr), -1, &srcString); - Tcl_UtfToWCharDString(Tcl_GetString(normDestPtr), -1, &dstString); + Tcl_UtfToWCharDString(TclGetString(normSrcPtr), TCL_INDEX_NONE, &srcString); + Tcl_UtfToWCharDString(TclGetString(normDestPtr), TCL_INDEX_NONE, &dstString); ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds); @@ -989,7 +989,7 @@ TclpObjRemoveDirectory( return TCL_ERROR; } Tcl_DStringInit(&native); - Tcl_UtfToWCharDString(Tcl_GetString(normPtr), -1, &native); + Tcl_UtfToWCharDString(TclGetString(normPtr), TCL_INDEX_NONE, &native); ret = DoRemoveDirectory(&native, recursive, &ds); Tcl_DStringFree(&native); } else { @@ -1732,7 +1732,7 @@ ConvertFileNameFormat( } } - *attributePtrPtr = Tcl_FSJoinPath(splitPath, -1); + *attributePtrPtr = Tcl_FSJoinPath(splitPath, TCL_INDEX_NONE); if (splitPath != NULL) { /* @@ -2008,9 +2008,9 @@ TclpCreateTemporaryDirectory( goto useSystemTemp; } Tcl_DStringInit(&base); - Tcl_UtfToWCharDString(Tcl_GetString(dirObj), -1, &base); + Tcl_UtfToWCharDString(Tcl_GetString(dirObj), TCL_INDEX_NONE, &base); if (dirObj->bytes[dirObj->length - 1] != '\\') { - Tcl_UtfToWCharDString("\\", -1, &base); + Tcl_UtfToWCharDString("\\", TCL_INDEX_NONE, &base); } } else { useSystemTemp: @@ -2026,11 +2026,11 @@ TclpCreateTemporaryDirectory( #define SUFFIX_LENGTH 8 if (basenameObj) { - Tcl_UtfToWCharDString(Tcl_GetString(basenameObj), -1, &base); + Tcl_UtfToWCharDString(Tcl_GetString(basenameObj), TCL_INDEX_NONE, &base); } else { - Tcl_UtfToWCharDString(DEFAULT_TEMP_DIR_PREFIX, -1, &base); + Tcl_UtfToWCharDString(DEFAULT_TEMP_DIR_PREFIX, TCL_INDEX_NONE, &base); } - Tcl_UtfToWCharDString("_", -1, &base); + Tcl_UtfToWCharDString("_", TCL_INDEX_NONE, &base); /* * Now we keep on trying random suffixes until we get one that works @@ -2057,7 +2057,7 @@ TclpCreateTemporaryDirectory( tempbuf[i] = randChars[(int) (rand() % numRandChars)]; } Tcl_DStringSetLength(&base, baseLen); - Tcl_UtfToWCharDString(tempbuf, -1, &base); + Tcl_UtfToWCharDString(tempbuf, TCL_INDEX_NONE, &base); } while (!CreateDirectoryW((LPCWSTR) Tcl_DStringValue(&base), NULL) && (error = GetLastError()) == ERROR_ALREADY_EXISTS); diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 16c1d59..7e0a763 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -170,7 +170,7 @@ static int NativeWriteReparse(const WCHAR *LinkDirectory, static int NativeMatchType(int isDrive, DWORD attr, const WCHAR *nativeName, Tcl_GlobTypeData *types); static int WinIsDrive(const char *name, size_t nameLen); -static int WinIsReserved(const char *path); +static Tcl_Size WinIsReserved(const char *path); static Tcl_Obj * WinReadLink(const WCHAR *LinkSource); static Tcl_Obj * WinReadLinkDirectory(const WCHAR *LinkDirectory); static int WinLink(const WCHAR *LinkSource, @@ -938,9 +938,9 @@ TclpMatchInDirectory( * Match a single file directly. */ - int len; DWORD attr; WIN32_FILE_ATTRIBUTE_DATA data; + Tcl_Size len = 0; const char *str = TclGetStringFromObj(norm, &len); native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr); @@ -951,7 +951,7 @@ TclpMatchInDirectory( } attr = data.dwFileAttributes; - if (NativeMatchType(WinIsDrive(str,len), attr, native, types)) { + if (NativeMatchType(WinIsDrive(str, len), attr, native, types)) { Tcl_ListObjAppendElement(interp, resultPtr, pathPtr); } } @@ -962,7 +962,7 @@ TclpMatchInDirectory( WIN32_FIND_DATAW data; const char *dirName; /* UTF-8 dir name, later with pattern * appended. */ - int dirLength; + Tcl_Size dirLength; int matchSpecialDots; Tcl_DString ds; /* Native encoding of dir, also used * temporarily for other things. */ @@ -1030,7 +1030,7 @@ TclpMatchInDirectory( } Tcl_DStringInit(&ds); - native = Tcl_UtfToWCharDString(dirName, -1, &ds); + native = Tcl_UtfToWCharDString(dirName, TCL_INDEX_NONE, &ds); if ((types == NULL) || (types->type != TCL_GLOB_TYPE_DIR)) { handle = FindFirstFileW(native, &data); } else { @@ -1245,7 +1245,7 @@ WinIsDrive( * (not any trailing :). */ -static int +static Tcl_Size WinIsReserved( const char *path) /* Path in UTF-8 */ { @@ -1477,7 +1477,7 @@ TclpGetUserHome( Tcl_DStringFree(&ds); } else { Tcl_DStringInit(&ds); - wName = Tcl_UtfToWCharDString(domain + 1, -1, &ds); + wName = Tcl_UtfToWCharDString(domain + 1, TCL_INDEX_NONE, &ds); rc = NetGetDCName(NULL, wName, (LPBYTE *) &wDomain); Tcl_DStringFree(&ds); nameLen = domain - name; @@ -2362,9 +2362,9 @@ FromCTime( *---------------------------------------------------------------------- */ -ClientData +void * TclpGetNativeCwd( - ClientData clientData) + void *clientData) { WCHAR buffer[MAX_PATH]; @@ -2585,17 +2585,17 @@ TclpObjNormalizePath( */ if (isDrive) { - int len = WinIsReserved(path); + Tcl_Size len = WinIsReserved(path); if (len > 0) { /* * Actually it does exist - COM1, etc. */ - int i; + Tcl_Size i; for (i=0 ; i= 'a') { wc -= ('a' - 'A'); @@ -2604,7 +2604,7 @@ TclpObjNormalizePath( } Tcl_DStringAppend(&dsNorm, (const char *)nativePath, - (int)(sizeof(WCHAR) * len)); + sizeof(WCHAR) * len); lastValidPathEnd = currentPathEndPosition; } else if (nextCheckpoint == 0) { /* @@ -2820,8 +2820,8 @@ TclpObjNormalizePath( * Not the end of the string. */ - int len; Tcl_Obj *tmpPathPtr; + Tcl_Size len; tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), nextCheckpoint); @@ -2910,7 +2910,7 @@ TclWinVolumeRelativeNormalize( * also on drive C. */ - int cwdLen; + Tcl_Size cwdLen; const char *drive = TclGetStringFromObj(useThisCwd, &cwdLen); char drive_cur = path[0]; @@ -2980,11 +2980,11 @@ TclWinVolumeRelativeNormalize( Tcl_Obj * TclpNativeToNormalized( - ClientData clientData) + void *clientData) { Tcl_DString ds; Tcl_Obj *objPtr; - int len; + Tcl_Size len; char *copy, *p; Tcl_DStringInit(&ds); @@ -3040,14 +3040,14 @@ TclpNativeToNormalized( *--------------------------------------------------------------------------- */ -ClientData +void * TclNativeCreateNativeRep( Tcl_Obj *pathPtr) { WCHAR *nativePathPtr = NULL; const char *str; Tcl_Obj *validPathPtr; - size_t len; + Tcl_Size len; WCHAR *wp; if (TclFSCwdIsNative()) { @@ -3084,10 +3084,9 @@ TclNativeCreateNativeRep( Tcl_IncrRefCount(validPathPtr); } - str = Tcl_GetString(validPathPtr); - len = validPathPtr->length; + str = TclGetStringFromObj(validPathPtr, &len); - if (strlen(str) != len) { + if (strlen(str) != (size_t)len) { /* * String contains NUL-bytes. This is invalid. */ @@ -3202,9 +3201,9 @@ TclNativeCreateNativeRep( *--------------------------------------------------------------------------- */ -ClientData +void * TclNativeDupInternalRep( - ClientData clientData) + void *clientData) { char *copy; size_t len; diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index 2106343..df49337 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -98,7 +98,7 @@ TclpDlopen( ERROR_MOD_NOT_FOUND : GetLastError(); Tcl_DStringInit(&ds); - nativeName = Tcl_UtfToWCharDString(Tcl_GetString(pathPtr), -1, &ds); + nativeName = Tcl_UtfToWCharDString(TclGetString(pathPtr), TCL_INDEX_NONE, &ds); hInstance = LoadLibraryExW(nativeName, NULL, LOAD_WITH_ALTERED_SEARCH_PATH); Tcl_DStringFree(&ds); @@ -139,31 +139,31 @@ TclpDlopen( Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_NOT_FOUND", NULL); notFoundMsg: Tcl_AppendToObj(errMsg, "this library or a dependent library" - " could not be found in library path", -1); + " could not be found in library path", TCL_INDEX_NONE); break; case ERROR_PROC_NOT_FOUND: Tcl_SetErrorCode(interp, "WIN_LOAD", "PROC_NOT_FOUND", NULL); Tcl_AppendToObj(errMsg, "A function specified in the import" " table could not be resolved by the system. Windows" - " is not telling which one, I'm sorry.", -1); + " is not telling which one, I'm sorry.", TCL_INDEX_NONE); break; case ERROR_INVALID_DLL: Tcl_SetErrorCode(interp, "WIN_LOAD", "INVALID_DLL", NULL); Tcl_AppendToObj(errMsg, "this library or a dependent library" - " is damaged", -1); + " is damaged", TCL_INDEX_NONE); break; case ERROR_DLL_INIT_FAILED: Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", NULL); Tcl_AppendToObj(errMsg, "the library initialization" - " routine failed", -1); + " routine failed", TCL_INDEX_NONE); break; case ERROR_BAD_EXE_FORMAT: Tcl_SetErrorCode(interp, "WIN_LOAD", "BAD_EXE_FORMAT", NULL); - Tcl_AppendToObj(errMsg, "Bad exe format. Possibly a 32/64-bit mismatch.", -1); + Tcl_AppendToObj(errMsg, "Bad exe format. Possibly a 32/64-bit mismatch.", TCL_INDEX_NONE); break; default: Tcl_WinConvertError(lastError); - Tcl_AppendToObj(errMsg, Tcl_PosixError(interp), -1); + Tcl_AppendToObj(errMsg, Tcl_PosixError(interp), TCL_INDEX_NONE); } Tcl_SetObjResult(interp, errMsg); } diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 4a84038..6f9a8db 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -104,7 +104,7 @@ typedef struct PipeInfo { TclFile readFile; /* Output from pipe. */ TclFile writeFile; /* Input from pipe. */ TclFile errorFile; /* Error output from pipe. */ - int numPids; /* Number of processes attached to pipe. */ + Tcl_Size numPids; /* Number of processes attached to pipe. */ Tcl_Pid *pidPtr; /* Pids of attached processes. */ Tcl_ThreadId threadId; /* Thread to which events should be reported. * This value is used by the reader/writer @@ -171,28 +171,28 @@ typedef struct { static int ApplicationType(Tcl_Interp *interp, const char *fileName, char *fullName); -static void BuildCommandLine(const char *executable, int argc, +static void BuildCommandLine(const char *executable, Tcl_Size argc, const char **argv, Tcl_DString *linePtr); static BOOL HasConsole(void); -static int PipeBlockModeProc(ClientData instanceData, int mode); -static void PipeCheckProc(ClientData clientData, int flags); -static int PipeClose2Proc(ClientData instanceData, +static int PipeBlockModeProc(void *instanceData, int mode); +static void PipeCheckProc(void *clientData, int flags); +static int PipeClose2Proc(void *instanceData, Tcl_Interp *interp, int flags); static int PipeEventProc(Tcl_Event *evPtr, int flags); -static int PipeGetHandleProc(ClientData instanceData, - int direction, ClientData *handlePtr); +static int PipeGetHandleProc(void *instanceData, + int direction, void **handlePtr); static void PipeInit(void); -static int PipeInputProc(ClientData instanceData, char *buf, +static int PipeInputProc(void *instanceData, char *buf, int toRead, int *errorCode); -static int PipeOutputProc(ClientData instanceData, +static int PipeOutputProc(void *instanceData, const char *buf, int toWrite, int *errorCode); static DWORD WINAPI PipeReaderThread(LPVOID arg); -static void PipeSetupProc(ClientData clientData, int flags); -static void PipeWatchProc(ClientData instanceData, int mask); +static void PipeSetupProc(void *clientData, int flags); +static void PipeWatchProc(void *instanceData, int mask); static DWORD WINAPI PipeWriterThread(LPVOID arg); static int TempFileName(WCHAR name[MAX_PATH]); static int WaitForRead(PipeInfo *infoPtr, int blocking); -static void PipeThreadActionProc(ClientData instanceData, +static void PipeThreadActionProc(void *instanceData, int action); /* @@ -310,7 +310,7 @@ TclpFinalizePipes(void) void PipeSetupProc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { PipeInfo *infoPtr; @@ -363,7 +363,7 @@ PipeSetupProc( static void PipeCheckProc( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { PipeInfo *infoPtr; @@ -500,7 +500,7 @@ TclpMakeFile( HANDLE handle; if (Tcl_GetChannelHandle(channel, direction, - (ClientData *) &handle) == TCL_OK) { + (void **) &handle) == TCL_OK) { return TclWinMakeFile(handle); } else { return (TclFile) NULL; @@ -578,7 +578,7 @@ TclpOpenFile( } Tcl_DStringInit(&ds); - nativePath = Tcl_UtfToWCharDString(path, -1, &ds); + nativePath = Tcl_UtfToWCharDString(path, TCL_INDEX_NONE, &ds); /* * If the file is not being created, use the existing file attributes. @@ -851,7 +851,7 @@ TclpCloseFile( * Results: * Returns the process id for the child process. If the pid was not known * by Tcl, either because the pid was not created by Tcl or the child - * process has already been reaped, -1 is returned. + * process has already been reaped, TCL_INDEX_NONE is returned. * * Side effects: * None. @@ -859,7 +859,7 @@ TclpCloseFile( *-------------------------------------------------------------------------- */ -int +Tcl_Size TclpGetPid( Tcl_Pid pid) /* The HANDLE of the child process. */ { @@ -869,13 +869,13 @@ TclpGetPid( Tcl_MutexLock(&pipeMutex); for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { - if (infoPtr->dwProcessId == (DWORD) (size_t) pid) { + if (infoPtr->dwProcessId == (DWORD)(size_t)pid) { Tcl_MutexUnlock(&pipeMutex); return infoPtr->dwProcessId; } } Tcl_MutexUnlock(&pipeMutex); - return (unsigned long) -1; + return TCL_INDEX_NONE; } /* @@ -911,7 +911,7 @@ TclpCreateProcess( * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ - int argc, /* Number of arguments in following array. */ + Tcl_Size argc, /* Number of arguments in following array. */ const char **argv, /* Array of argument strings. argv[0] contains * the name of the executable converted to * native format (using the @@ -1536,13 +1536,14 @@ static void BuildCommandLine( const char *executable, /* Full path of executable (including * extension). Replacement for argv[0]. */ - int argc, /* Number of arguments. */ + Tcl_Size argc, /* Number of arguments. */ const char **argv, /* Argument strings in UTF. */ Tcl_DString *linePtr) /* Initialized Tcl_DString that receives the * command line (WCHAR). */ { const char *arg, *start, *special, *bspos; - int quote = 0, i; + int quote = 0; + Tcl_Size i; Tcl_DString ds; static const char specMetaChars[] = "&|^<>!()%"; /* Characters to enclose in quotes if unpaired @@ -1759,7 +1760,7 @@ TclpCreateCommandChannel( TclFile writeFile, /* If non-null, gives the file for writing. */ TclFile errorFile, /* If non-null, gives the file where errors * can be read. */ - int numPids, /* The number of pids in the pid array. */ + Tcl_Size numPids, /* The number of pids in the pid array. */ Tcl_Pid *pidPtr) /* An array of process identifiers. */ { char channelName[16 + TCL_INTEGER_SPACE]; @@ -1872,10 +1873,10 @@ Tcl_CreatePipe( return TCL_ERROR; } - *rchan = Tcl_MakeFileChannel((ClientData) readHandle, TCL_READABLE); + *rchan = Tcl_MakeFileChannel((void *) readHandle, TCL_READABLE); Tcl_RegisterChannel(interp, *rchan); - *wchan = Tcl_MakeFileChannel((ClientData) writeHandle, TCL_WRITABLE); + *wchan = Tcl_MakeFileChannel((void *) writeHandle, TCL_WRITABLE); Tcl_RegisterChannel(interp, *wchan); return TCL_OK; @@ -1906,7 +1907,7 @@ TclGetAndDetachPids( PipeInfo *pipePtr; const Tcl_ChannelType *chanTypePtr; Tcl_Obj *pidsObj; - int i; + Tcl_Size i; /* * Punt if the channel is not a command channel. @@ -1950,7 +1951,7 @@ TclGetAndDetachPids( static int PipeBlockModeProc( - ClientData instanceData, /* Instance data for channel. */ + void *instanceData, /* Instance data for channel. */ int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { @@ -1989,7 +1990,7 @@ PipeBlockModeProc( static int PipeClose2Proc( - ClientData instanceData, /* Pointer to PipeInfo structure. */ + void *instanceData, /* Pointer to PipeInfo structure. */ Tcl_Interp *interp, /* For error reporting. */ int flags) /* Flags that indicate which side to close. */ { @@ -2112,7 +2113,7 @@ PipeClose2Proc( if (pipePtr->errorFile) { WinFile *filePtr = (WinFile *) pipePtr->errorFile; - errChan = Tcl_MakeFileChannel((ClientData) filePtr->handle, + errChan = Tcl_MakeFileChannel((void *)filePtr->handle, TCL_READABLE); ckfree(filePtr); } else { @@ -2159,7 +2160,7 @@ PipeClose2Proc( static int PipeInputProc( - ClientData instanceData, /* Pipe state. */ + void *instanceData, /* Pipe state. */ char *buf, /* Where to store data read. */ int bufSize, /* How much space is available in the * buffer? */ @@ -2253,7 +2254,7 @@ PipeInputProc( static int PipeOutputProc( - ClientData instanceData, /* Pipe state. */ + void *instanceData, /* Pipe state. */ const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCode) /* Where to store error code. */ @@ -2435,7 +2436,7 @@ PipeEventProc( static void PipeWatchProc( - ClientData instanceData, /* Pipe state. */ + void *instanceData, /* Pipe state. */ int mask) /* What events to watch for, OR-ed combination * of TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ @@ -2497,21 +2498,21 @@ PipeWatchProc( static int PipeGetHandleProc( - ClientData instanceData, /* The pipe state. */ + void *instanceData, /* The pipe state. */ int direction, /* TCL_READABLE or TCL_WRITABLE */ - ClientData *handlePtr) /* Where to store the handle. */ + void **handlePtr) /* Where to store the handle. */ { PipeInfo *infoPtr = (PipeInfo *) instanceData; WinFile *filePtr; if (direction == TCL_READABLE && infoPtr->readFile) { filePtr = (WinFile*) infoPtr->readFile; - *handlePtr = (ClientData) filePtr->handle; + *handlePtr = (void *) filePtr->handle; return TCL_OK; } if (direction == TCL_WRITABLE && infoPtr->writeFile) { filePtr = (WinFile*) infoPtr->writeFile; - *handlePtr = (ClientData) filePtr->handle; + *handlePtr = (void *) filePtr->handle; return TCL_OK; } return TCL_ERROR; @@ -2742,7 +2743,7 @@ TclWinAddProcess( int Tcl_PidObjCmd( - TCL_UNUSED(ClientData), + TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument strings. */ @@ -2750,7 +2751,7 @@ Tcl_PidObjCmd( Tcl_Channel chan; const Tcl_ChannelType *chanTypePtr; PipeInfo *pipePtr; - int i; + Tcl_Size i; Tcl_Obj *resultPtr; if (objc > 2) { @@ -3136,7 +3137,7 @@ PipeWriterThread( static void PipeThreadActionProc( - ClientData instanceData, + void *instanceData, int action) { PipeInfo *infoPtr = (PipeInfo *) instanceData; @@ -3197,7 +3198,8 @@ TclpOpenTemporaryFile( char *namePtr; HANDLE handle; DWORD flags = FILE_ATTRIBUTE_TEMPORARY; - int length, counter, counter2; + Tcl_Size length; + int counter, counter2; Tcl_DString buf; if (!resultingNameObj) { @@ -3256,7 +3258,7 @@ TclpOpenTemporaryFile( TclDecrRefCount(tmpObj); } - return Tcl_MakeFileChannel((ClientData) handle, + return Tcl_MakeFileChannel((void *) handle, TCL_READABLE|TCL_WRITABLE); gotError: @@ -3280,7 +3282,7 @@ TclpOpenTemporaryFile( TclPipeThreadInfo * TclPipeThreadCreateTI( TclPipeThreadInfo **pipeTIPtr, - ClientData clientData, + void *clientData, HANDLE wakeEvent) { TclPipeThreadInfo *pipeTI; diff --git a/win/tclWinSock.c b/win/tclWinSock.c index ef01fa8..b349d0d 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -349,7 +349,7 @@ printaddrinfolist( void InitializeHostName( char **valuePtr, - unsigned int *lengthPtr, + TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr) { WCHAR wbuf[256]; @@ -1256,7 +1256,7 @@ TcpGetOptionProc( if (statePtr->connectError != 0) { Tcl_DStringAppend(dsPtr, - Tcl_ErrnoMsg(statePtr->connectError), -1); + Tcl_ErrnoMsg(statePtr->connectError), TCL_INDEX_NONE); statePtr->connectError = 0; } } else { @@ -1291,7 +1291,7 @@ TcpGetOptionProc( if (err) { Tcl_WinConvertError(err); - Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1); + Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), TCL_INDEX_NONE); } } } @@ -1302,7 +1302,7 @@ TcpGetOptionProc( (strncmp(optionName, "-connecting", len) == 0)) { Tcl_DStringAppend(dsPtr, GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING) - ? "1" : "0", -1); + ? "1" : "0", TCL_INDEX_NONE); return TCL_OK; } -- cgit v0.12 From a4ac44fccc008eb38b43511905b3797f9b0274df Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Nov 2022 17:43:12 +0000 Subject: Fix gcc warning, seen on Ubuntu with select notifier --- unix/tclSelectNotfy.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/unix/tclSelectNotfy.c b/unix/tclSelectNotfy.c index 732e4c9..fc77e77 100644 --- a/unix/tclSelectNotfy.c +++ b/unix/tclSelectNotfy.c @@ -938,7 +938,10 @@ TclAsyncNotifier( *flagPtr = value; if (!asyncPending) { asyncPending = 1; - write(triggerPipe, "S", 1); + if (write(triggerPipe, "S", 1) != 1) { + asyncPending = 0; + return 0; + }; } return 1; } -- cgit v0.12 From 21920649b543f44f48eea83bd8d781282ce05dbf Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 24 Nov 2022 21:04:48 +0000 Subject: Move Tcl_Size definition earlier in tcl.h --- generic/tcl.h | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 580397d..68d6719 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -311,6 +311,12 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; #define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) #define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) +#if TCL_MAJOR_VERSION > 8 +typedef size_t Tcl_Size; +#else +typedef int Tcl_Size; +#endif + #ifdef _WIN32 # if TCL_MAJOR_VERSION > 8 typedef struct __stat64 Tcl_StatBuf; @@ -668,12 +674,6 @@ typedef union Tcl_ObjInternalRep { /* The internal representation: */ * An object stores a value as either a string, some internal representation, * or both. */ -#if TCL_MAJOR_VERSION > 8 -typedef size_t Tcl_Size; -#else -typedef int Tcl_Size; -#endif - typedef struct Tcl_Obj { Tcl_Size refCount; /* When 0 the object will be freed. */ @@ -688,7 +688,7 @@ typedef struct Tcl_Obj { * should use Tcl_GetStringFromObj or * Tcl_GetString to get a pointer to the byte * array as a readonly value. */ - Tcl_Size length; /* The number of bytes at *bytes, not + Tcl_Size length; /* The number of bytes at *bytes, not * including the terminating null. */ const Tcl_ObjType *typePtr; /* Denotes the object's type. Always * corresponds to the type of the object's -- cgit v0.12 From 191fa0458a0d2c822b73cbfb8c63752461ac9ce5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 25 Nov 2022 08:29:06 +0000 Subject: Handle closeProc == NULL the same as closeProc == TCL_CLOSE2PROC in stead of panicing. Backported from 8.7 (undocumented feature) --- generic/tclIO.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index d228d50..85ff39b 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -358,7 +358,7 @@ ChanClose( Channel *chanPtr, Tcl_Interp *interp) { - if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) { + if ((chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) && (chanPtr->typePtr->closeProc != NULL)) { return chanPtr->typePtr->closeProc(chanPtr->instanceData, interp); } else { return chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, 0); @@ -1602,8 +1602,8 @@ Tcl_CreateChannel( assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc *)); assert(typePtr->typeName != NULL); - if (NULL == typePtr->closeProc) { - Tcl_Panic("channel type %s must define closeProc", typePtr->typeName); + if (((NULL == typePtr->closeProc) || (TCL_CLOSE2PROC == typePtr->closeProc)) && (typePtr->close2Proc == NULL)) { + Tcl_Panic("channel type %s must define closeProc or close2Proc", typePtr->typeName); } if ((TCL_READABLE & mask) && (NULL == typePtr->inputProc)) { Tcl_Panic("channel type %s must define inputProc when used for reader channel", typePtr->typeName); @@ -3460,9 +3460,9 @@ Tcl_Close( * it anymore and this will help avoid deadlocks on some channel types. */ - if (chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) { - result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, - TCL_CLOSE_READ); + if ((chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) || (chanPtr->typePtr->closeProc == NULL)) { + /* If this half-close gives a EINVAL or ENOTCONN, just continue the full close */ + result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, TCL_CLOSE_READ); if ((result == EINVAL) || result == ENOTCONN) { result = 0; } -- cgit v0.12 From 66e2117d2071a5ffe2c16ef8ff2ff39d6172b05b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 25 Nov 2022 10:01:00 +0000 Subject: Unbreak Windows build. More int -> size_t, being able to handle longer strings --- generic/tclArithSeries.c | 6 +++--- generic/tclBasic.c | 4 ++-- generic/tclZipfs.c | 43 +++++++++++++++++++++++-------------------- win/tclWinFile.c | 2 +- 4 files changed, 29 insertions(+), 26 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 3fa9792..befe19e 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -578,14 +578,14 @@ UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr) Tcl_Obj *elemObj; Tcl_WideInt i; Tcl_WideInt length = 0; - int slen; + size_t slen; /* * Pass 1: estimate space. */ for (i = 0; i < arithSeriesRepPtr->len; i++) { TclArithSeriesObjIndex(arithSeriesPtr, i, &elemObj); - elem = TclGetStringFromObj(elemObj, &slen); + elem = Tcl_GetStringFromObj(elemObj, &slen); Tcl_DecrRefCount(elemObj); slen += 1; /* + 1 is for the space or the nul-term */ length += slen; @@ -598,7 +598,7 @@ UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr) p = Tcl_InitStringRep(arithSeriesPtr, NULL, length); for (i = 0; i < arithSeriesRepPtr->len; i++) { TclArithSeriesObjIndex(arithSeriesPtr, i, &elemObj); - elem = TclGetStringFromObj(elemObj, &slen); + elem = Tcl_GetStringFromObj(elemObj, &slen); strcpy(p, elem); p[slen] = ' '; p += slen+1; diff --git a/generic/tclBasic.c b/generic/tclBasic.c index cd1bfc8..52c35fc 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -621,8 +621,8 @@ buildInfoObjCmd2( return TCL_ERROR; } if (objc == 2) { - int len; - const char *arg = TclGetStringFromObj(objv[1], &len); + size_t len; + const char *arg = Tcl_GetStringFromObj(objv[1], &len); if (len == 7 && !strcmp(arg, "version")) { char buf[80]; const char *p = strchr((char *)clientData, '.'); diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 45f65fe..93ff054 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -669,11 +669,11 @@ ToDosDate( *------------------------------------------------------------------------- */ -static inline int +static inline size_t CountSlashes( const char *string) { - int count = 0; + size_t count = 0; const char *p = string; while (*p != '\0') { @@ -2391,7 +2391,7 @@ ZipFSMkKeyObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int len, i = 0; + size_t len, i = 0; const char *pw; Tcl_Obj *passObj; unsigned char *passBuf; @@ -2400,7 +2400,7 @@ ZipFSMkKeyObjCmd( Tcl_WrongNumArgs(interp, 1, objv, "password"); return TCL_ERROR; } - pw = TclGetStringFromObj(objv[1], &len); + pw = Tcl_GetStringFromObj(objv[1], &len); if (len == 0) { return TCL_OK; } @@ -2918,16 +2918,16 @@ ComputeNameInArchive( * archive */ const char *strip, /* A prefix to strip; may be NULL if no * stripping need be done. */ - int slen) /* The length of the prefix; must be 0 if no + size_t slen) /* The length of the prefix; must be 0 if no * stripping need be done. */ { const char *name; - int len; + size_t len; if (directNameObj) { name = TclGetString(directNameObj); } else { - name = TclGetStringFromObj(pathObj, &len); + name = Tcl_GetStringFromObj(pathObj, &len); if (slen > 0) { if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { /* @@ -2990,8 +2990,8 @@ ZipFSMkZipOrImg( * there's no password protection. */ { Tcl_Channel out; - int pwlen = 0, slen = 0, count, ret = TCL_ERROR; - size_t lobjc, len, i = 0; + int pwlen = 0, count, ret = TCL_ERROR; + size_t slen = 0, lobjc, len, i = 0; long long directoryStartOffset; /* The overall file offset of the start of the * central directory. */ @@ -3169,7 +3169,7 @@ ZipFSMkZipOrImg( Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS); if (mappingList == NULL && stripPrefix != NULL) { - strip = TclGetStringFromObj(stripPrefix, &slen); + strip = Tcl_GetStringFromObj(stripPrefix, &slen); if (!slen) { strip = NULL; } @@ -4998,7 +4998,8 @@ ZipFSMatchInDirectoryProc( Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); - int scnt, l, dirOnly = -1, prefixLen, strip = 0, mounts = 0, len; + int scnt, l, dirOnly = -1, strip = 0, mounts = 0; + size_t prefixLen, len; char *pat, *prefix, *path; Tcl_DString dsPref, *prefixBuf = NULL; @@ -5014,13 +5015,13 @@ ZipFSMatchInDirectoryProc( * The prefix that gets prepended to results. */ - prefix = TclGetStringFromObj(pathPtr, &prefixLen); + prefix = Tcl_GetStringFromObj(pathPtr, &prefixLen); /* * The (normalized) path we're searching. */ - path = TclGetStringFromObj(normPathPtr, &len); + path = Tcl_GetStringFromObj(normPathPtr, &len); Tcl_DStringInit(&dsPref); if (strcmp(prefix, path) == 0) { @@ -5134,9 +5135,9 @@ ZipFSMatchMountPoints( { Tcl_HashEntry *hPtr; Tcl_HashSearch search; - int l, normLength; - const char *path = TclGetStringFromObj(normPathPtr, &normLength); - size_t len = (size_t) normLength; + size_t l, normLength; + const char *path = Tcl_GetStringFromObj(normPathPtr, &normLength); + size_t len = normLength; if (len < 1) { /* @@ -5215,14 +5216,15 @@ ZipFSPathInFilesystemProc( { Tcl_HashEntry *hPtr; Tcl_HashSearch search; - int ret = -1, len; + int ret = -1; + size_t len; char *path; pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (!pathPtr) { return -1; } - path = TclGetStringFromObj(pathPtr, &len); + path = Tcl_GetStringFromObj(pathPtr, &len); if (strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) != 0) { return -1; } @@ -5362,7 +5364,8 @@ ZipFSFileAttrsGetProc( Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef) { - int len, ret = TCL_OK; + size_t len; + int ret = TCL_OK; char *path; ZipEntry *z; @@ -5370,7 +5373,7 @@ ZipFSFileAttrsGetProc( if (!pathPtr) { return -1; } - path = TclGetStringFromObj(pathPtr, &len); + path = Tcl_GetStringFromObj(pathPtr, &len); ReadLock(); z = ZipFSLookup(path); if (!z) { diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 58ec311..30ca622 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -3065,7 +3065,7 @@ TclNativeCreateNativeRep( Tcl_IncrRefCount(validPathPtr); } - str = TclGetStringFromObj(validPathPtr, &len); + str = Tcl_GetStringFromObj(validPathPtr, &len); if (strlen(str) != (size_t)len) { /* -- cgit v0.12 From 73116e2c54973fea6efc412b979d78999df3a08a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 25 Nov 2022 10:12:32 +0000 Subject: one more int -> size_t --- generic/tclZipfs.c | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 93ff054..48bcd48 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -1515,7 +1515,7 @@ static inline int IsPasswordValid( Tcl_Interp *interp, const char *passwd, - int pwlen) + size_t pwlen) { if ((pwlen > 255) || strchr(passwd, 0xff)) { ZIPFS_ERROR(interp, "illegal password"); @@ -1552,8 +1552,8 @@ ZipFSCatalogFilesystem( * the ZIP is unprotected. */ const char *zipname) /* Path to ZIP file to build a catalog of. */ { - int pwlen, isNew; - size_t i; + int isNew; + size_t i, pwlen; ZipFile *zf0; ZipEntry *z; Tcl_HashEntry *hPtr; @@ -2990,8 +2990,8 @@ ZipFSMkZipOrImg( * there's no password protection. */ { Tcl_Channel out; - int pwlen = 0, count, ret = TCL_ERROR; - size_t slen = 0, lobjc, len, i = 0; + int count, ret = TCL_ERROR; + size_t pwlen = 0, slen = 0, lobjc, len, i = 0; long long directoryStartOffset; /* The overall file offset of the start of the * central directory. */ @@ -3013,13 +3013,12 @@ ZipFSMkZipOrImg( passBuf[0] = 0; if (passwordObj != NULL) { - pw = TclGetStringFromObj(passwordObj, &pwlen); + pw = Tcl_GetStringFromObj(passwordObj, &pwlen); if (IsPasswordValid(interp, pw, pwlen) != TCL_OK) { return TCL_ERROR; } - if (pwlen <= 0) { + if (pwlen == 0) { pw = NULL; - pwlen = 0; } } if (dirRoot != NULL) { -- cgit v0.12 From b816a585c00c97feca1b4516769ccf2769a58e02 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 25 Nov 2022 16:11:38 +0000 Subject: Tcl_NewDoubleObj -> TclNewDoubleObj and Tcl_NewWideIntObj -> TclNewIntObj (and similar). Gives more info when debugging --- generic/tclArithSeries.c | 7 ++++--- generic/tclClock.c | 12 +++++++++--- generic/tclCmdIL.c | 6 +++--- generic/tclCmdMZ.c | 8 ++++---- generic/tclCompExpr.c | 2 +- generic/tclInt.decls | 2 +- generic/tclIntDecls.h | 6 +++--- generic/tclLink.c | 7 +++---- generic/tclListObj.c | 14 ++++---------- generic/tclScan.c | 4 ++-- 10 files changed, 34 insertions(+), 34 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 5c4e5a5..40f34b5 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -390,9 +390,9 @@ TclArithSeriesObjStep( } arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesPtr); if (arithSeriesRepPtr->isDouble) { - *stepObj = Tcl_NewDoubleObj(((ArithSeriesDbl*)(arithSeriesRepPtr))->step); + TclNewDoubleObj(*stepObj, ((ArithSeriesDbl*)(arithSeriesRepPtr))->step); } else { - *stepObj = Tcl_NewWideIntObj(arithSeriesRepPtr->step); + TclNewIntObj(*stepObj, arithSeriesRepPtr->step); } return TCL_OK; } @@ -956,7 +956,8 @@ TclArithSeriesObjReverse( if (Tcl_IsShared(arithSeriesPtr) || ((arithSeriesPtr->refCount > 1))) { - Tcl_Obj *lenObj = Tcl_NewWideIntObj(len); + Tcl_Obj *lenObj; + TclNewIntObj(lenObj, len); if (TclNewArithSeriesObj(interp, &resultObj, isDouble, startObj, endObj, stepObj, lenObj) != TCL_OK) { resultObj = NULL; diff --git a/generic/tclClock.c b/generic/tclClock.c index a9ba70c..d1f08c1 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -14,6 +14,7 @@ */ #include "tclInt.h" +#include "tclTomMath.h" /* * Windows has mktime. The configurators do not check. @@ -1804,14 +1805,16 @@ ClockMillisecondsObjCmd( Tcl_Obj *const *objv) /* Parameter values */ { Tcl_Time now; + Tcl_Obj *timeObj; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } Tcl_GetTime(&now); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) - now.sec * 1000 + now.usec / 1000)); + TclNewUIntObj(timeObj, (Tcl_WideUInt) + now.sec * 1000 + now.usec / 1000); + Tcl_SetObjResult(interp, timeObj); return TCL_OK; } @@ -1992,13 +1995,16 @@ ClockSecondsObjCmd( Tcl_Obj *const *objv) /* Parameter values */ { Tcl_Time now; + Tcl_Obj *timeObj; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } Tcl_GetTime(&now); - Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) now.sec)); + TclNewUIntObj(timeObj, (Tcl_WideUInt)now.sec); + + Tcl_SetObjResult(interp, timeObj); return TCL_OK; } diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 4b7bd48..e2493c4 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -3607,7 +3607,7 @@ Tcl_LsearchObjCmd( if (allMatches || inlineReturn) { Tcl_ResetResult(interp); } else { - TclNewIndexObj(itemPtr, TCL_INDEX_NONE); + TclNewIntObj(itemPtr, -1); Tcl_SetObjResult(interp, itemPtr); } goto done; @@ -4103,10 +4103,10 @@ SequenceIdentifyArgument( exprValueObj = argPtr; } else { if (floor(dvalue) == dvalue) { - exprValueObj = Tcl_NewWideIntObj(value); + TclNewIntObj(exprValueObj, value); keyword = TCL_NUMBER_INT; } else { - exprValueObj = Tcl_NewDoubleObj(dvalue); + TclNewDoubleObj(exprValueObj, dvalue); keyword = TCL_NUMBER_DOUBLE; } } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index b063689..57541f9 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3775,7 +3775,7 @@ TclNRSwitchObjCmd( TclNewIndexObj(rangeObjAry[0], info.matches[j].start); TclNewIndexObj(rangeObjAry[1], info.matches[j].end-1); } else { - TclNewIndexObj(rangeObjAry[1], TCL_INDEX_NONE); + TclNewIntObj(rangeObjAry[1], -1); rangeObjAry[0] = rangeObjAry[1]; } @@ -4099,9 +4099,9 @@ Tcl_TimeObjCmd( * Use int obj since we know time is not fractional. [Bug 1202178] */ - objs[0] = Tcl_NewWideIntObj((count <= 0) ? 0 : (Tcl_WideInt)totalMicroSec); + TclNewIntObj(objs[0], (count <= 0) ? 0 : (Tcl_WideInt)totalMicroSec); } else { - objs[0] = Tcl_NewDoubleObj(totalMicroSec/count); + TclNewDoubleObj(objs[0], totalMicroSec/count); } /* @@ -4586,7 +4586,7 @@ Tcl_TimeRateObjCmd( if (measureOverhead > ((double) usec) / count) { measureOverhead = ((double) usec) / count; } - objs[0] = Tcl_NewDoubleObj(measureOverhead); + TclNewDoubleObj(objs[0], measureOverhead); TclNewLiteralStringObj(objs[1], "\xC2\xB5s/#-overhead"); /* mics */ objs += 2; } diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 06b4b05..ded32aa 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2787,7 +2787,7 @@ TclVariadicOpCmd( nodes[1].p.parent = 0; } else { if (lexeme == DIVIDE) { - litObjv[0] = Tcl_NewDoubleObj(1.0); + TclNewDoubleObj(litObjv[0], 1.0); } else { TclNewIntObj(litObjv[0], occdPtr->i.identity); } diff --git a/generic/tclInt.decls b/generic/tclInt.decls index c0e0e06..b3e352a 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -701,7 +701,7 @@ declare 258 { # TIP 625: for unit testing - create list objects with span declare 260 { - Tcl_Obj *TclListTestObj(int length, int leadingSpace, int endSpace) + Tcl_Obj *TclListTestObj(Tcl_Size length, Tcl_Size leadingSpace, Tcl_Size endSpace) } # TIP 625: for unit testing - check list invariants diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 3da8567..4c8d897 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -660,8 +660,8 @@ EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* Slot 259 is reserved */ /* 260 */ -EXTERN Tcl_Obj * TclListTestObj(int length, int leadingSpace, - int endSpace); +EXTERN Tcl_Obj * TclListTestObj(Tcl_Size length, + Tcl_Size leadingSpace, Tcl_Size endSpace); /* 261 */ EXTERN void TclListObjValidate(Tcl_Interp *interp, Tcl_Obj *listObj); @@ -930,7 +930,7 @@ typedef struct TclIntStubs { void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 257 */ Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */ void (*reserved259)(void); - Tcl_Obj * (*tclListTestObj) (int length, int leadingSpace, int endSpace); /* 260 */ + Tcl_Obj * (*tclListTestObj) (Tcl_Size length, Tcl_Size leadingSpace, Tcl_Size endSpace); /* 260 */ void (*tclListObjValidate) (Tcl_Interp *interp, Tcl_Obj *listObj); /* 261 */ } TclIntStubs; diff --git a/generic/tclLink.c b/generic/tclLink.c index cd2c731..f478a00 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -1282,7 +1282,7 @@ ObjValue( memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.dPtr[i]); + TclNewDoubleObj(objv[i], linkPtr->lastValue.dPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1401,7 +1401,7 @@ ObjValue( memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.fPtr[i]); + TclNewDoubleObj(objv[i], linkPtr->lastValue.fPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); @@ -1414,8 +1414,7 @@ ObjValue( memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { - TclNewUIntObj(objv[i], - linkPtr->lastValue.uwPtr[i]); + TclNewUIntObj(objv[i], linkPtr->lastValue.uwPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); ckfree(objv); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 8ee0f48..486baa2 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -11,6 +11,7 @@ #include #include "tclInt.h" +#include "tclTomMath.h" #include "tclArithSeries.h" /* @@ -3514,15 +3515,8 @@ UpdateStringOfList( *------------------------------------------------------------------------ */ Tcl_Obj * -TclListTestObj (int length, int leadingSpace, int endSpace) +TclListTestObj(Tcl_Size length, Tcl_Size leadingSpace, Tcl_Size endSpace) { - if (length < 0) - length = 0; - if (leadingSpace < 0) - leadingSpace = 0; - if (endSpace < 0) - endSpace = 0; - ListRep listRep; Tcl_Size capacity; Tcl_Obj *listObj; @@ -3538,9 +3532,9 @@ TclListTestObj (int length, int leadingSpace, int endSpace) ListRepInit(capacity, NULL, 0, &listRep); ListStore *storePtr = listRep.storePtr; - int i; + Tcl_Size i; for (i = 0; i < length; ++i) { - storePtr->slots[i + leadingSpace] = Tcl_NewIntObj(i); + TclNewUIntObj(storePtr->slots[i + leadingSpace], i); Tcl_IncrRefCount(storePtr->slots[i + leadingSpace]); } storePtr->firstUsed = leadingSpace; diff --git a/generic/tclScan.c b/generic/tclScan.c index 6bc914d..c200fa0 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -993,7 +993,7 @@ Tcl_ScanObjCmd( * Scan a floating point number */ - objPtr = Tcl_NewDoubleObj(0.0); + TclNewDoubleObj(objPtr, 0.0); Tcl_IncrRefCount(objPtr); if (width == 0) { width = ~0; @@ -1090,7 +1090,7 @@ Tcl_ScanObjCmd( if (code == TCL_OK) { if (underflow && (nconversions == 0)) { if (numVars) { - TclNewIndexObj(objPtr, TCL_INDEX_NONE); + TclNewIntObj(objPtr, -1); } else { if (objPtr) { Tcl_SetListObj(objPtr, 0, NULL); -- cgit v0.12 From ba490472b58358406e7f04356e4e8a076644d9c6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 25 Nov 2022 22:40:47 +0000 Subject: Remove "knownBug" constraint: no longer necessary --- tests/io.test | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/io.test b/tests/io.test index fdb4be4..9dd37f3 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9053,8 +9053,8 @@ test io-75.6 {multibyte encoding error read results in raw bytes} -setup { puts -nonewline $f "A\xC0\x40" flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -} -constraints knownBug -body { + fconfigure $f -encoding utf-8 -buffering none -strict 1 +} -body { set d [read $f] binary scan $d H* hd set hd @@ -9113,7 +9113,7 @@ test io-75.9 {shiftjis encoding error read results in raw bytes} -setup { flush $f seek $f 0 fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf -} -constraints knownBug -body { +} -body { set d [read $f] binary scan $d H* hd set hd -- cgit v0.12 From 513b2d50314fa22ef6df699c698ee0f05b7f59b5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 26 Nov 2022 23:57:26 +0000 Subject: HAS_ABSTRACTLIST_PROC --- generic/tclArithSeries.c | 3 ++- generic/tclInt.h | 18 ++++++++++-------- generic/tclListObj.c | 23 +++++++++++------------ generic/tclObj.c | 20 ++++++++++++-------- generic/tclUtil.c | 5 +++-- 5 files changed, 38 insertions(+), 31 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 34c0dd1..70bbb1b 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -76,8 +76,9 @@ const TclObjTypeWithAbstractList tclArithSeriesType = { DupArithSeriesInternalRep, /* dupIntRepProc */ UpdateStringOfArithSeries, /* updateStringProc */ SetArithSeriesFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0_1}, + TCL_OBJTYPE_V0_1( TclArithSeriesObjLength + ) }; /* diff --git a/generic/tclInt.h b/generic/tclInt.h index a58c401..0ff0d8e 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1076,14 +1076,6 @@ typedef struct ActiveInterpTrace { * in reverse order. */ } ActiveInterpTrace; - -#define TCL_OBJTYPE_V0_1 ((size_t)1) /* For internal core use only */ - -typedef struct { /* For internal core use only */ - Tcl_ObjType objType; - unsigned long long (*lengthProc)(Tcl_Obj *obj); -} TclObjTypeWithAbstractList; - /* * Flag values designating types of execution traces. See tclTrace.c for * related flag values. @@ -1099,6 +1091,16 @@ typedef struct { /* For internal core use only */ #define TCL_TRACE_ENTER_EXEC 1 #define TCL_TRACE_LEAVE_EXEC 2 +typedef struct { /* For internal core use only */ + Tcl_ObjType objType; + unsigned long long (*lengthProc)(Tcl_Obj *obj); +} TclObjTypeWithAbstractList; +#define TCL_OBJTYPE_V0_1(lengthProc) (sizeof(TclObjTypeWithAbstractList)) \ + }, lengthProc /* For internal core use only */ +#define HAS_ABSTRACTLIST_PROC(objPtr, proc) (objPtr->typePtr \ + && (objPtr->typePtr->version > offsetof(TclObjTypeWithAbstractList, proc)) \ + && (((const TclObjTypeWithAbstractList *)objPtr->typePtr)->proc)) + /* * The structure below defines an entry in the assocData hash table which is * associated with an interpreter. The entry contains a pointer to a function diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 4a5b3ae..565872e 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -158,8 +158,9 @@ const TclObjTypeWithAbstractList tclListType = { DupListInternalRep, /* dupIntRepProc */ UpdateStringOfList, /* updateStringProc */ SetListFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0_1}, - ListLength + TCL_OBJTYPE_V0_1( + ListLength + ) }; /* Macros to manipulate the List internal rep */ @@ -1994,19 +1995,17 @@ Tcl_ListObjLength( Tcl_Obj *listObj, /* List object whose #elements to return. */ Tcl_Size *lenPtr) /* The resulting int is stored here. */ { - if (listObj->typePtr && (listObj->typePtr->version == TCL_OBJTYPE_V0_1)) { + if (HAS_ABSTRACTLIST_PROC(listObj, lengthProc)) { const TclObjTypeWithAbstractList *objType = (const TclObjTypeWithAbstractList *)listObj->typePtr; - if (objType->lengthProc) { - unsigned long long len = objType->lengthProc(listObj); - if (len >= TCL_INDEX_NONE) { - if (interp) { - Tcl_AppendResult(interp, "List too large"); - } - return TCL_ERROR; + unsigned long long len = objType->lengthProc(listObj); + if (len >= TCL_INDEX_NONE) { + if (interp) { + Tcl_AppendResult(interp, "List too large"); } - *lenPtr = len; - return TCL_OK; + return TCL_ERROR; } + *lenPtr = len; + return TCL_OK; } /* diff --git a/generic/tclObj.c b/generic/tclObj.c index 5e3f4f1..ca7861f 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -233,8 +233,9 @@ const TclObjTypeWithAbstractList tclBooleanType= { NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ TclSetBooleanFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0_1}, - LengthOne + TCL_OBJTYPE_V0_1( + LengthOne + ) }; const TclObjTypeWithAbstractList tclDoubleType= { {"double", /* name */ @@ -242,8 +243,9 @@ const TclObjTypeWithAbstractList tclDoubleType= { NULL, /* dupIntRepProc */ UpdateStringOfDouble, /* updateStringProc */ SetDoubleFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0_1}, - LengthOne + TCL_OBJTYPE_V0_1( + LengthOne + ) }; const TclObjTypeWithAbstractList tclIntType = { {"int", /* name */ @@ -251,8 +253,9 @@ const TclObjTypeWithAbstractList tclIntType = { NULL, /* dupIntRepProc */ UpdateStringOfInt, /* updateStringProc */ SetIntFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0_1}, - LengthOne + TCL_OBJTYPE_V0_1( + LengthOne + ) }; const TclObjTypeWithAbstractList tclBignumType = { {"bignum", /* name */ @@ -260,8 +263,9 @@ const TclObjTypeWithAbstractList tclBignumType = { DupBignum, /* dupIntRepProc */ UpdateStringOfBignum, /* updateStringProc */ NULL, /* setFromAnyProc */ - TCL_OBJTYPE_V0_1}, - LengthOne + TCL_OBJTYPE_V0_1( + LengthOne + ) }; /* diff --git a/generic/tclUtil.c b/generic/tclUtil.c index b23d134..58fb1e4 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -130,8 +130,9 @@ static const TclObjTypeWithAbstractList endOffsetType = { NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ - TCL_OBJTYPE_V0_1}, - LengthOne + TCL_OBJTYPE_V0_1( + LengthOne + ) }; /* -- cgit v0.12 From 82fb7b1d551b7e74efa4ee9cc814ef74fab5332c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 27 Nov 2022 23:37:32 +0000 Subject: size_t result for lengthProc. More usage of Tcl_GetWideUIntFromObj --- generic/tclArithSeries.c | 2 +- generic/tclArithSeries.h | 2 +- generic/tclCmdIL.c | 4 +++- generic/tclExecute.c | 2 +- generic/tclInt.h | 2 +- generic/tclListObj.c | 6 +++--- generic/tclObj.c | 2 +- generic/tclTest.c | 32 ++++++++++++++++++++++++-------- generic/tclUtil.c | 2 +- tests/link.test | 2 +- 10 files changed, 37 insertions(+), 19 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 70bbb1b..1d6291d 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -462,7 +462,7 @@ TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **ele * *---------------------------------------------------------------------- */ -unsigned long long TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr) +size_t TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr) { ArithSeries *arithSeriesRepPtr = (ArithSeries*) arithSeriesPtr->internalRep.twoPtrValue.ptr1; diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h index 8392a57..ccd050f 100644 --- a/generic/tclArithSeries.h +++ b/generic/tclArithSeries.h @@ -39,7 +39,7 @@ MODULE_SCOPE int TclArithSeriesObjStep(Tcl_Obj *arithSeriesPtr, Tcl_Obj **stepObj); MODULE_SCOPE int TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **elementObj); -MODULE_SCOPE unsigned long long TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); +MODULE_SCOPE size_t TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Interp *interp, Tcl_Obj *arithSeriesPtr, Tcl_Size fromIdx, Tcl_Size toIdx); MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Interp *interp, diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 612764d..d5c7fc8 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2575,6 +2575,7 @@ Tcl_LlengthObjCmd( { size_t listLen; int result; + Tcl_Obj *objPtr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "list"); @@ -2591,7 +2592,8 @@ Tcl_LlengthObjCmd( * length. */ - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(listLen)); + TclNewUIntObj(objPtr, listLen); + Tcl_SetObjResult(interp, objPtr); return TCL_OK; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 9049c0a..c1a2bfd 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4649,7 +4649,7 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - TclNewIntObj(objResultPtr, length); + TclNewUIntObj(objResultPtr, length); TRACE_APPEND(("%" TCL_Z_MODIFIER "u\n", length)); NEXT_INST_F(1, 1, 1); diff --git a/generic/tclInt.h b/generic/tclInt.h index 0ff0d8e..b5fc48e 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1093,7 +1093,7 @@ typedef struct ActiveInterpTrace { typedef struct { /* For internal core use only */ Tcl_ObjType objType; - unsigned long long (*lengthProc)(Tcl_Obj *obj); + size_t (*lengthProc)(Tcl_Obj *obj); } TclObjTypeWithAbstractList; #define TCL_OBJTYPE_V0_1(lengthProc) (sizeof(TclObjTypeWithAbstractList)) \ }, lengthProc /* For internal core use only */ diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 565872e..58322c5 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -143,7 +143,7 @@ static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeListInternalRep(Tcl_Obj *listPtr); static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfList(Tcl_Obj *listPtr); -static unsigned long long ListLength(Tcl_Obj *listPtr); +static size_t ListLength(Tcl_Obj *listPtr); /* * The structure below defines the list Tcl object type by means of functions @@ -2024,7 +2024,7 @@ Tcl_ListObjLength( return TCL_OK; } -unsigned long long ListLength( +size_t ListLength( Tcl_Obj *listPtr) { ListRep listRep; @@ -2648,7 +2648,7 @@ TclLindexFlat( /* Handle ArithSeries as special case */ if (TclHasInternalRep(listObj,&tclArithSeriesType.objType)) { - Tcl_WideInt listLen = TclArithSeriesObjLength(listObj); + size_t listLen = TclArithSeriesObjLength(listObj); Tcl_Size index; Tcl_Obj *elemObj = NULL; for (i=0 ; i WIDE_MAX) { + mp_int bignumValue; + if (mp_init_u64(&bignumValue, ulongVar) != MP_OKAY) { + Tcl_Panic("%s: memory overflow", "Tcl_SetWideUIntObj"); + } + tmp = Tcl_NewBignumObj(&bignumValue); + } else { + tmp = Tcl_NewWideIntObj((Tcl_WideInt)ulongVar); + } Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); Tcl_PrintDouble(NULL, (double)floatVar, buffer); Tcl_AppendElement(interp, buffer); - tmp = Tcl_NewWideIntObj((Tcl_WideInt)uwideVar); + if (uwideVar > WIDE_MAX) { + mp_int bignumValue; + if (mp_init_u64(&bignumValue, uwideVar) != MP_OKAY) { + Tcl_Panic("%s: memory overflow", "Tcl_SetWideUIntObj"); + } + tmp = Tcl_NewBignumObj(&bignumValue); + } else { + tmp = Tcl_NewWideIntObj((Tcl_WideInt)uwideVar); + } Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); } else if (strcmp(argv[1], "set") == 0) { @@ -3500,18 +3516,18 @@ TestlistrepCmd( Tcl_WrongNumArgs(interp, 2, objv, "length ?leadSpace endSpace?"); return TCL_ERROR; } else { - Tcl_WideInt length; - Tcl_WideInt leadSpace = 0; - Tcl_WideInt endSpace = 0; - if (Tcl_GetWideIntFromObj(interp, objv[2], &length) != TCL_OK) { + Tcl_WideUInt length; + Tcl_WideUInt leadSpace = 0; + Tcl_WideUInt endSpace = 0; + if (Tcl_GetWideUIntFromObj(interp, objv[2], &length) != TCL_OK) { return TCL_ERROR; } if (objc > 3) { - if (Tcl_GetWideIntFromObj(interp, objv[3], &leadSpace) != TCL_OK) { + if (Tcl_GetWideUIntFromObj(interp, objv[3], &leadSpace) != TCL_OK) { return TCL_ERROR; } if (objc > 4) { - if (Tcl_GetWideIntFromObj(interp, objv[4], &endSpace) + if (Tcl_GetWideUIntFromObj(interp, objv[4], &endSpace) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 58fb1e4..a0a866b 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -122,7 +122,7 @@ static int FindElement(Tcl_Interp *interp, const char *string, * is unregistered, so has no need of a setFromAnyProc either. */ -static unsigned long long LengthOne(TCL_UNUSED(Tcl_Obj *)) {return 1;} +static size_t LengthOne(TCL_UNUSED(Tcl_Obj *)) {return 1;} static const TclObjTypeWithAbstractList endOffsetType = { {"end-offset", /* name */ diff --git a/tests/link.test b/tests/link.test index 69ebb02..43a85fb 100644 --- a/tests/link.test +++ b/tests/link.test @@ -71,7 +71,7 @@ test link-2.1 {writing C variables from Tcl} -constraints {testlink} -setup { set float 1.0987654321 set uwide 12345678901234567890 concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide -} -result {465 -10.5 1 abcdef 135135 79 161 8000 40000 -1073628482 34543 567890 1.0987653732299805 -6101065172474983726 | 0o0721 -10.5 true abcdef 135135 79 161 8000 40000 0xc001babe 34543 567890 1.0987654321 12345678901234567890} +} -result {465 -10.5 1 abcdef 135135 79 161 8000 40000 -1073628482 34543 567890 1.0987653732299805 12345678901234567890 | 0o0721 -10.5 true abcdef 135135 79 161 8000 40000 0xc001babe 34543 567890 1.0987654321 12345678901234567890} test link-2.2 {writing bad values into variables} -setup { testlink delete } -constraints {testlink} -body { -- cgit v0.12 From 18f90309e43e13dde5891a7548dad46e248e2c9a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 28 Nov 2022 12:06:41 +0000 Subject: Use Tcl_Size for ArithSeries.len --- generic/tclArithSeries.c | 46 +++++++++++++++++++--------------- generic/tclArithSeries.h | 14 ++++++++--- generic/tclInt.decls | 2 +- generic/tclIntDecls.h | 6 ++--- generic/tclListObj.c | 9 ++++--- generic/tclTest.c | 65 +++++++++++++++++++++++++++++++++--------------- tests/link.test | 2 +- 7 files changed, 93 insertions(+), 51 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 40f34b5..c32c443 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -149,7 +149,7 @@ TclNewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_W arithSeriesRepPtr->start = start; arithSeriesRepPtr->end = end; arithSeriesRepPtr->step = step; - arithSeriesRepPtr->len = length; + arithSeriesRepPtr->len1 = length; arithSeriesRepPtr->elements = NULL; arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL; @@ -196,7 +196,7 @@ TclNewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) arithSeriesRepPtr->start = start; arithSeriesRepPtr->end = end; arithSeriesRepPtr->step = step; - arithSeriesRepPtr->len = length; + arithSeriesRepPtr->len1 = length; arithSeriesRepPtr->elements = NULL; arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL; @@ -429,7 +429,7 @@ TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **ele Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); } arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesPtr); - if (index < 0 || index >= arithSeriesRepPtr->len) { + if (index < 0 || index >= arithSeriesRepPtr->len1) { return TCL_ERROR; } /* List[i] = Start + (Step * index) */ @@ -458,11 +458,11 @@ TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **ele * *---------------------------------------------------------------------- */ -Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr) +Tcl_Size TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr) { ArithSeries *arithSeriesRepPtr = (ArithSeries*) arithSeriesPtr->internalRep.twoPtrValue.ptr1; - return arithSeriesRepPtr->len; + return arithSeriesRepPtr->len1; } /* @@ -491,7 +491,7 @@ FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesPtr) if (arithSeriesRepPtr->elements) { Tcl_WideInt i; Tcl_Obj**elmts = arithSeriesRepPtr->elements; - for(i=0; ilen; i++) { + for(i=0; ilen1; i++) { if (elmts[i]) { Tcl_DecrRefCount(elmts[i]); } @@ -581,7 +581,7 @@ UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr) /* * Pass 1: estimate space. */ - for (i = 0; i < arithSeriesRepPtr->len; i++) { + for (i = 0; i < arithSeriesRepPtr->len1; i++) { TclArithSeriesObjIndex(arithSeriesPtr, i, &elemObj); elem = TclGetStringFromObj(elemObj, &slen); Tcl_DecrRefCount(elemObj); @@ -594,7 +594,7 @@ UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr) */ p = Tcl_InitStringRep(arithSeriesPtr, NULL, length); - for (i = 0; i < arithSeriesRepPtr->len; i++) { + for (i = 0; i < arithSeriesRepPtr->len1; i++) { TclArithSeriesObjIndex(arithSeriesPtr, i, &elemObj); elem = TclGetStringFromObj(elemObj, &slen); strcpy(p, elem); @@ -725,10 +725,9 @@ TclArithSeriesObjRange( if (TclArithSeriesObjIndex(arithSeriesPtr, fromIdx, &startObj) != TCL_OK) { if (interp) { - Tcl_SetObjResult( - interp, - Tcl_ObjPrintf("index %d is out of bounds 0 to %" - TCL_LL_MODIFIER "d", fromIdx, (arithSeriesRepPtr->len-1))); + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("index %d is out of bounds 0 to %" + "d", fromIdx, (arithSeriesRepPtr->len1-1))); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } return NULL; @@ -736,10 +735,9 @@ TclArithSeriesObjRange( Tcl_IncrRefCount(startObj); if (TclArithSeriesObjIndex(arithSeriesPtr, toIdx, &endObj) != TCL_OK) { if (interp) { - Tcl_SetObjResult( - interp, - Tcl_ObjPrintf("index %d is out of bounds 0 to %" - TCL_LL_MODIFIER "d", fromIdx, (arithSeriesRepPtr->len-1))); + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("index %d is out of bounds 0 to %" + "d", fromIdx, (arithSeriesRepPtr->len1-1))); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } return NULL; @@ -782,7 +780,7 @@ TclArithSeriesObjRange( arithSeriesDblRepPtr->start = start; arithSeriesDblRepPtr->end = end; arithSeriesDblRepPtr->step = step; - arithSeriesDblRepPtr->len = (end-start+step)/step; + arithSeriesDblRepPtr->len1 = (end-start+step)/step; arithSeriesDblRepPtr->elements = NULL; } else { @@ -793,7 +791,7 @@ TclArithSeriesObjRange( arithSeriesRepPtr->start = start; arithSeriesRepPtr->end = end; arithSeriesRepPtr->step = step; - arithSeriesRepPtr->len = (end-start+step)/step; + arithSeriesRepPtr->len1 = (end-start+step)/step; arithSeriesRepPtr->elements = NULL; } @@ -849,7 +847,7 @@ TclArithSeriesGetElements( int i, objc; ArithSeriesGetInternalRep(objPtr, arithSeriesRepPtr); - objc = arithSeriesRepPtr->len; + objc = arithSeriesRepPtr->len1; if (objc > 0) { if (arithSeriesRepPtr->elements) { /* If this exists, it has already been populated */ @@ -931,7 +929,7 @@ TclArithSeriesObjReverse( ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); isDouble = arithSeriesRepPtr->isDouble; - len = arithSeriesRepPtr->len; + len = arithSeriesRepPtr->len1; TclArithSeriesObjIndex(arithSeriesPtr, (len-1), &startObj); Tcl_IncrRefCount(startObj); @@ -1000,3 +998,11 @@ TclArithSeriesObjReverse( return resultObj; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h index f7f2fa8..f855f6f 100644 --- a/generic/tclArithSeries.h +++ b/generic/tclArithSeries.h @@ -16,7 +16,7 @@ * but it's faster to cache it inside the internal representation. */ typedef struct ArithSeries { - Tcl_WideInt len; + Tcl_Size len1; Tcl_Obj **elements; int isDouble; Tcl_WideInt start; @@ -24,7 +24,7 @@ typedef struct ArithSeries { Tcl_WideInt step; } ArithSeries; typedef struct ArithSeriesDbl { - Tcl_WideInt len; + Tcl_Size len1; Tcl_Obj **elements; int isDouble; double start; @@ -39,7 +39,7 @@ MODULE_SCOPE int TclArithSeriesObjStep(Tcl_Obj *arithSeriesPtr, Tcl_Obj **stepObj); MODULE_SCOPE int TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **elementObj); -MODULE_SCOPE Tcl_WideInt TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); +MODULE_SCOPE Tcl_Size TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Interp *interp, Tcl_Obj *arithSeriesPtr, Tcl_Size fromIdx, Tcl_Size toIdx); MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Interp *interp, @@ -55,3 +55,11 @@ MODULE_SCOPE int TclNewArithSeriesObj(Tcl_Interp *interp, Tcl_Obj **arithSeriesObj, int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj, Tcl_Obj *stepObj, Tcl_Obj *lenObj); + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclInt.decls b/generic/tclInt.decls index b3e352a..4db3919 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -701,7 +701,7 @@ declare 258 { # TIP 625: for unit testing - create list objects with span declare 260 { - Tcl_Obj *TclListTestObj(Tcl_Size length, Tcl_Size leadingSpace, Tcl_Size endSpace) + Tcl_Obj *TclListTestObj(size_t length, size_t leadingSpace, size_t endSpace) } # TIP 625: for unit testing - check list invariants diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 4c8d897..ffd559d 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -660,8 +660,8 @@ EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* Slot 259 is reserved */ /* 260 */ -EXTERN Tcl_Obj * TclListTestObj(Tcl_Size length, - Tcl_Size leadingSpace, Tcl_Size endSpace); +EXTERN Tcl_Obj * TclListTestObj(size_t length, size_t leadingSpace, + size_t endSpace); /* 261 */ EXTERN void TclListObjValidate(Tcl_Interp *interp, Tcl_Obj *listObj); @@ -930,7 +930,7 @@ typedef struct TclIntStubs { void (*tclStaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc); /* 257 */ Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */ void (*reserved259)(void); - Tcl_Obj * (*tclListTestObj) (Tcl_Size length, Tcl_Size leadingSpace, Tcl_Size endSpace); /* 260 */ + Tcl_Obj * (*tclListTestObj) (size_t length, size_t leadingSpace, size_t endSpace); /* 260 */ void (*tclListObjValidate) (Tcl_Interp *interp, Tcl_Obj *listObj); /* 261 */ } TclIntStubs; diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 486baa2..776ff0e 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -3515,10 +3515,10 @@ UpdateStringOfList( *------------------------------------------------------------------------ */ Tcl_Obj * -TclListTestObj(Tcl_Size length, Tcl_Size leadingSpace, Tcl_Size endSpace) +TclListTestObj(size_t length, size_t leadingSpace, size_t endSpace) { ListRep listRep; - Tcl_Size capacity; + size_t capacity; Tcl_Obj *listObj; TclNewObj(listObj); @@ -3528,11 +3528,14 @@ TclListTestObj(Tcl_Size length, Tcl_Size leadingSpace, Tcl_Size endSpace) if (capacity == 0) { return listObj; } + if (capacity > LIST_MAX) { + return NULL; + } ListRepInit(capacity, NULL, 0, &listRep); ListStore *storePtr = listRep.storePtr; - Tcl_Size i; + size_t i; for (i = 0; i < length; ++i) { TclNewUIntObj(storePtr->slots[i + leadingSpace], i); Tcl_IncrRefCount(storePtr->slots[i + leadingSpace]); diff --git a/generic/tclTest.c b/generic/tclTest.c index bc3b553..c5eb6eb 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -300,7 +300,7 @@ static Tcl_ObjCmdProc TestprintObjCmd; static Tcl_ObjCmdProc TestregexpObjCmd; static Tcl_ObjCmdProc TestreturnObjCmd; static void TestregexpXflags(const char *string, - int length, int *cflagsPtr, int *eflagsPtr); + size_t length, int *cflagsPtr, int *eflagsPtr); #ifndef TCL_NO_DEPRECATED static Tcl_ObjCmdProc TestsaveresultCmd; static void TestsaveresultFree(char *blockPtr); @@ -999,7 +999,8 @@ AsyncHandlerProc( { TestAsyncHandler *asyncPtr; int id = PTR2INT(clientData); - const char *listArgv[4], *cmd; + const char *listArgv[4]; + char *cmd; char string[TCL_INTEGER_SPACE]; Tcl_MutexLock(&asyncTestMutex); @@ -3121,12 +3122,28 @@ TestlinkCmd( tmp = Tcl_NewWideIntObj(longVar); Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); - tmp = Tcl_NewWideIntObj((long)ulongVar); + if (ulongVar > WIDE_MAX) { + mp_int bignumValue; + if (mp_init_u64(&bignumValue, ulongVar) != MP_OKAY) { + Tcl_Panic("%s: memory overflow", "Tcl_SetWideUIntObj"); + } + tmp = Tcl_NewBignumObj(&bignumValue); + } else { + tmp = Tcl_NewWideIntObj((Tcl_WideInt)ulongVar); + } Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); Tcl_PrintDouble(NULL, (double)floatVar, buffer); Tcl_AppendElement(interp, buffer); - tmp = Tcl_NewWideIntObj((Tcl_WideInt)uwideVar); + if (uwideVar > WIDE_MAX) { + mp_int bignumValue; + if (mp_init_u64(&bignumValue, uwideVar) != MP_OKAY) { + Tcl_Panic("%s: memory overflow", "Tcl_SetWideUIntObj"); + } + tmp = Tcl_NewBignumObj(&bignumValue); + } else { + tmp = Tcl_NewWideIntObj((Tcl_WideInt)uwideVar); + } Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); } else if (strcmp(argv[1], "set") == 0) { @@ -3532,24 +3549,28 @@ TestlistrepCmd( Tcl_WrongNumArgs(interp, 2, objv, "length ?leadSpace endSpace?"); return TCL_ERROR; } else { - int length; - int leadSpace = 0; - int endSpace = 0; - if (Tcl_GetIntFromObj(interp, objv[2], &length) != TCL_OK) { + Tcl_WideUInt length; + Tcl_WideUInt leadSpace = 0; + Tcl_WideUInt endSpace = 0; + if (Tcl_GetWideUIntFromObj(interp, objv[2], &length) != TCL_OK) { return TCL_ERROR; } if (objc > 3) { - if (Tcl_GetIntFromObj(interp, objv[3], &leadSpace) != TCL_OK) { + if (Tcl_GetWideUIntFromObj(interp, objv[3], &leadSpace) != TCL_OK) { return TCL_ERROR; } if (objc > 4) { - if (Tcl_GetIntFromObj(interp, objv[4], &endSpace) + if (Tcl_GetWideUIntFromObj(interp, objv[4], &endSpace) != TCL_OK) { return TCL_ERROR; } } } resultObj = TclListTestObj(length, leadSpace, endSpace); + if (resultObj == NULL) { + Tcl_AppendResult(interp, "List capacity exceeded", NULL); + return TCL_ERROR; + } } break; @@ -4347,11 +4368,11 @@ TestregexpObjCmd( static void TestregexpXflags( const char *string, /* The string of flags. */ - int length, /* The length of the string in bytes. */ + size_t length, /* The length of the string in bytes. */ int *cflagsPtr, /* compile flags word */ int *eflagsPtr) /* exec flags word */ { - int i; + size_t i; int cflags, eflags; cflags = *cflagsPtr; @@ -5369,12 +5390,17 @@ TestsetbytearraylengthObjCmd( if (TCL_OK != Tcl_GetIntFromObj(interp, objv[2], &n)) { return TCL_ERROR; } - if (Tcl_IsShared(objv[1])) { - obj = Tcl_DuplicateObj(objv[1]); - } else { - obj = objv[1]; + obj = objv[1]; + if (Tcl_IsShared(obj)) { + obj = Tcl_DuplicateObj(obj); + } + if (Tcl_SetByteArrayLength(obj, n) == NULL) { + if (obj != objv[1]) { + Tcl_DecrRefCount(obj); + } + Tcl_AppendResult(interp, "expected bytes", NULL); + return TCL_ERROR; } - Tcl_SetByteArrayLength(obj, n); Tcl_SetObjResult(interp, obj); return TCL_OK; } @@ -6658,15 +6684,14 @@ TestWrongNumArgsObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i; - int length; + int i, length; const char *msg; if (objc < 3) { goto insufArgs; } - if (Tcl_GetIntFromObj(interp, objv[1], &i) != TCL_OK) { + if (Tcl_GetIntForIndex(interp, objv[1], TCL_INDEX_NONE, &i) != TCL_OK) { return TCL_ERROR; } diff --git a/tests/link.test b/tests/link.test index 69ebb02..43a85fb 100644 --- a/tests/link.test +++ b/tests/link.test @@ -71,7 +71,7 @@ test link-2.1 {writing C variables from Tcl} -constraints {testlink} -setup { set float 1.0987654321 set uwide 12345678901234567890 concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide -} -result {465 -10.5 1 abcdef 135135 79 161 8000 40000 -1073628482 34543 567890 1.0987653732299805 -6101065172474983726 | 0o0721 -10.5 true abcdef 135135 79 161 8000 40000 0xc001babe 34543 567890 1.0987654321 12345678901234567890} +} -result {465 -10.5 1 abcdef 135135 79 161 8000 40000 -1073628482 34543 567890 1.0987653732299805 12345678901234567890 | 0o0721 -10.5 true abcdef 135135 79 161 8000 40000 0xc001babe 34543 567890 1.0987654321 12345678901234567890} test link-2.2 {writing bad values into variables} -setup { testlink delete } -constraints {testlink} -body { -- cgit v0.12 From da196c33450ded41b2370bf956f7d3cd7b081069 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 28 Nov 2022 12:58:18 +0000 Subject: No reservation for TIP #648 any more in stub table. --- generic/tcl.decls | 17 +++++++---------- generic/tclArithSeries.c | 26 +++++++++++++------------- generic/tclArithSeries.h | 4 ++-- generic/tclDecls.h | 26 ++++++++++++++------------ generic/tclStubInit.c | 8 ++++---- 5 files changed, 40 insertions(+), 41 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 6283089..a9c042c 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2552,27 +2552,23 @@ declare 683 { int Tcl_GetEncodingNulLength(Tcl_Encoding encoding) } -# TIP #648 (reserved) -#declare 684 { -# Tcl_Obj *Tcl_NewWideUIntObj(Tcl_WideUInt wideValue) -#} -#declare 685 { -# void Tcl_SetWideUIntObj(Tcl_Obj *objPtr, Tcl_WideUInt uwideValue) -#} - # TIP #650 -declare 686 { +declare 684 { int Tcl_GetWideUIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr) } # TIP 651 -declare 687 { +declare 685 { Tcl_Obj *Tcl_DStringToObj(Tcl_DString *dsPtr) } # ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- # +declare 687 { + void TclUnusedStubEntry(void) +} + ############################################################################## # Define the platform specific public Tcl interface. These functions are only @@ -2662,6 +2658,7 @@ export { const char *TclZipfs_AppHook(int *argc, char ***argv) } + # Local Variables: # mode: tcl # End: diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index c32c443..b278644 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -149,7 +149,7 @@ TclNewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_W arithSeriesRepPtr->start = start; arithSeriesRepPtr->end = end; arithSeriesRepPtr->step = step; - arithSeriesRepPtr->len1 = length; + arithSeriesRepPtr->len = length; arithSeriesRepPtr->elements = NULL; arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL; @@ -196,7 +196,7 @@ TclNewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) arithSeriesRepPtr->start = start; arithSeriesRepPtr->end = end; arithSeriesRepPtr->step = step; - arithSeriesRepPtr->len1 = length; + arithSeriesRepPtr->len = length; arithSeriesRepPtr->elements = NULL; arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL; @@ -429,7 +429,7 @@ TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **ele Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); } arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesPtr); - if (index < 0 || index >= arithSeriesRepPtr->len1) { + if (index < 0 || index >= arithSeriesRepPtr->len) { return TCL_ERROR; } /* List[i] = Start + (Step * index) */ @@ -462,7 +462,7 @@ Tcl_Size TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr) { ArithSeries *arithSeriesRepPtr = (ArithSeries*) arithSeriesPtr->internalRep.twoPtrValue.ptr1; - return arithSeriesRepPtr->len1; + return arithSeriesRepPtr->len; } /* @@ -491,7 +491,7 @@ FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesPtr) if (arithSeriesRepPtr->elements) { Tcl_WideInt i; Tcl_Obj**elmts = arithSeriesRepPtr->elements; - for(i=0; ilen1; i++) { + for(i=0; ilen; i++) { if (elmts[i]) { Tcl_DecrRefCount(elmts[i]); } @@ -581,7 +581,7 @@ UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr) /* * Pass 1: estimate space. */ - for (i = 0; i < arithSeriesRepPtr->len1; i++) { + for (i = 0; i < arithSeriesRepPtr->len; i++) { TclArithSeriesObjIndex(arithSeriesPtr, i, &elemObj); elem = TclGetStringFromObj(elemObj, &slen); Tcl_DecrRefCount(elemObj); @@ -594,7 +594,7 @@ UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr) */ p = Tcl_InitStringRep(arithSeriesPtr, NULL, length); - for (i = 0; i < arithSeriesRepPtr->len1; i++) { + for (i = 0; i < arithSeriesRepPtr->len; i++) { TclArithSeriesObjIndex(arithSeriesPtr, i, &elemObj); elem = TclGetStringFromObj(elemObj, &slen); strcpy(p, elem); @@ -727,7 +727,7 @@ TclArithSeriesObjRange( if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("index %d is out of bounds 0 to %" - "d", fromIdx, (arithSeriesRepPtr->len1-1))); + "d", fromIdx, (arithSeriesRepPtr->len-1))); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } return NULL; @@ -737,7 +737,7 @@ TclArithSeriesObjRange( if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("index %d is out of bounds 0 to %" - "d", fromIdx, (arithSeriesRepPtr->len1-1))); + "d", fromIdx, (arithSeriesRepPtr->len-1))); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } return NULL; @@ -780,7 +780,7 @@ TclArithSeriesObjRange( arithSeriesDblRepPtr->start = start; arithSeriesDblRepPtr->end = end; arithSeriesDblRepPtr->step = step; - arithSeriesDblRepPtr->len1 = (end-start+step)/step; + arithSeriesDblRepPtr->len = (end-start+step)/step; arithSeriesDblRepPtr->elements = NULL; } else { @@ -791,7 +791,7 @@ TclArithSeriesObjRange( arithSeriesRepPtr->start = start; arithSeriesRepPtr->end = end; arithSeriesRepPtr->step = step; - arithSeriesRepPtr->len1 = (end-start+step)/step; + arithSeriesRepPtr->len = (end-start+step)/step; arithSeriesRepPtr->elements = NULL; } @@ -847,7 +847,7 @@ TclArithSeriesGetElements( int i, objc; ArithSeriesGetInternalRep(objPtr, arithSeriesRepPtr); - objc = arithSeriesRepPtr->len1; + objc = arithSeriesRepPtr->len; if (objc > 0) { if (arithSeriesRepPtr->elements) { /* If this exists, it has already been populated */ @@ -929,7 +929,7 @@ TclArithSeriesObjReverse( ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); isDouble = arithSeriesRepPtr->isDouble; - len = arithSeriesRepPtr->len1; + len = arithSeriesRepPtr->len; TclArithSeriesObjIndex(arithSeriesPtr, (len-1), &startObj); Tcl_IncrRefCount(startObj); diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h index f855f6f..1daacdd 100644 --- a/generic/tclArithSeries.h +++ b/generic/tclArithSeries.h @@ -16,7 +16,7 @@ * but it's faster to cache it inside the internal representation. */ typedef struct ArithSeries { - Tcl_Size len1; + Tcl_Size len; Tcl_Obj **elements; int isDouble; Tcl_WideInt start; @@ -24,7 +24,7 @@ typedef struct ArithSeries { Tcl_WideInt step; } ArithSeries; typedef struct ArithSeriesDbl { - Tcl_Size len1; + Tcl_Size len; Tcl_Obj **elements; int isDouble; double start; diff --git a/generic/tclDecls.h b/generic/tclDecls.h index eb15582..75fc17e 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -2040,13 +2040,14 @@ EXTERN int Tcl_RemoveChannelMode(Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 683 */ EXTERN int Tcl_GetEncodingNulLength(Tcl_Encoding encoding); -/* Slot 684 is reserved */ -/* Slot 685 is reserved */ -/* 686 */ +/* 684 */ EXTERN int Tcl_GetWideUIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); -/* 687 */ +/* 685 */ EXTERN Tcl_Obj * Tcl_DStringToObj(Tcl_DString *dsPtr); +/* Slot 686 is reserved */ +/* 687 */ +EXTERN void TclUnusedStubEntry(void); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -2766,10 +2767,10 @@ typedef struct TclStubs { int (*tcl_GetNumber) (Tcl_Interp *interp, const char *bytes, size_t numBytes, void **clientDataPtr, int *typePtr); /* 681 */ int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 682 */ int (*tcl_GetEncodingNulLength) (Tcl_Encoding encoding); /* 683 */ - void (*reserved684)(void); - void (*reserved685)(void); - int (*tcl_GetWideUIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); /* 686 */ - Tcl_Obj * (*tcl_DStringToObj) (Tcl_DString *dsPtr); /* 687 */ + int (*tcl_GetWideUIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); /* 684 */ + Tcl_Obj * (*tcl_DStringToObj) (Tcl_DString *dsPtr); /* 685 */ + void (*reserved686)(void); + void (*tclUnusedStubEntry) (void); /* 687 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4168,12 +4169,13 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_RemoveChannelMode) /* 682 */ #define Tcl_GetEncodingNulLength \ (tclStubsPtr->tcl_GetEncodingNulLength) /* 683 */ -/* Slot 684 is reserved */ -/* Slot 685 is reserved */ #define Tcl_GetWideUIntFromObj \ - (tclStubsPtr->tcl_GetWideUIntFromObj) /* 686 */ + (tclStubsPtr->tcl_GetWideUIntFromObj) /* 684 */ #define Tcl_DStringToObj \ - (tclStubsPtr->tcl_DStringToObj) /* 687 */ + (tclStubsPtr->tcl_DStringToObj) /* 685 */ +/* Slot 686 is reserved */ +#define TclUnusedStubEntry \ + (tclStubsPtr->tclUnusedStubEntry) /* 687 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 865effe..ddc0bc9 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -2055,10 +2055,10 @@ const TclStubs tclStubs = { Tcl_GetNumber, /* 681 */ Tcl_RemoveChannelMode, /* 682 */ Tcl_GetEncodingNulLength, /* 683 */ - 0, /* 684 */ - 0, /* 685 */ - Tcl_GetWideUIntFromObj, /* 686 */ - Tcl_DStringToObj, /* 687 */ + Tcl_GetWideUIntFromObj, /* 684 */ + Tcl_DStringToObj, /* 685 */ + 0, /* 686 */ + TclUnusedStubEntry, /* 687 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 71b0ad990caaf6a297049da2c63821a4e29c57ac Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 28 Nov 2022 23:16:31 +0000 Subject: Reduce shimmering: If a conclusion can be drawn about the number of list elements, don't get the elements before the list length is checked --- generic/tclArithSeries.h | 4 ++-- generic/tclAssembly.c | 5 ++++- generic/tclBinary.c | 10 +++++++--- generic/tclCmdAH.c | 6 ++++-- generic/tclCmdIL.c | 10 ++++++++-- generic/tclCmdMZ.c | 5 ++++- generic/tclDecls.h | 1 + generic/tclEnsemble.c | 12 ++++++++++-- generic/tclListObj.c | 4 ++-- generic/tclProc.c | 8 ++++++++ generic/tclTrace.c | 19 +++++++++++++++---- generic/tclVar.c | 8 ++++++-- generic/tclZipfs.c | 6 +++++- 13 files changed, 76 insertions(+), 22 deletions(-) diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h index 1daacdd..28fd993 100644 --- a/generic/tclArithSeries.h +++ b/generic/tclArithSeries.h @@ -15,7 +15,7 @@ * Note that the len can in theory be always computed by start,end,step * but it's faster to cache it inside the internal representation. */ -typedef struct ArithSeries { +typedef struct { Tcl_Size len; Tcl_Obj **elements; int isDouble; @@ -23,7 +23,7 @@ typedef struct ArithSeries { Tcl_WideInt end; Tcl_WideInt step; } ArithSeries; -typedef struct ArithSeriesDbl { +typedef struct { Tcl_Size len; Tcl_Obj **elements; int isDouble; diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index dbf37bb8..ab5cd7a 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -1985,7 +1985,7 @@ CreateMirrorJumpTable( * table. */ int i; - if (TclListObjGetElementsM(interp, jumps, &objc, &objv) != TCL_OK) { + if (TclListObjLengthM(interp, jumps, &objc) != TCL_OK) { return TCL_ERROR; } if (objc % 2 != 0) { @@ -1997,6 +1997,9 @@ CreateMirrorJumpTable( } return TCL_ERROR; } + if (TclListObjGetElementsM(interp, jumps, &objc, &objv) != TCL_OK) { + return TCL_ERROR; + } /* * Allocate the jumptable. diff --git a/generic/tclBinary.c b/generic/tclBinary.c index e4c8766..b744203 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -1125,11 +1125,10 @@ BinaryFormatCmd( * The macro evals its args more than once: avoid arg++ */ - if (TclListObjGetElementsM(interp, objv[arg], &listc, - &listv) != TCL_OK) { + if (TclListObjLengthM(interp, objv[arg], &listc + ) != TCL_OK) { return TCL_ERROR; } - arg++; if (count == BINARY_ALL) { count = listc; @@ -1139,6 +1138,11 @@ BinaryFormatCmd( -1)); return TCL_ERROR; } + if (TclListObjGetElementsM(interp, objv[arg], &listc, + &listv) != TCL_OK) { + return TCL_ERROR; + } + arg++; } offset += count*size; break; diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 9905633..2281b5a 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2860,8 +2860,8 @@ EachloopCmd( result = TCL_ERROR; goto done; } - TclListObjGetElementsM(NULL, statePtr->vCopyList[i], - &statePtr->varcList[i], &statePtr->varvList[i]); + TclListObjLengthM(NULL, statePtr->vCopyList[i], + &statePtr->varcList[i]); if (statePtr->varcList[i] < 1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s varlist is empty", @@ -2872,6 +2872,8 @@ EachloopCmd( result = TCL_ERROR; goto done; } + TclListObjGetElementsM(NULL, statePtr->vCopyList[i], + &statePtr->varcList[i], &statePtr->varvList[i]); /* Values */ if (TclHasInternalRep(objv[2+i*2],&tclArithSeriesType)) { diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index e2493c4..8e52d65 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -20,6 +20,7 @@ #include "tclInt.h" #include "tclRegexp.h" #include "tclArithSeries.h" +#include "tclTomMath.h" #include #include @@ -2573,6 +2574,7 @@ Tcl_LlengthObjCmd( /* Argument objects. */ { int listLen, result; + Tcl_Obj *objPtr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "list"); @@ -2589,7 +2591,8 @@ Tcl_LlengthObjCmd( * length. */ - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(listLen)); + TclNewUIntObj(objPtr, listLen); + Tcl_SetObjResult(interp, objPtr); return TCL_OK; } @@ -3152,7 +3155,7 @@ Tcl_LreverseObjCmd( } /* end ArithSeries */ /* True List */ - if (TclListObjGetElementsM(interp, objv[1], &elemc, &elemv) != TCL_OK) { + if (TclListObjLengthM(interp, objv[1], &elemc) != TCL_OK) { return TCL_ERROR; } @@ -3164,6 +3167,9 @@ Tcl_LreverseObjCmd( Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } + if (TclListObjGetElementsM(interp, objv[1], &elemc, &elemv) != TCL_OK) { + return TCL_ERROR; + } if (Tcl_IsShared(objv[1]) || ListObjRepIsShared(objv[1])) { /* Bug 1675044 */ diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 57541f9..147c2dc 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -3610,7 +3610,7 @@ TclNRSwitchObjCmd( Tcl_Obj **listv; blist = objv[0]; - if (TclListObjGetElementsM(interp, objv[0], &objc, &listv) != TCL_OK) { + if (TclListObjLengthM(interp, objv[0], &objc) != TCL_OK) { return TCL_ERROR; } @@ -3623,6 +3623,9 @@ TclNRSwitchObjCmd( "?-option ...? string {?pattern body ...? ?default body?}"); return TCL_ERROR; } + if (TclListObjGetElementsM(interp, objv[0], &objc, &listv) != TCL_OK) { + return TCL_ERROR; + } objv = listv; splitObjs = 1; } diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 75fc17e..d8b4b5d 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -4182,6 +4182,7 @@ extern const TclStubs *tclStubsPtr; /* !END!: Do not edit above this line. */ #undef TclUnusedStubEntry + #if defined(USE_TCL_STUBS) # undef Tcl_CreateInterp # undef Tcl_FindExecutable diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 88b611f..963f1d8 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -562,8 +562,8 @@ TclNamespaceEnsembleCmd( continue; } do { - if (TclListObjGetElementsM(interp, listObj, &len, - &listv) != TCL_OK) { + if (TclListObjLengthM(interp, listObj, &len + ) != TCL_OK) { Tcl_DictObjDone(&search); if (patchedDict) { Tcl_DecrRefCount(patchedDict); @@ -582,6 +582,14 @@ TclNamespaceEnsembleCmd( } goto freeMapAndError; } + if (TclListObjGetElementsM(interp, listObj, &len, + &listv) != TCL_OK) { + Tcl_DictObjDone(&search); + if (patchedDict) { + Tcl_DecrRefCount(patchedDict); + } + goto freeMapAndError; + } cmd = TclGetString(listv[0]); if (!(cmd[0] == ':' && cmd[1] == ':')) { Tcl_Obj *newList = Tcl_DuplicateObj(listObj); diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 776ff0e..80477f7 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -1994,7 +1994,7 @@ int Tcl_ListObjLength( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *listObj, /* List object whose #elements to return. */ - Tcl_Size *lenPtr) /* The resulting int is stored here. */ + Tcl_Size *lenPtr) /* The resulting length is stored here. */ { ListRep listRep; @@ -2632,7 +2632,7 @@ TclLindexFlat( /* Handle ArithSeries as special case */ if (TclHasInternalRep(listObj,&tclArithSeriesType)) { - Tcl_WideInt listLen = TclArithSeriesObjLength(listObj); + Tcl_Size listLen = TclArithSeriesObjLength(listObj); Tcl_Size index; Tcl_Obj *elemObj = NULL; for (i=0 ; i Date: Tue, 29 Nov 2022 10:30:41 +0000 Subject: Update all "8.5" versions in Tcl_InitStubs() to "8.5-", since they can be compiled for Tcl 9.0 as well. --- generic/tclTest.c | 4 ++-- tools/tsdPerf.c | 2 +- unix/dltest/pkga.c | 2 +- unix/dltest/pkgb.c | 4 ++-- unix/dltest/pkgc.c | 4 ++-- unix/dltest/pkgd.c | 4 ++-- unix/dltest/pkge.c | 2 +- unix/dltest/pkgooa.c | 2 +- unix/dltest/pkgua.c | 2 +- unix/tclXtTest.c | 2 +- win/tclWinDde.c | 2 +- win/tclWinReg.c | 2 +- 12 files changed, 16 insertions(+), 16 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 0004c8e..bc51c99 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -445,7 +445,7 @@ Tcltest_Init( "-appinitprocclosestderr", "-appinitprocsetrcfile", NULL }; - if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } if (Tcl_TomMath_InitStubs(interp, "8.5") == NULL) { @@ -694,7 +694,7 @@ int Tcltest_SafeInit( Tcl_Interp *interp) /* Interpreter for application. */ { - if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } return Procbodytest_SafeInit(interp); diff --git a/tools/tsdPerf.c b/tools/tsdPerf.c index 40004b1..a75e962 100644 --- a/tools/tsdPerf.c +++ b/tools/tsdPerf.c @@ -40,7 +40,7 @@ tsdPerfGetObjCmd(ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const int Tsdperf_Init(Tcl_Interp *interp) { - if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } diff --git a/unix/dltest/pkga.c b/unix/dltest/pkga.c index ff8f000..c2d814f 100644 --- a/unix/dltest/pkga.c +++ b/unix/dltest/pkga.c @@ -126,7 +126,7 @@ Pkga_Init( { int code; - if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } code = Tcl_PkgProvide(interp, "pkga", "1.0"); diff --git a/unix/dltest/pkgb.c b/unix/dltest/pkgb.c index 29f4a23..8d8d123 100644 --- a/unix/dltest/pkgb.c +++ b/unix/dltest/pkgb.c @@ -149,7 +149,7 @@ Pkgb_Init( { int code; - if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } code = Tcl_PkgProvide(interp, "pkgb", "2.3"); @@ -186,7 +186,7 @@ Pkgb_SafeInit( { int code; - if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } code = Tcl_PkgProvide(interp, "pkgb", "2.3"); diff --git a/unix/dltest/pkgc.c b/unix/dltest/pkgc.c index 23bb2e5..46f6e86 100644 --- a/unix/dltest/pkgc.c +++ b/unix/dltest/pkgc.c @@ -118,7 +118,7 @@ Pkgc_Init( { int code; - if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } code = Tcl_PkgProvide(interp, "pkgc", "1.7.2"); @@ -155,7 +155,7 @@ Pkgc_SafeInit( { int code; - if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } code = Tcl_PkgProvide(interp, "pkgc", "1.7.2"); diff --git a/unix/dltest/pkgd.c b/unix/dltest/pkgd.c index d51dd6a..d64c807 100644 --- a/unix/dltest/pkgd.c +++ b/unix/dltest/pkgd.c @@ -118,7 +118,7 @@ Pkgd_Init( { int code; - if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } code = Tcl_PkgProvide(interp, "pkgd", "7.3"); @@ -155,7 +155,7 @@ Pkgd_SafeInit( { int code; - if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } code = Tcl_PkgProvide(interp, "pkgd", "7.3"); diff --git a/unix/dltest/pkge.c b/unix/dltest/pkge.c index 9120538..f46ca74 100644 --- a/unix/dltest/pkge.c +++ b/unix/dltest/pkge.c @@ -38,7 +38,7 @@ Pkge_Init( { static const char script[] = "if 44 {open non_existent}"; - if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } return Tcl_EvalEx(interp, script, -1, 0); diff --git a/unix/dltest/pkgooa.c b/unix/dltest/pkgooa.c index 9f78da8..06ff3ac 100644 --- a/unix/dltest/pkgooa.c +++ b/unix/dltest/pkgooa.c @@ -105,7 +105,7 @@ Pkgooa_Init( * This worked in Tcl 8.6.0, and is expected * to keep working in all future Tcl 8.x releases. */ - if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } if (tclStubsPtr == NULL) { diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c index ad2b2b3..e6a4fbb 100644 --- a/unix/dltest/pkgua.c +++ b/unix/dltest/pkgua.c @@ -216,7 +216,7 @@ Pkgua_Init( int code; Tcl_Command *cmdTokens; - if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } diff --git a/unix/tclXtTest.c b/unix/tclXtTest.c index 12960ad..7eb1fdc 100644 --- a/unix/tclXtTest.c +++ b/unix/tclXtTest.c @@ -47,7 +47,7 @@ DLLEXPORT int Tclxttest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { - if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } XtToolkitInitialize(); diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 1c10c65..678eed3 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -175,7 +175,7 @@ int Dde_Init( Tcl_Interp *interp) { - if (!Tcl_InitStubs(interp, "8.5", 0)) { + if (!Tcl_InitStubs(interp, "8.5-", 0)) { return TCL_ERROR; } diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 16a0d3d..cd4ab33 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -184,7 +184,7 @@ Registry_Init( { Tcl_Command cmd; - if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } -- cgit v0.12 From 4813d492cacd8473e3266e284b3d3714f49602ae Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 29 Nov 2022 14:51:03 +0000 Subject: Proposed fix for [084ab982fe]: Use -strict to disable noncharacters --- generic/tclEncoding.c | 27 ++++++++++++++------------- tests/encoding.test | 36 ++++++++++++++++++++++++++++++++++++ 2 files changed, 50 insertions(+), 13 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index eb217b4..5be6a2e 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -562,7 +562,7 @@ TclInitEncodingSubsystem(void) type.nullSize = 1; type.clientData = INT2PTR(TCL_ENCODING_UTF); Tcl_CreateEncoding(&type); - type.clientData = INT2PTR(0); + type.clientData = INT2PTR(TCL_ENCODING_NOCOMPLAIN); type.encodingName = "cesu-8"; Tcl_CreateEncoding(&type); @@ -571,13 +571,13 @@ TclInitEncodingSubsystem(void) type.freeProc = NULL; type.nullSize = 2; type.encodingName = "ucs-2le"; - type.clientData = INT2PTR(TCL_ENCODING_LE); + type.clientData = INT2PTR(TCL_ENCODING_LE|TCL_ENCODING_NOCOMPLAIN); Tcl_CreateEncoding(&type); type.encodingName = "ucs-2be"; - type.clientData = INT2PTR(0); + type.clientData = INT2PTR(TCL_ENCODING_NOCOMPLAIN); Tcl_CreateEncoding(&type); type.encodingName = "ucs-2"; - type.clientData = INT2PTR(isLe.c); + type.clientData = INT2PTR(isLe.c|TCL_ENCODING_NOCOMPLAIN); Tcl_CreateEncoding(&type); type.toUtfProc = Utf32ToUtfProc; @@ -2468,15 +2468,16 @@ UtfToUtfProc( src += len; dst += Tcl_UniCharToUtf(ch, dst); ch = low; - } else if (!Tcl_UniCharIsUnicode(ch)) { - if (STOPONERROR) { - result = TCL_CONVERT_UNKNOWN; - src = saveSrc; - break; - } - if (!(flags & TCL_ENCODING_MODIFIED)) { - ch = 0xFFFD; - } + } else if (STOPONERROR && !(flags & TCL_ENCODING_MODIFIED) && !Tcl_UniCharIsUnicode(ch) + && (((ch & ~0x7FF) == 0xD800) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT))) { + result = TCL_CONVERT_UNKNOWN; + src = saveSrc; + break; + } else if (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) + && (flags & TCL_ENCODING_MODIFIED) && !Tcl_UniCharIsUnicode(ch)) { + result = TCL_CONVERT_SYNTAX; + src = saveSrc; + break; } dst += Tcl_UniCharToUtf(ch, dst); } diff --git a/tests/encoding.test b/tests/encoding.test index 9aa123d..1125397 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -688,6 +688,42 @@ test encoding-24.27 {Parse invalid utf-8 with -strict} -body { test encoding-24.28 {Parse invalid utf-8 with -strict} -body { encoding convertfrom -strict utf-8 "\xFF\x00\x00" } -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xFF'} +test encoding-24.29 {Parse invalid utf-8} -body { + encoding convertfrom utf-8 \xEF\xBF\xBF +} -result \uFFFF +test encoding-24.30 {Parse invalid utf-8 with -strict} -body { + encoding convertfrom -strict utf-8 \xEF\xBF\xBF +} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xEF'} +test encoding-24.31 {Parse invalid utf-8 with -nocomplain} -body { + encoding convertfrom -nocomplain utf-8 \xEF\xBF\xBF +} -result \uFFFF +test encoding-24.32 {Try to generate invalid utf-8} -body { + encoding convertto utf-8 \uFFFF +} -result \xEF\xBF\xBF +test encoding-24.33 {Try to generate invalid utf-8 with -strict} -body { + encoding convertto -strict utf-8 \uFFFF +} -returnCodes 1 -result {unexpected character at index 0: 'U+00FFFF'} +test encoding-24.34 {Try to generate invalid utf-8 with -nocomplain} -body { + encoding convertto -nocomplain utf-8 \uFFFF +} -result \xEF\xBF\xBF +test encoding-24.35 {Parse invalid utf-8} -constraints deprecated -body { + encoding convertfrom utf-8 \xED\xA0\x80 +} -result \uD800 +test encoding-24.36 {Parse invalid utf-8 with -strict} -body { + encoding convertfrom -strict utf-8 \xED\xA0\x80 +} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xED'} +test encoding-24.37 {Parse invalid utf-8 with -nocomplain} -body { + encoding convertfrom -nocomplain utf-8 \xED\xA0\x80 +} -result \uD800 +test encoding-24.38 {Try to generate invalid utf-8} -constraints deprecated -body { + encoding convertto utf-8 \uD800 +} -result \xED\xA0\x80 +test encoding-24.39 {Try to generate invalid utf-8 with -strict} -body { + encoding convertto -strict utf-8 \uD800 +} -returnCodes 1 -result {unexpected character at index 0: 'U+00D800'} +test encoding-24.40 {Try to generate invalid utf-8 with -nocomplain} -body { + encoding convertto -nocomplain utf-8 \uD800 +} -result \xED\xA0\x80 file delete [file join [temporaryDirectory] iso2022.txt] -- cgit v0.12 From 6d6996d99fb8dc3566f23a3b6fa22dfb0bda0a16 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 29 Nov 2022 16:05:33 +0000 Subject: make Windows dde (-> 1.4.5) and registry (-> 1.3.7) extensions ready for the Tcl 9.0 era. --- library/dde/pkgIndex.tcl | 6 +- library/registry/pkgIndex.tcl | 4 +- tests/registry.test | 4 +- tests/winDde.test | 4 +- win/Makefile.in | 4 +- win/makefile.vc | 4 +- win/tclWinDde.c | 93 ++++++++++++------------------- win/tclWinReg.c | 124 +++++++++++++++++++++++------------------- 8 files changed, 116 insertions(+), 127 deletions(-) diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl index 18ac517..ace1681 100644 --- a/library/dde/pkgIndex.tcl +++ b/library/dde/pkgIndex.tcl @@ -1,12 +1,12 @@ if {[info sharedlibextension] != ".dll"} return if {[package vsatisfies [package provide Tcl] 9.0-]} { - package ifneeded dde 1.4.4 \ + package ifneeded dde 1.4.5 \ [list load [file join $dir tcl9dde14.dll] Dde] } elseif {![package vsatisfies [package provide Tcl] 8.7] && [::tcl::pkgconfig get debug]} { - package ifneeded dde 1.4.4 \ + package ifneeded dde 1.4.5 \ [list load [file join $dir tcldde14g.dll] Dde] } else { - package ifneeded dde 1.4.4 \ + package ifneeded dde 1.4.5 \ [list load [file join $dir tcldde14.dll] Dde] } diff --git a/library/registry/pkgIndex.tcl b/library/registry/pkgIndex.tcl index 765f02a..edb4729 100644 --- a/library/registry/pkgIndex.tcl +++ b/library/registry/pkgIndex.tcl @@ -1,9 +1,9 @@ if {![package vsatisfies [package provide Tcl] 8.5-]} return if {[info sharedlibextension] != ".dll"} return if {[package vsatisfies [package provide Tcl] 9.0-]} { - package ifneeded registry 1.3.6 \ + package ifneeded registry 1.3.7 \ [list load [file join $dir tcl9registry13.dll] Registry] } else { - package ifneeded registry 1.3.6 \ + package ifneeded registry 1.3.7 \ [list load [file join $dir tclregistry13.dll] Registry] } diff --git a/tests/registry.test b/tests/registry.test index 4fc96bf..2f1fd8c 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -19,7 +19,7 @@ testConstraint reg 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - set ::regver [package require registry 1.3.6] + set ::regver [package require registry 1.3.7] }]} { testConstraint reg 1 } @@ -34,7 +34,7 @@ testConstraint english [expr { test registry-1.0 {check if we are testing the right dll} {win reg} { set ::regver -} {1.3.6} +} {1.3.7} test registry-1.1 {argument parsing for registry command} {win reg} { list [catch {registry} msg] $msg } {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}} diff --git a/tests/winDde.test b/tests/winDde.test index c56d27d..14308c7 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -19,7 +19,7 @@ testConstraint dde 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - set ::ddever [package require dde 1.4.4] + set ::ddever [package require dde 1.4.5] set ::ddelib [info loaded {} Dde]}]} { testConstraint dde 1 } @@ -105,7 +105,7 @@ proc createChildProcess {ddeServerName args} { # ------------------------------------------------------------------------- test winDde-1.0 {check if we are testing the right dll} {win dde} { set ::ddever -} {1.4.4} +} {1.4.5} test winDde-1.1 {Settings the server's topic name} -constraints dde -body { list [dde servername foobar] [dde servername] [dde servername self] diff --git a/win/Makefile.in b/win/Makefile.in index 689f9b8..6d7bb7d 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -157,8 +157,8 @@ TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX} TEST_EXE_FILE = tcltest${EXESUFFIX} TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${DLLSUFFIX}${LIBSUFFIX} TEST_LOAD_PRMS = lappend ::auto_path {$(ROOT_DIR_WIN_NATIVE)/tests};\ - package ifneeded dde 1.4.4 [list load [file normalize ${DDE_DLL_FILE}]];\ - package ifneeded registry 1.3.6 [list load [file normalize ${REG_DLL_FILE}]] + package ifneeded dde 1.4.5 [list load [file normalize ${DDE_DLL_FILE}]];\ + package ifneeded registry 1.3.7 [list load [file normalize ${REG_DLL_FILE}]] TEST_LOAD_FACILITIES = package ifneeded tcl::test ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest];\ $(TEST_LOAD_PRMS) ZLIB_DLL_FILE = zlib1.dll diff --git a/win/makefile.vc b/win/makefile.vc index e583ae0..1f0b02e 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -500,8 +500,8 @@ test: test-core test-pkgs test-core: setup $(TCLTEST) dlls set TCL_LIBRARY=$(ROOT:\=/)/library $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << - package ifneeded dde 1.4.4 [list load "$(TCLDDELIB:\=/)"] - package ifneeded registry 1.3.6 [list load "$(TCLREGLIB:\=/)"] + package ifneeded dde 1.4.5 [list load "$(TCLDDELIB:\=/)"] + package ifneeded registry 1.3.7 [list load "$(TCLREGLIB:\=/)"] << runtest: setup $(TCLTEST) dlls diff --git a/win/tclWinDde.c b/win/tclWinDde.c index 678eed3..e232471 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -79,7 +79,7 @@ static DWORD ddeInstance; /* The application instance handle given to us * by DdeInitialize. */ static int ddeIsServer = 0; -#define TCL_DDE_VERSION "1.4.4" +#define TCL_DDE_VERSION "1.4.5" #define TCL_DDE_PACKAGE_NAME "dde" #define TCL_DDE_SERVICE_NAME L"TclEval" #define TCL_DDE_EXECUTE_RESULT L"$TCLEVAL$EXECUTE$RESULT" @@ -117,7 +117,7 @@ static int DdeObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -#if (TCL_MAJOR_VERSION < 9) && (TCL_MINOR_VERSION < 7) +#if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7) # if TCL_UTF_MAX > 3 # define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf((TCHAR *)(a),(b)*sizeof(WCHAR),c) # define Tcl_UtfToWCharDString(a,b,c) (WCHAR *)Tcl_WinUtfToTChar(a,b,c) @@ -125,32 +125,20 @@ static int DdeObjCmd(void *clientData, # define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString # define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString # endif +#define Tcl_Size int +#define TCL_INDEX_NONE -1 #endif -static unsigned char * -getByteArrayFromObj( - Tcl_Obj *objPtr, - size_t *lengthPtr -) { - int length; - - unsigned char *result = Tcl_GetByteArrayFromObj(objPtr, &length); -#if TCL_MAJOR_VERSION > 8 - if (sizeof(TCL_HASH_TYPE) > sizeof(int)) { - /* 64-bit and TIP #494 situation: */ - *lengthPtr = *(TCL_HASH_TYPE *) objPtr->internalRep.twoPtrValue.ptr1; - } else -#endif - /* 32-bit or without TIP #494 */ - *lengthPtr = (size_t) (unsigned) length; - return result; -} - #ifdef __cplusplus extern "C" { #endif DLLEXPORT int Dde_Init(Tcl_Interp *interp); DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp); +#if TCL_MAJOR_VERSION < 9 +/* With those additional entries, "load dde14.dll" works without 3th argument */ +DLLEXPORT int Tcldde_Init(Tcl_Interp *interp); +DLLEXPORT int Tcldde_SafeInit(Tcl_Interp *interp); +#endif #ifdef __cplusplus } #endif @@ -410,7 +398,7 @@ DdeSetServerName( Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr); Tcl_DStringInit(&ds); - Tcl_UtfToWCharDString(Tcl_GetString(namePtr), -1, &ds); + Tcl_UtfToWCharDString(Tcl_GetString(namePtr), TCL_INDEX_NONE, &ds); if (wcscmp(actualName, (WCHAR *)Tcl_DStringValue(&ds)) == 0) { suffix++; Tcl_DStringFree(&ds); @@ -568,7 +556,7 @@ ExecuteRemoteObject( if ((riPtr->handlerPtr == NULL) && Tcl_IsSafe(riPtr->interp)) { Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: " "a handler procedure must be defined for use in a safe " - "interp", -1)); + "interp", TCL_INDEX_NONE)); Tcl_SetErrorCode(riPtr->interp, "TCL", "DDE", "SECURITY_CHECK", NULL); result = TCL_ERROR; } @@ -647,7 +635,7 @@ DdeServerProc( /* Transaction-dependent data. */ { Tcl_DString dString; - size_t len; + Tcl_Size len; DWORD dlen; WCHAR *utilString; Tcl_Obj *ddeObjectPtr; @@ -767,8 +755,7 @@ DdeServerProc( CP_WINUNICODE); if (_wcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) { returnString = - Tcl_GetString(convPtr->returnPackagePtr); - len = convPtr->returnPackagePtr->length; + Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len); if (uFmt != CF_TEXT) { Tcl_DStringInit(&dsBuf); Tcl_UtfToWCharDString(returnString, len, &dsBuf); @@ -790,8 +777,7 @@ DdeServerProc( convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, TCL_GLOBAL_ONLY); if (variableObjPtr != NULL) { - returnString = Tcl_GetString(variableObjPtr); - len = variableObjPtr->length; + returnString = Tcl_GetStringFromObj(variableObjPtr, &len); if (uFmt != CF_TEXT) { Tcl_DStringInit(&dsBuf); Tcl_UtfToWCharDString(returnString, len, &dsBuf); @@ -852,7 +838,7 @@ DdeServerProc( Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds2); utilString = (WCHAR *) Tcl_DStringValue(&ds2); } - variableObjPtr = Tcl_NewStringObj((char *)utilString, -1); + variableObjPtr = Tcl_NewStringObj((char *)utilString, TCL_INDEX_NONE); Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, variableObjPtr, TCL_GLOBAL_ONLY); @@ -1147,12 +1133,12 @@ DdeServicesOnAck( GlobalGetAtomNameW(service, sz, 255); Tcl_DStringInit(&dString); Tcl_WCharToUtfDString(sz, wcslen(sz), &dString); - Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); + Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), TCL_INDEX_NONE)); Tcl_DStringFree(&dString); GlobalGetAtomNameW(topic, sz, 255); Tcl_DStringInit(&dString); Tcl_WCharToUtfDString(sz, wcslen(sz), &dString); - Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); + Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), TCL_INDEX_NONE)); Tcl_DStringFree(&dString); /* @@ -1270,7 +1256,7 @@ SetDdeError( errorCode = "FAILED"; } - Tcl_SetObjResult(interp, Tcl_NewStringObj(errorMessage, -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(errorMessage, TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "DDE", errorCode, NULL); } @@ -1325,7 +1311,7 @@ DdeObjCmd( }; int index, i, argIndex; - size_t length; + Tcl_Size length; int flags = 0, result = TCL_OK, firstArg = 0; HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL; HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn; @@ -1488,9 +1474,8 @@ DdeObjCmd( Initialize(); if (firstArg != 1) { - const char *src = Tcl_GetString(objv[firstArg]); + const char *src = Tcl_GetStringFromObj(objv[firstArg], &length); - length = objv[firstArg]->length; Tcl_DStringInit(&serviceBuf); Tcl_UtfToWCharDString(src, length, &serviceBuf); serviceName = (WCHAR *) Tcl_DStringValue(&serviceBuf); @@ -1507,9 +1492,8 @@ DdeObjCmd( } if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) { - const char *src = Tcl_GetString(objv[firstArg + 1]); + const char *src = Tcl_GetStringFromObj(objv[firstArg + 1], &length); - length = objv[firstArg + 1]->length; Tcl_DStringInit(&topicBuf); topicName = Tcl_UtfToWCharDString(src, length, &topicBuf); length = Tcl_DStringLength(&topicBuf) / sizeof(WCHAR); @@ -1539,19 +1523,18 @@ DdeObjCmd( break; case DDE_EXECUTE: { - size_t dataLength; + Tcl_Size dataLength; const void *dataString; Tcl_DString dsBuf; Tcl_DStringInit(&dsBuf); if (flags & DDE_FLAG_BINARY) { dataString = - getByteArrayFromObj(objv[firstArg + 2], &dataLength); + Tcl_GetByteArrayFromObj(objv[firstArg + 2], &dataLength); } else { const char *src; - src = Tcl_GetString(objv[firstArg + 2]); - dataLength = objv[firstArg + 2]->length; + src = Tcl_GetStringFromObj(objv[firstArg + 2], &dataLength); Tcl_DStringInit(&dsBuf); dataString = Tcl_UtfToWCharDString(src, dataLength, &dsBuf); @@ -1560,7 +1543,7 @@ DdeObjCmd( if (dataLength + 1 < 2) { Tcl_SetObjResult(interp, - Tcl_NewStringObj("cannot execute null data", -1)); + Tcl_NewStringObj("cannot execute null data", TCL_INDEX_NONE)); Tcl_DStringFree(&dsBuf); Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); result = TCL_ERROR; @@ -1604,15 +1587,14 @@ DdeObjCmd( const WCHAR *itemString; const char *src; - src = Tcl_GetString(objv[firstArg + 2]); - length = objv[firstArg + 2]->length; + src = Tcl_GetStringFromObj(objv[firstArg + 2], &length); Tcl_DStringInit(&itemBuf); itemString = Tcl_UtfToWCharDString(src, length, &itemBuf); length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR); if (length == 0) { Tcl_SetObjResult(interp, - Tcl_NewStringObj("cannot request value of null data", -1)); + Tcl_NewStringObj("cannot request value of null data", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); result = TCL_ERROR; goto cleanup; @@ -1672,14 +1654,13 @@ DdeObjCmd( BYTE *dataString; const char *src; - src = Tcl_GetString(objv[firstArg + 2]); - length = objv[firstArg + 2]->length; + src = Tcl_GetStringFromObj(objv[firstArg + 2], &length); Tcl_DStringInit(&itemBuf); itemString = Tcl_UtfToWCharDString(src, length, &itemBuf); length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR); if (length == 0) { Tcl_SetObjResult(interp, - Tcl_NewStringObj("cannot have a null item", -1)); + Tcl_NewStringObj("cannot have a null item", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); result = TCL_ERROR; goto cleanup; @@ -1687,11 +1668,10 @@ DdeObjCmd( Tcl_DStringInit(&dsBuf); if (flags & DDE_FLAG_BINARY) { dataString = (BYTE *) - getByteArrayFromObj(objv[firstArg + 3], &length); + Tcl_GetByteArrayFromObj(objv[firstArg + 3], &length); } else { const char *data = - Tcl_GetString(objv[firstArg + 3]); - length = objv[firstArg + 3]->length; + Tcl_GetStringFromObj(objv[firstArg + 3], &length); Tcl_DStringInit(&dsBuf); dataString = (BYTE *) Tcl_UtfToWCharDString(data, length, &dsBuf); @@ -1734,7 +1714,7 @@ DdeObjCmd( if (serviceName == NULL) { Tcl_SetObjResult(interp, - Tcl_NewStringObj("invalid service name \"\"", -1)); + Tcl_NewStringObj("invalid service name \"\"", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL); result = TCL_ERROR; goto cleanup; @@ -1782,7 +1762,7 @@ DdeObjCmd( if (Tcl_IsSafe(riPtr->interp) && (riPtr->handlerPtr == NULL)) { Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj( "permission denied: a handler procedure must be" - " defined for use in a safe interp", -1)); + " defined for use in a safe interp", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "DDE", "SECURITY_CHECK", NULL); result = TCL_ERROR; @@ -1848,15 +1828,14 @@ DdeObjCmd( if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) { invalidServerResponse: Tcl_SetObjResult(interp, - Tcl_NewStringObj("invalid data returned from server", -1)); + Tcl_NewStringObj("invalid data returned from server", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "DDE", "BAD_RESPONSE", NULL); result = TCL_ERROR; goto cleanup; } objPtr = Tcl_ConcatObj(objc, objv); - string = Tcl_GetString(objPtr); - length = objPtr->length; + string = Tcl_GetStringFromObj(objPtr, &length); Tcl_DStringInit(&dsBuf); Tcl_UtfToWCharDString(string, length, &dsBuf); string = Tcl_DStringValue(&dsBuf); @@ -1906,7 +1885,7 @@ DdeObjCmd( length = DdeGetData(ddeData, NULL, 0, 0); ddeDataString = (WCHAR *) Tcl_Alloc(length); DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0); - if (length > sizeof(WCHAR)) { + if (length > (Tcl_Size)sizeof(WCHAR)) { length -= sizeof(WCHAR); } Tcl_DStringInit(&dsBuf); diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 2daf43e..6fafead 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -124,7 +124,7 @@ static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, Tcl_Obj *valueNameObj, Tcl_Obj *dataObj, Tcl_Obj *typeObj, REGSAM mode); -#if (TCL_MAJOR_VERSION < 9) && (TCL_MINOR_VERSION < 7) +#if (TCL_MAJOR_VERSION < 9) && defined(TCL_MINOR_VERSION) && (TCL_MINOR_VERSION < 7) # if TCL_UTF_MAX > 3 # define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf((TCHAR *)(a),(b)*sizeof(WCHAR),c) # define Tcl_UtfToWCharDString(a,b,c) (WCHAR *)Tcl_WinUtfToTChar(a,b,c) @@ -132,32 +132,20 @@ static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, # define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString # define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString # endif +#define Tcl_Size int +#define TCL_INDEX_NONE -1 #endif -static unsigned char * -getByteArrayFromObj( - Tcl_Obj *objPtr, - size_t *lengthPtr -) { - int length; - - unsigned char *result = Tcl_GetByteArrayFromObj(objPtr, &length); -#if TCL_MAJOR_VERSION > 8 - if (sizeof(TCL_HASH_TYPE) > sizeof(int)) { - /* 64-bit and TIP #494 situation: */ - *lengthPtr = *(TCL_HASH_TYPE *) objPtr->internalRep.twoPtrValue.ptr1; - } else -#endif - /* 32-bit or without TIP #494 */ - *lengthPtr = (size_t) (unsigned) length; - return result; -} - #ifdef __cplusplus extern "C" { #endif DLLEXPORT int Registry_Init(Tcl_Interp *interp); DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags); +#if TCL_MAJOR_VERSION < 9 +/* With those additional entries, "load registry13.dll" works without 3th argument */ +DLLEXPORT int Tclregistry_Init(Tcl_Interp *interp); +DLLEXPORT int Tclregistry_SafeInit(Tcl_Interp *interp); +#endif #ifdef __cplusplus } #endif @@ -191,8 +179,16 @@ Registry_Init( cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, interp, DeleteCmd); Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd); - return Tcl_PkgProvideEx(interp, "registry", "1.3.6", NULL); + return Tcl_PkgProvideEx(interp, "registry", "1.3.7", NULL); +} +#if TCL_MAJOR_VERSION < 9 +int +Tclregistry_Init( + Tcl_Interp *interp) +{ + return Registry_Init(interp); } +#endif /* *---------------------------------------------------------------------- @@ -223,9 +219,9 @@ Registry_Unload( * Unregister the registry package. There is no Tcl_PkgForget() */ - objv[0] = Tcl_NewStringObj("package", -1); - objv[1] = Tcl_NewStringObj("forget", -1); - objv[2] = Tcl_NewStringObj("registry", -1); + objv[0] = Tcl_NewStringObj("package", TCL_INDEX_NONE); + objv[1] = Tcl_NewStringObj("forget", TCL_INDEX_NONE); + objv[2] = Tcl_NewStringObj("registry", TCL_INDEX_NONE); Tcl_EvalObjv(interp, 3, objv, TCL_EVAL_GLOBAL); /* @@ -239,6 +235,15 @@ Registry_Unload( return TCL_OK; } +#if TCL_MAJOR_VERSION < 9 +int +Tclregistry_Unload( + Tcl_Interp *interp, + int flags) +{ + return Registry_Unload(interp, flags); +} +#endif /* *---------------------------------------------------------------------- @@ -438,13 +443,14 @@ DeleteKey( DWORD result; Tcl_DString buf; REGSAM saveMode = mode; + Tcl_Size len; /* * Find the parent of the key being deleted and open it. */ - keyName = Tcl_GetString(keyNameObj); - buffer = (char *)Tcl_Alloc(keyNameObj->length + 1); + keyName = Tcl_GetStringFromObj(keyNameObj, &len); + buffer = (char *)Tcl_Alloc(len + 1); strcpy(buffer, keyName); if (ParseKeyName(interp, buffer, &hostName, &rootKey, @@ -455,7 +461,7 @@ DeleteKey( if (*keyName == '\0') { Tcl_SetObjResult(interp, - Tcl_NewStringObj("bad key: cannot delete root keys", -1)); + Tcl_NewStringObj("bad key: cannot delete root keys", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "WIN_REG", "DEL_ROOT_KEY", NULL); Tcl_Free(buffer); return TCL_ERROR; @@ -477,7 +483,7 @@ DeleteKey( return TCL_OK; } Tcl_SetObjResult(interp, - Tcl_NewStringObj("unable to delete key: ", -1)); + Tcl_NewStringObj("unable to delete key: ", TCL_INDEX_NONE)); AppendSystemError(interp, result); return TCL_ERROR; } @@ -487,13 +493,13 @@ DeleteKey( */ Tcl_DStringInit(&buf); - nativeTail = Tcl_UtfToWCharDString(tail, -1, &buf); + nativeTail = Tcl_UtfToWCharDString(tail, TCL_INDEX_NONE, &buf); result = RecursiveDeleteKey(subkey, nativeTail, saveMode); Tcl_DStringFree(&buf); if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) { Tcl_SetObjResult(interp, - Tcl_NewStringObj("unable to delete key: ", -1)); + Tcl_NewStringObj("unable to delete key: ", TCL_INDEX_NONE)); AppendSystemError(interp, result); result = TCL_ERROR; } else { @@ -532,6 +538,7 @@ DeleteValue( char *valueName; DWORD result; Tcl_DString ds; + Tcl_Size len; /* * Attempt to open the key for deletion. @@ -542,9 +549,9 @@ DeleteValue( return TCL_ERROR; } - valueName = Tcl_GetString(valueNameObj); + valueName = Tcl_GetStringFromObj(valueNameObj, &len); Tcl_DStringInit(&ds); - Tcl_UtfToWCharDString(valueName, valueNameObj->length, &ds); + Tcl_UtfToWCharDString(valueName, len, &ds); result = RegDeleteValueW(key, (const WCHAR *)Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); if (result != ERROR_SUCCESS) { @@ -685,6 +692,7 @@ GetType( Tcl_DString ds; const char *valueName; const WCHAR *nativeValue; + Tcl_Size len; /* * Attempt to open the key for reading. @@ -699,9 +707,9 @@ GetType( * Get the type of the value. */ - valueName = Tcl_GetString(valueNameObj); + valueName = Tcl_GetStringFromObj(valueNameObj, &len); Tcl_DStringInit(&ds); - nativeValue = Tcl_UtfToWCharDString(valueName, valueNameObj->length, &ds); + nativeValue = Tcl_UtfToWCharDString(valueName, len, &ds); result = RegQueryValueExW(key, nativeValue, NULL, &type, NULL, NULL); Tcl_DStringFree(&ds); @@ -723,7 +731,7 @@ GetType( if (type > lastType) { Tcl_SetObjResult(interp, Tcl_NewIntObj((int) type)); } else { - Tcl_SetObjResult(interp, Tcl_NewStringObj(typeNames[type], -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(typeNames[type], TCL_INDEX_NONE)); } return TCL_OK; } @@ -757,6 +765,7 @@ GetValue( const WCHAR *nativeValue; DWORD result, length, type; Tcl_DString data, buf; + Tcl_Size len; /* * Attempt to open the key for reading. @@ -781,9 +790,9 @@ GetValue( Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1); length = TCL_DSTRING_STATIC_SIZE/sizeof(WCHAR) - 1; - valueName = Tcl_GetString(valueNameObj); + valueName = Tcl_GetStringFromObj(valueNameObj, &len); Tcl_DStringInit(&buf); - nativeValue = Tcl_UtfToWCharDString(valueName, valueNameObj->length, &buf); + nativeValue = Tcl_UtfToWCharDString(valueName, len, &buf); result = RegQueryValueExW(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); @@ -975,9 +984,10 @@ OpenKey( char *keyName, *buffer, *hostName; HKEY rootKey; DWORD result; + Tcl_Size len; - keyName = Tcl_GetString(keyNameObj); - buffer = (char *)Tcl_Alloc(keyNameObj->length + 1); + keyName = Tcl_GetStringFromObj(keyNameObj, &len); + buffer = (char *)Tcl_Alloc(len + 1); strcpy(buffer, keyName); result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName); @@ -985,7 +995,7 @@ OpenKey( result = OpenSubKey(hostName, rootKey, keyName, mode, flags, keyPtr); if (result != ERROR_SUCCESS) { Tcl_SetObjResult(interp, - Tcl_NewStringObj("unable to open key: ", -1)); + Tcl_NewStringObj("unable to open key: ", TCL_INDEX_NONE)); AppendSystemError(interp, result); result = TCL_ERROR; } else { @@ -1033,7 +1043,7 @@ OpenSubKey( if (hostName) { Tcl_DStringInit(&buf); - hostName = (char *) Tcl_UtfToWCharDString(hostName, -1, &buf); + hostName = (char *) Tcl_UtfToWCharDString(hostName, TCL_INDEX_NONE, &buf); result = RegConnectRegistryW((WCHAR *)hostName, rootKey, &rootKey); Tcl_DStringFree(&buf); @@ -1049,7 +1059,7 @@ OpenSubKey( if (keyName) { Tcl_DStringInit(&buf); - keyName = (char *) Tcl_UtfToWCharDString(keyName, -1, &buf); + keyName = (char *) Tcl_UtfToWCharDString(keyName, TCL_INDEX_NONE, &buf); } if (flags & REG_CREATE) { DWORD create; @@ -1153,7 +1163,7 @@ ParseKeyName( * Look for a matching root name. */ - rootObj = Tcl_NewStringObj(rootName, -1); + rootObj = Tcl_NewStringObj(rootName, TCL_INDEX_NONE); result = Tcl_GetIndexFromObj(interp, rootObj, rootKeyNames, "root name", TCL_EXACT, &index); Tcl_DecrRefCount(rootObj); @@ -1285,6 +1295,7 @@ SetValue( HKEY key; const char *valueName; Tcl_DString nameBuf; + Tcl_Size len; if (typeObj == NULL) { type = REG_SZ; @@ -1300,9 +1311,9 @@ SetValue( return TCL_ERROR; } - valueName = Tcl_GetString(valueNameObj); + valueName = Tcl_GetStringFromObj(valueNameObj, &len); Tcl_DStringInit(&nameBuf); - valueName = (char *) Tcl_UtfToWCharDString(valueName, valueNameObj->length, &nameBuf); + valueName = (char *) Tcl_UtfToWCharDString(valueName, len, &nameBuf); if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { int value; @@ -1335,9 +1346,9 @@ SetValue( Tcl_DStringInit(&data); for (i = 0; i < objc; i++) { - const char *bytes = Tcl_GetString(objv[i]); + const char *bytes = Tcl_GetStringFromObj(objv[i], &len); - Tcl_DStringAppend(&data, bytes, objv[i]->length); + Tcl_DStringAppend(&data, bytes, len); /* * Add a null character to separate this value from the next. @@ -1356,10 +1367,10 @@ SetValue( Tcl_DStringFree(&buf); } else if (type == REG_SZ || type == REG_EXPAND_SZ) { Tcl_DString buf; - const char *data = Tcl_GetString(dataObj); + const char *data = Tcl_GetStringFromObj(dataObj, &len); Tcl_DStringInit(&buf); - data = (char *) Tcl_UtfToWCharDString(data, dataObj->length, &buf); + data = (char *) Tcl_UtfToWCharDString(data, len, &buf); /* * Include the null in the length, padding if needed for WCHAR. @@ -1372,13 +1383,13 @@ SetValue( Tcl_DStringFree(&buf); } else { BYTE *data; - size_t bytelength; + Tcl_Size bytelength; /* * Store binary data in the registry. */ - data = (BYTE *) getByteArrayFromObj(dataObj, &bytelength); + data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &bytelength); result = RegSetValueExW(key, (WCHAR *) valueName, 0, (DWORD) type, data, (DWORD) bytelength); } @@ -1388,7 +1399,7 @@ SetValue( if (result != ERROR_SUCCESS) { Tcl_SetObjResult(interp, - Tcl_NewStringObj("unable to set value: ", -1)); + Tcl_NewStringObj("unable to set value: ", TCL_INDEX_NONE)); AppendSystemError(interp, result); return TCL_ERROR; } @@ -1421,15 +1432,14 @@ BroadcastValue( LRESULT result; DWORD_PTR sendResult; int timeout = 3000; - size_t len; + Tcl_Size len; const char *str; Tcl_Obj *objPtr; WCHAR *wstr; Tcl_DString ds; if (objc == 3) { - str = Tcl_GetString(objv[1]); - len = objv[1]->length; + str = Tcl_GetStringFromObj(objv[1], &len); if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", len)) { return TCL_BREAK; } @@ -1438,9 +1448,9 @@ BroadcastValue( } } - str = Tcl_GetString(objv[0]); + str = Tcl_GetStringFromObj(objv[0], &len); Tcl_DStringInit(&ds); - wstr = Tcl_UtfToWCharDString(str, objv[0]->length, &ds); + wstr = Tcl_UtfToWCharDString(str, len, &ds); if (Tcl_DStringLength(&ds) == 0) { wstr = NULL; } -- cgit v0.12 From a744c509d4d7d059d01a0e6331f134fe5383b370 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 29 Nov 2022 20:54:20 +0000 Subject: Remove ARGSUSED. More type-casts --- generic/tclConfig.c | 6 +-- generic/tclInt.decls | 10 ++--- generic/tclInt.h | 16 +++---- generic/tclIntDecls.h | 23 +++++----- generic/tclTrace.c | 94 ++++++++++++++++++++-------------------- generic/tclVar.c | 118 +++++++++++++++++++++----------------------------- 6 files changed, 121 insertions(+), 146 deletions(-) diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 2fb3e92..8ea1f4d 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -41,9 +41,7 @@ typedef struct QCCD { * Static functions in this file: */ -static int QueryConfigObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - struct Tcl_Obj *const *objv); +static Tcl_ObjCmdProc QueryConfigObjCmd; static void QueryConfigDelete(ClientData clientData); static Tcl_Obj * GetConfigDict(Tcl_Interp *interp); static void ConfigDictDeleteProc(ClientData clientData, @@ -197,7 +195,7 @@ QueryConfigObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, - struct Tcl_Obj *const *objv) + Tcl_Obj *const *objv) { QCCD *cdPtr = clientData; Tcl_Obj *pkgName = cdPtr->pkg; diff --git a/generic/tclInt.decls b/generic/tclInt.decls index c2d8253..c75c2e1 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -914,7 +914,7 @@ declare 229 { declare 230 { Var *TclObjLookupVar(Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, - const int createPart1, const int createPart2, Var **arrayPtrPtr) + int createPart1, int createPart2, Var **arrayPtrPtr) } declare 231 { int TclGetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -1018,17 +1018,17 @@ declare 251 { declare 252 { Tcl_Obj *TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - const int flags) + int flags) } declare 253 { Tcl_Obj *TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - Tcl_Obj *newValuePtr, const int flags) + Tcl_Obj *newValuePtr, int flags) } declare 254 { Tcl_Obj *TclPtrIncrObjVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - Tcl_Obj *incrPtr, const int flags) + Tcl_Obj *incrPtr, int flags) } declare 255 { int TclPtrObjMakeUpvar(Tcl_Interp *interp, Tcl_Var otherPtr, @@ -1036,7 +1036,7 @@ declare 255 { } declare 256 { int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, - Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags) + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags) } declare 257 { diff --git a/generic/tclInt.h b/generic/tclInt.h index 8c3efb5..3fa9a11 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -4017,30 +4017,30 @@ MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, MODULE_SCOPE Var * TclObjLookupVarEx(Tcl_Interp * interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags, - const char *msg, const int createPart1, - const int createPart2, Var **arrayPtrPtr); + const char *msg, int createPart1, + int createPart2, Var **arrayPtrPtr); MODULE_SCOPE Var * TclLookupArrayElement(Tcl_Interp *interp, Tcl_Obj *arrayNamePtr, Tcl_Obj *elNamePtr, - const int flags, const char *msg, - const int createPart1, const int createPart2, + int flags, const char *msg, + int createPart1, int createPart2, Var *arrayPtr, int index); MODULE_SCOPE Tcl_Obj * TclPtrGetVarIdx(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, const int flags, int index); + Tcl_Obj *part2Ptr, int flags, int index); MODULE_SCOPE Tcl_Obj * TclPtrSetVarIdx(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, - const int flags, int index); + int flags, int index); MODULE_SCOPE Tcl_Obj * TclPtrIncrObjVarIdx(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, - const int flags, int index); + int flags, int index); MODULE_SCOPE int TclPtrObjMakeUpvarIdx(Tcl_Interp *interp, Var *otherPtr, Tcl_Obj *myNamePtr, int myFlags, int index); MODULE_SCOPE int TclPtrUnsetVarIdx(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, const int flags, + Tcl_Obj *part2Ptr, int flags, int index); MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr); MODULE_SCOPE void TclFindArrayPtrElements(Var *arrayPtr, diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index c524608..e958733 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -551,9 +551,8 @@ EXTERN int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr, /* 230 */ EXTERN Var * TclObjLookupVar(Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, - int flags, const char *msg, - const int createPart1, const int createPart2, - Var **arrayPtrPtr); + int flags, const char *msg, int createPart1, + int createPart2, Var **arrayPtrPtr); /* 231 */ EXTERN int TclGetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); @@ -619,17 +618,17 @@ EXTERN int TclRegisterLiteral(void *envPtr, char *bytes, /* 252 */ EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, const int flags); + Tcl_Obj *part2Ptr, int flags); /* 253 */ EXTERN Tcl_Obj * TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, - const int flags); + int flags); /* 254 */ EXTERN Tcl_Obj * TclPtrIncrObjVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, - const int flags); + int flags); /* 255 */ EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, @@ -637,7 +636,7 @@ EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp, /* 256 */ EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, const int flags); + Tcl_Obj *part2Ptr, int flags); /* 257 */ EXTERN void TclStaticPackage(Tcl_Interp *interp, const char *prefix, @@ -883,7 +882,7 @@ typedef struct TclIntStubs { void (*tclSetNsPath) (Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]); /* 227 */ void (*reserved228)(void); int (*tclPtrMakeUpvar) (Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); /* 229 */ - Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, const int createPart1, const int createPart2, Var **arrayPtrPtr); /* 230 */ + Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, int createPart1, int createPart2, Var **arrayPtrPtr); /* 230 */ int (*tclGetNamespaceFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); /* 231 */ int (*tclEvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 232 */ void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */ @@ -905,11 +904,11 @@ typedef struct TclIntStubs { char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ int (*tclRegisterLiteral) (void *envPtr, char *bytes, int length, int flags); /* 251 */ - Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 252 */ - Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, const int flags); /* 253 */ - Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags); /* 254 */ + Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 252 */ + Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 253 */ + Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); /* 254 */ int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */ - int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */ + int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 256 */ void (*tclStaticPackage) (Tcl_Interp *interp, const char *prefix, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */ void (*reserved258)(void); void (*reserved259)(void); diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 87fe063..8c1c79d 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -182,7 +182,6 @@ typedef struct StringTraceData { *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_TraceObjCmd( ClientData dummy, /* Not used. */ @@ -271,7 +270,8 @@ Tcl_TraceObjCmd( case TRACE_OLD_VDELETE: { Tcl_Obj *copyObjv[6]; Tcl_Obj *opsList; - int code, numFlags; + int code; + int numFlags; if (objc != 5) { Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); @@ -325,7 +325,7 @@ Tcl_TraceObjCmd( TclNewObj(resultListPtr); name = Tcl_GetString(objv[2]); FOREACH_VAR_TRACE(interp, name, clientData) { - TraceVarInfo *tvarPtr = clientData; + TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData; char *q = ops; pairObjPtr = Tcl_NewListObj(0, NULL); @@ -467,9 +467,9 @@ TraceExecutionObjCmd( } } command = Tcl_GetStringFromObj(objv[5], &commandLength); - length = (size_t) commandLength; + length = commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { - TraceCommandInfo *tcmdPtr = ckalloc( + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)ckalloc( TclOffset(TraceCommandInfo, command) + 1 + length); tcmdPtr->flags = flags; @@ -509,7 +509,7 @@ TraceExecutionObjCmd( } FOREACH_COMMAND_TRACE(interp, name, clientData) { - TraceCommandInfo *tcmdPtr = clientData; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; /* * In checking the 'flags' field we must remove any extraneous @@ -521,7 +521,7 @@ TraceExecutionObjCmd( && ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC | TCL_TRACE_RENAME | TCL_TRACE_DELETE)) == flags) && (strncmp(command, tcmdPtr->command, - (size_t) length) == 0)) { + length) == 0)) { flags |= TCL_TRACE_DELETE; if (flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC)) { @@ -578,7 +578,7 @@ TraceExecutionObjCmd( FOREACH_COMMAND_TRACE(interp, name, clientData) { int numOps = 0; Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr; - TraceCommandInfo *tcmdPtr = clientData; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; /* * Build a list with the ops list as the first obj element and the @@ -661,8 +661,8 @@ TraceCommandObjCmd( switch ((enum traceOptions) optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { - int flags = 0; - int i, listLen, result; + int flags = 0, result; + int i, listLen; Tcl_Obj **elemPtrs; if (objc != 6) { @@ -704,9 +704,9 @@ TraceCommandObjCmd( } command = Tcl_GetStringFromObj(objv[5], &commandLength); - length = (size_t) commandLength; + length = commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { - TraceCommandInfo *tcmdPtr = ckalloc( + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)ckalloc( TclOffset(TraceCommandInfo, command) + 1 + length); tcmdPtr->flags = flags; @@ -742,11 +742,11 @@ TraceCommandObjCmd( } FOREACH_COMMAND_TRACE(interp, name, clientData) { - TraceCommandInfo *tcmdPtr = clientData; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; if ((tcmdPtr->length == length) && (tcmdPtr->flags == flags) && (strncmp(command, tcmdPtr->command, - (size_t) length) == 0)) { + length) == 0)) { Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE, TraceCommandProc, clientData); tcmdPtr->flags |= TCL_TRACE_DESTROYED; @@ -781,7 +781,7 @@ TraceCommandObjCmd( FOREACH_COMMAND_TRACE(interp, name, clientData) { int numOps = 0; Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr; - TraceCommandInfo *tcmdPtr = clientData; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; /* * Build a list with the ops list as the first obj element and the @@ -860,8 +860,8 @@ TraceVariableObjCmd( switch ((enum traceOptions) optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { - int flags = 0; - int i, listLen, result; + int flags = 0, result; + int i, listLen; Tcl_Obj **elemPtrs; if (objc != 6) { @@ -907,9 +907,9 @@ TraceVariableObjCmd( } } command = Tcl_GetStringFromObj(objv[5], &commandLength); - length = (size_t) commandLength; + length = commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { - CombinedTraceVarInfo *ctvarPtr = ckalloc( + CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)ckalloc( TclOffset(CombinedTraceVarInfo, traceCmdInfo.command) + 1 + length); @@ -940,7 +940,7 @@ TraceVariableObjCmd( name = Tcl_GetString(objv[3]); FOREACH_VAR_TRACE(interp, name, clientData) { - TraceVarInfo *tvarPtr = clientData; + TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData; if ((tvarPtr->length == length) && ((tvarPtr->flags @@ -949,7 +949,7 @@ TraceVariableObjCmd( #endif )==flags) && (strncmp(command, tvarPtr->command, - (size_t) length) == 0)) { + length) == 0)) { Tcl_UntraceVar2(interp, name, NULL, flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT, TraceVarProc, clientData); @@ -971,7 +971,7 @@ TraceVariableObjCmd( name = Tcl_GetString(objv[3]); FOREACH_VAR_TRACE(interp, name, clientData) { Tcl_Obj *opObjPtr, *eachTraceObjPtr, *elemObjPtr; - TraceVarInfo *tvarPtr = clientData; + TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData; /* * Build a list with the ops list as the first obj element and the @@ -1126,7 +1126,7 @@ Tcl_TraceCommand( * Set up trace information. */ - tracePtr = ckalloc(sizeof(CommandTrace)); + tracePtr = (CommandTrace *)ckalloc(sizeof(CommandTrace)); tracePtr->traceProc = proc; tracePtr->clientData = clientData; tracePtr->flags = flags & @@ -1278,7 +1278,6 @@ Tcl_UntraceCommand( *---------------------------------------------------------------------- */ - /* ARGSUSED */ static void TraceCommandProc( ClientData clientData, /* Information about the command trace. */ @@ -1290,7 +1289,7 @@ TraceCommandProc( int flags) /* OR-ed bits giving operation and other * information. */ { - TraceCommandInfo *tcmdPtr = clientData; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; int code; Tcl_DString cmd; @@ -1304,7 +1303,7 @@ TraceCommandProc( */ Tcl_DStringInit(&cmd); - Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length); + Tcl_DStringAppend(&cmd, tcmdPtr->command, tcmdPtr->length); Tcl_DStringAppendElement(&cmd, oldName); Tcl_DStringAppendElement(&cmd, (newName ? newName : "")); if (flags & TCL_TRACE_RENAME) { @@ -1468,7 +1467,7 @@ TclCheckExecutionTraces( active.nextTracePtr = tracePtr->nextPtr; } if (tracePtr->traceProc == TraceCommandProc) { - TraceCommandInfo *tcmdPtr = tracePtr->clientData; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)tracePtr->clientData; if (tcmdPtr->flags != 0) { tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT; @@ -1609,7 +1608,7 @@ TclCheckInterpTraces( if (tracePtr->flags & traceFlags) { if (tracePtr->proc == TraceExecutionProc) { - TraceCommandInfo *tcmdPtr = tracePtr->clientData; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)tracePtr->clientData; tcmdPtr->curFlags = traceFlags; tcmdPtr->curCode = code; @@ -1688,7 +1687,7 @@ CallTraceFunction( * Copy the command characters into a new string. */ - commandCopy = TclStackAlloc(interp, numChars + 1); + commandCopy = (char *)TclStackAlloc(interp, numChars + 1); memcpy(commandCopy, command, numChars); commandCopy[numChars] = '\0'; @@ -1724,7 +1723,7 @@ static void CommandObjTraceDeleted( ClientData clientData) { - TraceCommandInfo *tcmdPtr = clientData; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; if (tcmdPtr->refCount-- <= 1) { ckfree(tcmdPtr); @@ -1764,11 +1763,11 @@ TraceExecutionProc( const char *command, Tcl_Command cmdInfo, int objc, - struct Tcl_Obj *const objv[]) + Tcl_Obj *const objv[]) { int call = 0; Interp *iPtr = (Interp *) interp; - TraceCommandInfo *tcmdPtr = clientData; + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; int flags = tcmdPtr->curFlags; int code = tcmdPtr->curCode; int traceCode = TCL_OK; @@ -1821,7 +1820,7 @@ TraceExecutionProc( int i, saveInterpFlags; Tcl_DStringInit(&cmd); - Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length); + Tcl_DStringAppend(&cmd, tcmdPtr->command, tcmdPtr->length); /* * Append command with arguments. @@ -1922,7 +1921,7 @@ TraceExecutionProc( unsigned len = strlen(command) + 1; tcmdPtr->startLevel = level; - tcmdPtr->startCmd = ckalloc(len); + tcmdPtr->startCmd = (char *)ckalloc(len); memcpy(tcmdPtr->startCmd, command, len); tcmdPtr->refCount++; tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, @@ -1963,7 +1962,6 @@ TraceExecutionProc( *---------------------------------------------------------------------- */ - /* ARGSUSED */ static char * TraceVarProc( ClientData clientData, /* Information about the variable trace. */ @@ -1974,7 +1972,7 @@ TraceVarProc( int flags) /* OR-ed bits giving operation and other * information. */ { - TraceVarInfo *tvarPtr = clientData; + TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData; char *result; int code, destroy = 0; Tcl_DString cmd; @@ -1990,14 +1988,14 @@ TraceVarProc( result = NULL; if ((tvarPtr->flags & flags) && !Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) { - if (tvarPtr->length != (size_t) 0) { + if (tvarPtr->length) { /* * Generate a command to execute by appending list elements for * the two variable names and the operation. */ Tcl_DStringInit(&cmd); - Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length); + Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length); Tcl_DStringAppendElement(&cmd, name1); Tcl_DStringAppendElement(&cmd, (name2 ? name2 : "")); #ifndef TCL_REMOVE_OBSOLETE_TRACES @@ -2162,7 +2160,7 @@ Tcl_CreateObjTrace( iPtr->tracesForbiddingInline++; } - tracePtr = ckalloc(sizeof(Trace)); + tracePtr = (Trace *)ckalloc(sizeof(Trace)); tracePtr->level = level; tracePtr->proc = proc; tracePtr->clientData = clientData; @@ -2225,7 +2223,7 @@ Tcl_CreateTrace( * command. */ ClientData clientData) /* Arbitrary value word to pass to proc. */ { - StringTraceData *data = ckalloc(sizeof(StringTraceData)); + StringTraceData *data = (StringTraceData *)ckalloc(sizeof(StringTraceData)); data->clientData = clientData; data->proc = proc; @@ -2259,7 +2257,7 @@ StringTraceProc( int objc, Tcl_Obj *const *objv) { - StringTraceData *data = clientData; + StringTraceData *data = (StringTraceData *)clientData; Command *cmdPtr = (Command *) commandInfo; const char **argv; /* Args to pass to string trace proc */ int i; @@ -2270,7 +2268,7 @@ StringTraceProc( */ argv = (const char **) TclStackAlloc(interp, - (unsigned) ((objc + 1) * sizeof(const char *))); + (objc + 1) * sizeof(const char *)); for (i = 0; i < objc; i++) { argv[i] = Tcl_GetString(objv[i]); } @@ -2657,7 +2655,7 @@ TclCallVarTraces( && (arrayPtr->flags & traceflags)) { hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) arrayPtr); active.varPtr = arrayPtr; - for (tracePtr = Tcl_GetHashValue(hPtr); + for (tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr); tracePtr != NULL; tracePtr = active.nextTracePtr) { active.nextTracePtr = tracePtr->nextPtr; if (!(tracePtr->flags & flags)) { @@ -2701,7 +2699,7 @@ TclCallVarTraces( active.varPtr = varPtr; if (varPtr->flags & traceflags) { hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); - for (tracePtr = Tcl_GetHashValue(hPtr); + for (tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr); tracePtr != NULL; tracePtr = active.nextTracePtr) { active.nextTracePtr = tracePtr->nextPtr; if (!(tracePtr->flags & flags)) { @@ -2937,7 +2935,7 @@ Tcl_UntraceVar2( flags &= flagMask; hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); - for (tracePtr = Tcl_GetHashValue(hPtr), prevPtr = NULL; ; + for (tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr), prevPtr = NULL; ; prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { goto updateFlags; @@ -3094,7 +3092,7 @@ Tcl_VarTraceInfo2( hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); if (hPtr) { - VarTrace *tracePtr = Tcl_GetHashValue(hPtr); + VarTrace *tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr); if (prevClientData != NULL) { for (; tracePtr != NULL; tracePtr = tracePtr->nextPtr) { @@ -3193,7 +3191,7 @@ Tcl_TraceVar2( VarTrace *tracePtr; int result; - tracePtr = ckalloc(sizeof(VarTrace)); + tracePtr = (VarTrace *)ckalloc(sizeof(VarTrace)); tracePtr->traceProc = proc; tracePtr->clientData = clientData; tracePtr->flags = flags; @@ -3287,7 +3285,7 @@ TraceVarEx( if (isNew) { tracePtr->nextPtr = NULL; } else { - tracePtr->nextPtr = Tcl_GetHashValue(hPtr); + tracePtr->nextPtr = (VarTrace *)Tcl_GetHashValue(hPtr); } Tcl_SetHashValue(hPtr, tracePtr); diff --git a/generic/tclVar.c b/generic/tclVar.c index a8d6664..6f0ec89 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -9,8 +9,8 @@ * * Copyright (c) 1987-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. - * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 1998-1999 Scriptics Corporation. + * Copyright (c) 2001 Kevin B. Kenny. All rights reserved. * Copyright (c) 2007 Miguel Sofer * * See the file "license.terms" for information on usage and redistribution of @@ -63,11 +63,10 @@ VarHashCreateVar( Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table, key, newPtr); - if (hPtr) { - return VarHashGetValue(hPtr); - } else { + if (!hPtr) { return NULL; } + return VarHashGetValue(hPtr); } #define VarHashFindVar(tablePtr, key) \ @@ -92,11 +91,10 @@ VarHashFirstVar( { Tcl_HashEntry *hPtr = VarHashFirstEntry(tablePtr, searchPtr); - if (hPtr) { - return VarHashGetValue(hPtr); - } else { + if (!hPtr) { return NULL; } + return VarHashGetValue(hPtr); } static inline Var * @@ -105,11 +103,10 @@ VarHashNextVar( { Tcl_HashEntry *hPtr = VarHashNextEntry(searchPtr); - if (hPtr) { - return VarHashGetValue(hPtr); - } else { + if (!hPtr) { return NULL; } + return VarHashGetValue(hPtr); } #define VarHashGetKey(varPtr) \ @@ -184,7 +181,7 @@ static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp, int flags); static int ObjMakeUpvar(Tcl_Interp *interp, CallFrame *framePtr, Tcl_Obj *otherP1Ptr, - const char *otherP2, const int otherFlags, + const char *otherP2, int otherFlags, Tcl_Obj *myNamePtr, int myFlags, int index); static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr, Tcl_Obj *varNamePtr, Tcl_Obj *handleObj); @@ -200,7 +197,7 @@ static int SetArraySearchObj(Tcl_Interp *interp, */ MODULE_SCOPE Var * TclLookupSimpleVar(Tcl_Interp *interp, - Tcl_Obj *varNamePtr, int flags, const int create, + Tcl_Obj *varNamePtr, int flags, int create, const char **errMsgPtr, int *indexPtr); static Tcl_DupInternalRepProc DupLocalVarName; @@ -499,10 +496,10 @@ TclObjLookupVar( const char *msg, /* Verb to use in error messages, e.g. "read" * or "set". Only needed if TCL_LEAVE_ERR_MSG * is set in flags. */ - const int createPart1, /* If 1, create hash table entry for part 1 of + int createPart1, /* If 1, create hash table entry for part 1 of * name, if it doesn't already exist. If 0, * return error if it doesn't exist. */ - const int createPart2, /* If 1, create hash table entry for part 2 of + int createPart2, /* If 1, create hash table entry for part 2 of * name, if it doesn't already exist. If 0, * return error if it doesn't exist. */ Var **arrayPtrPtr) /* If the name refers to an element of an @@ -549,10 +546,10 @@ TclObjLookupVarEx( const char *msg, /* Verb to use in error messages, e.g. "read" * or "set". Only needed if TCL_LEAVE_ERR_MSG * is set in flags. */ - const int createPart1, /* If 1, create hash table entry for part 1 of + int createPart1, /* If 1, create hash table entry for part 1 of * name, if it doesn't already exist. If 0, * return error if it doesn't exist. */ - const int createPart2, /* If 1, create hash table entry for part 2 of + int createPart2, /* If 1, create hash table entry for part 2 of * name, if it doesn't already exist. If 0, * return error if it doesn't exist. */ Var **arrayPtrPtr) /* If the name refers to an element of an @@ -827,7 +824,7 @@ TclLookupSimpleVar( int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_AVOID_RESOLVERS and TCL_LEAVE_ERR_MSG * bits matter. */ - const int create, /* If 1, create hash table entry for varname, + int create, /* If 1, create hash table entry for varname, * if it doesn't already exist. If 0, return * error if it doesn't exist. */ const char **errMsgPtr, @@ -996,7 +993,7 @@ TclLookupSimpleVar( tablePtr = varFramePtr->varTablePtr; if (create) { if (tablePtr == NULL) { - tablePtr = ckalloc(sizeof(TclVarHashTable)); + tablePtr = (TclVarHashTable *)ckalloc(sizeof(TclVarHashTable)); TclInitVarHashTable(tablePtr, NULL); varFramePtr->varTablePtr = tablePtr; } @@ -1059,15 +1056,15 @@ TclLookupArrayElement( Tcl_Obj *arrayNamePtr, /* This is the name of the array, or NULL if * index>= 0. */ Tcl_Obj *elNamePtr, /* Name of element within array. */ - const int flags, /* Only TCL_LEAVE_ERR_MSG bit matters. */ + int flags, /* Only TCL_LEAVE_ERR_MSG bit matters. */ const char *msg, /* Verb to use in error messages, e.g. "read" * or "set". Only needed if TCL_LEAVE_ERR_MSG * is set in flags. */ - const int createArray, /* If 1, transform arrayName to be an array if + int createArray, /* If 1, transform arrayName to be an array if * it isn't one yet and the transformation is * possible. If 0, return error if it isn't * already an array. */ - const int createElem, /* If 1, create hash table entry for the + int createElem, /* If 1, create hash table entry for the * element, if it doesn't already exist. If 0, * return error if it doesn't exist. */ Var *arrayPtr, /* Pointer to the array's Var structure. */ @@ -1389,7 +1386,7 @@ TclPtrGetVar( * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ - const int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and + int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ { if (varPtr == NULL) { @@ -1435,7 +1432,7 @@ TclPtrGetVarIdx( * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ - const int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and + int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ int index) /* Index into the local variable table of the * variable, or -1. Only used when part1Ptr is @@ -1508,7 +1505,6 @@ TclPtrGetVarIdx( *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_SetObjCmd( ClientData dummy, /* Not used. */ @@ -1809,7 +1805,7 @@ TclPtrSetVar( Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ Tcl_Obj *newValuePtr, /* New value for variable. */ - const int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and + int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ { if (varPtr == NULL) { @@ -1864,7 +1860,7 @@ TclPtrSetVarIdx( Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ Tcl_Obj *newValuePtr, /* New value for variable. */ - const int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and + int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ int index) /* Index of local var where part1 is to be * found. */ @@ -2141,7 +2137,7 @@ TclPtrIncrObjVar( * part1Ptr. */ Tcl_Obj *incrPtr, /* Increment value. */ /* TODO: Which of these flag values really make sense? */ - const int flags) /* Various flags that tell how to incr value: + int flags) /* Various flags that tell how to incr value: * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, * TCL_LEAVE_ERR_MSG. */ @@ -2197,7 +2193,7 @@ TclPtrIncrObjVarIdx( * part1Ptr. */ Tcl_Obj *incrPtr, /* Increment value. */ /* TODO: Which of these flag values really make sense? */ - const int flags, /* Various flags that tell how to incr value: + int flags, /* Various flags that tell how to incr value: * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, * TCL_LEAVE_ERR_MSG. */ @@ -2232,7 +2228,6 @@ TclPtrIncrObjVarIdx( } else { /* Unshared - can Incr in place */ if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) { - /* * This seems dumb to write the incremeted value into the var * after we just adjusted the value in place, but the spec for @@ -2425,7 +2420,7 @@ TclPtrUnsetVar( * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ - const int flags) /* OR-ed combination of any of + int flags) /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_LEAVE_ERR_MSG. */ { @@ -2472,7 +2467,7 @@ TclPtrUnsetVarIdx( * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ - const int flags, /* OR-ed combination of any of + int flags, /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_LEAVE_ERR_MSG. */ int index) /* Index into the local variable table of the @@ -2598,7 +2593,7 @@ UnsetVarStruct( int isNew; tPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr); - tracePtr = Tcl_GetHashValue(tPtr); + tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr); varPtr->flags &= ~VAR_ALL_TRACES; Tcl_DeleteHashEntry(tPtr); if (dummyVar.flags & VAR_TRACED_UNSET) { @@ -2625,7 +2620,7 @@ UnsetVarStruct( if (TclIsVarTraced(&dummyVar)) { tPtr = Tcl_FindHashEntry(&iPtr->varTraces, &dummyVar); if (tPtr) { - tracePtr = Tcl_GetHashValue(tPtr); + tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr); Tcl_DeleteHashEntry(tPtr); } } @@ -2711,7 +2706,6 @@ UnsetVarStruct( *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_UnsetObjCmd( ClientData dummy, /* Not used. */ @@ -2779,7 +2773,6 @@ Tcl_UnsetObjCmd( *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_AppendObjCmd( ClientData dummy, /* Not used. */ @@ -2845,7 +2838,6 @@ Tcl_AppendObjCmd( *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_LappendObjCmd( ClientData dummy, /* Not used. */ @@ -2987,7 +2979,6 @@ Tcl_LappendObjCmd( *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int ArrayStartSearchCmd( ClientData clientData, @@ -3056,7 +3047,6 @@ ArrayStartSearchCmd( *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int ArrayAnyMoreCmd( ClientData clientData, @@ -3135,7 +3125,6 @@ ArrayAnyMoreCmd( *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int ArrayNextElementCmd( ClientData clientData, @@ -3216,7 +3205,6 @@ ArrayNextElementCmd( *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int ArrayDoneSearchCmd( ClientData clientData, @@ -3297,7 +3285,6 @@ ArrayDoneSearchCmd( *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int ArrayExistsCmd( ClientData clientData, @@ -3338,7 +3325,6 @@ ArrayExistsCmd( *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int ArrayGetCmd( ClientData clientData, @@ -3498,7 +3484,6 @@ ArrayGetCmd( *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int ArrayNamesCmd( ClientData clientData, @@ -3509,7 +3494,7 @@ ArrayNamesCmd( static const char *const options[] = { "-exact", "-glob", "-regexp", NULL }; - enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; + enum arrayNamesOptionsEnum { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; Var *varPtr, *varPtr2; Tcl_Obj *nameObj, *resultObj, *patternObj; Tcl_HashSearch search; @@ -3577,7 +3562,7 @@ ArrayNamesCmd( const char *name = TclGetString(nameObj); int matched = 0; - switch ((enum options) mode) { + switch ((enum arrayNamesOptionsEnum) mode) { case OPT_EXACT: Tcl_Panic("exact matching shouldn't get here"); case OPT_GLOB: @@ -3666,7 +3651,6 @@ TclFindArrayPtrElements( *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int ArraySetCmd( ClientData clientData, @@ -3786,7 +3770,8 @@ ArraySetCmd( if ((elemVarPtr == NULL) || (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj, - elemPtrs[i],elemPtrs[i+1],TCL_LEAVE_ERR_MSG,-1) == NULL)){ + elemPtrs[i], elemPtrs[i+1], TCL_LEAVE_ERR_MSG, + -1) == NULL)) { result = TCL_ERROR; break; } @@ -3843,7 +3828,6 @@ ArraySetCmd( *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int ArraySizeCmd( ClientData clientData, @@ -3903,7 +3887,6 @@ ArraySizeCmd( *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int ArrayStatsCmd( ClientData clientData, @@ -3958,7 +3941,6 @@ ArrayStatsCmd( *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int ArrayUnsetCmd( ClientData clientData, @@ -3970,7 +3952,7 @@ ArrayUnsetCmd( Tcl_Obj *varNameObj, *patternObj, *nameObj; Tcl_HashSearch search; const char *pattern; - const int unsetFlags = 0; /* Should this be TCL_LEAVE_ERR_MSG? */ + int unsetFlags = 0; /* Should this be TCL_LEAVE_ERR_MSG? */ int isArray; switch (objc) { @@ -4095,7 +4077,6 @@ ArrayUnsetCmd( *---------------------------------------------------------------------- */ - /* ARGSUSED */ Tcl_Command TclInitArrayCmd( Tcl_Interp *interp) /* Current interpreter. */ @@ -4128,7 +4109,7 @@ TclInitArrayCmd( * * Results: * A standard Tcl completion code. If an error occurs then an error - * message is left in iPtr->result. + * message is left in interp. * * Side effects: * The variable given by myName is linked to the variable in framePtr @@ -4148,7 +4129,7 @@ ObjMakeUpvar( * NULL means use global :: context. */ Tcl_Obj *otherP1Ptr, const char *otherP2, /* Two-part name of variable in framePtr. */ - const int otherFlags, /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: + int otherFlags, /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: * indicates scope of "other" variable. */ Tcl_Obj *myNamePtr, /* Name of variable which will refer to * otherP1/otherP2. Must be a scalar. */ @@ -4222,7 +4203,7 @@ ObjMakeUpvar( * * Results: * A standard Tcl completion code. If an error occurs then an error - * message is left in iPtr->result. + * message is left in interp. * * Side effects: * The variable given by myName is linked to the variable in framePtr @@ -4818,7 +4799,6 @@ Tcl_VariableObjCmd( *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_UpvarObjCmd( ClientData dummy, /* Not used. */ @@ -5089,7 +5069,7 @@ DeleteSearches( if (arrayVarPtr->flags & VAR_SEARCH_ACTIVE) { sPtr = Tcl_FindHashEntry(&iPtr->varSearches, arrayVarPtr); - for (searchPtr = Tcl_GetHashValue(sPtr); searchPtr != NULL; + for (searchPtr = (ArraySearch *)Tcl_GetHashValue(sPtr); searchPtr != NULL; searchPtr = nextPtr) { nextPtr = searchPtr->nextPtr; ckfree(searchPtr); @@ -5159,7 +5139,7 @@ TclDeleteNamespaceVars( if (TclIsVarTraced(varPtr)) { Tcl_HashEntry *tPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr); - VarTrace *tracePtr = Tcl_GetHashValue(tPtr); + VarTrace *tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr); ActiveVarTrace *activePtr; while (tracePtr) { @@ -5356,7 +5336,7 @@ DeleteArray( elNamePtr, flags,/* leaveErrMsg */ 0, index); } tPtr = Tcl_FindHashEntry(&iPtr->varTraces, elPtr); - tracePtr = Tcl_GetHashValue(tPtr); + tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr); while (tracePtr) { VarTrace *prevPtr = tracePtr; @@ -5497,7 +5477,7 @@ static void FreeLocalVarName( Tcl_Obj *objPtr) { - Tcl_Obj *namePtr = objPtr->internalRep.twoPtrValue.ptr1; + Tcl_Obj *namePtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1; if (namePtr) { Tcl_DecrRefCount(namePtr); @@ -5559,7 +5539,7 @@ DupParsedVarName( if (arrayPtr != NULL) { Tcl_IncrRefCount(arrayPtr); elemLen = strlen(elem); - elemCopy = ckalloc(elemLen + 1); + elemCopy = (char *)ckalloc(elemLen + 1); memcpy(elemCopy, elem, elemLen); *(elemCopy + elemLen) = '\0'; elem = elemCopy; @@ -5931,7 +5911,7 @@ TclInfoVarsCmd( */ if ((nsPtr != globalNsPtr) && !specificNsInPattern) { - varPtr = VarHashFirstVar(&globalNsPtr->varTable,&search); + varPtr = VarHashFirstVar(&globalNsPtr->varTable, &search); while (varPtr) { if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) { @@ -6270,11 +6250,11 @@ AllocVarEntry( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key to store in the hash table entry. */ { - Tcl_Obj *objPtr = keyPtr; + Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; Tcl_HashEntry *hPtr; Var *varPtr; - varPtr = ckalloc(sizeof(VarInHash)); + varPtr = (Var *)ckalloc(sizeof(VarInHash)); varPtr->flags = VAR_IN_HASHTABLE; varPtr->value.objPtr = NULL; VarHashRefCount(varPtr) = 1; @@ -6310,7 +6290,7 @@ CompareVarKeys( void *keyPtr, /* New key to compare. */ Tcl_HashEntry *hPtr) /* Existing key to compare. */ { - Tcl_Obj *objPtr1 = keyPtr; + Tcl_Obj *objPtr1 = (Tcl_Obj *)keyPtr; Tcl_Obj *objPtr2 = hPtr->key.objPtr; const char *p1, *p2; int l1, l2; @@ -6318,9 +6298,9 @@ CompareVarKeys( /* * If the object pointers are the same then they match. * OPT: this comparison was moved to the caller - - if (objPtr1 == objPtr2) return 1; - */ + * + * if (objPtr1 == objPtr2) return 1; + */ /* * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being in a -- cgit v0.12 From 521b3bfb0efbff8cb6b5df2fd40630ece70f8e1f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 30 Nov 2022 08:12:16 +0000 Subject: Update to tzdata 2022g --- library/tzdata/America/Bogota | 2 +- library/tzdata/America/Cambridge_Bay | 18 ++- library/tzdata/America/Dawson | 2 + library/tzdata/America/Inuvik | 18 ++- library/tzdata/America/Iqaluit | 18 ++- library/tzdata/America/Nuuk | 155 +-------------------- library/tzdata/America/Ojinaga | 155 +++++++++++++++++++++ library/tzdata/America/Pangnirtung | 253 +---------------------------------- library/tzdata/America/Rankin_Inlet | 18 ++- library/tzdata/America/Resolute | 18 ++- library/tzdata/America/Whitehorse | 2 + library/tzdata/America/Yellowknife | 18 ++- library/tzdata/Asia/Singapore | 2 +- 13 files changed, 261 insertions(+), 418 deletions(-) diff --git a/library/tzdata/America/Bogota b/library/tzdata/America/Bogota index 8ca39ba..ae7b53e 100644 --- a/library/tzdata/America/Bogota +++ b/library/tzdata/America/Bogota @@ -5,5 +5,5 @@ set TZData(:America/Bogota) { {-2707671824 -17776 0 BMT} {-1739041424 -18000 0 -05} {704869200 -14400 1 -05} - {733896000 -18000 0 -05} + {729057600 -18000 0 -05} } diff --git a/library/tzdata/America/Cambridge_Bay b/library/tzdata/America/Cambridge_Bay index 3115ee1..584ed83 100644 --- a/library/tzdata/America/Cambridge_Bay +++ b/library/tzdata/America/Cambridge_Bay @@ -6,8 +6,22 @@ set TZData(:America/Cambridge_Bay) { {-880210800 -21600 1 MWT} {-769395600 -21600 1 MPT} {-765388800 -25200 0 MST} - {-147891600 -18000 1 MDDT} - {-131562000 -25200 0 MST} + {73472400 -21600 1 MDT} + {89193600 -25200 0 MST} + {104922000 -21600 1 MDT} + {120643200 -25200 0 MST} + {136371600 -21600 1 MDT} + {152092800 -25200 0 MST} + {167821200 -21600 1 MDT} + {183542400 -25200 0 MST} + {199270800 -21600 1 MDT} + {215596800 -25200 0 MST} + {230720400 -21600 1 MDT} + {247046400 -25200 0 MST} + {262774800 -21600 1 MDT} + {278496000 -25200 0 MST} + {294224400 -21600 1 MDT} + {309945600 -25200 0 MST} {325674000 -21600 1 MDT} {341395200 -25200 0 MST} {357123600 -21600 1 MDT} diff --git a/library/tzdata/America/Dawson b/library/tzdata/America/Dawson index c8e3f26..62b0654 100644 --- a/library/tzdata/America/Dawson +++ b/library/tzdata/America/Dawson @@ -10,8 +10,10 @@ set TZData(:America/Dawson) { {-880203600 -28800 1 YWT} {-769395600 -28800 1 YPT} {-765381600 -32400 0 YST} + {-157734000 -32400 0 YST} {-147884400 -25200 1 YDDT} {-131554800 -32400 0 YST} + {120646800 -28800 0 PST} {315561600 -28800 0 PST} {325677600 -25200 1 PDT} {341398800 -28800 0 PST} diff --git a/library/tzdata/America/Inuvik b/library/tzdata/America/Inuvik index 08f0fd6..84231f8 100644 --- a/library/tzdata/America/Inuvik +++ b/library/tzdata/America/Inuvik @@ -3,8 +3,22 @@ set TZData(:America/Inuvik) { {-9223372036854775808 0 0 -00} {-536457600 -28800 0 PST} - {-147888000 -21600 1 PDDT} - {-131558400 -28800 0 PST} + {73476000 -25200 1 PDT} + {89197200 -28800 0 PST} + {104925600 -25200 1 PDT} + {120646800 -28800 0 PST} + {136375200 -25200 1 PDT} + {152096400 -28800 0 PST} + {167824800 -25200 1 PDT} + {183546000 -28800 0 PST} + {199274400 -25200 1 PDT} + {215600400 -28800 0 PST} + {230724000 -25200 1 PDT} + {247050000 -28800 0 PST} + {262778400 -25200 1 PDT} + {278499600 -28800 0 PST} + {294228000 -21600 0 MDT} + {309945600 -25200 0 MST} {315558000 -25200 0 MST} {325674000 -21600 1 MDT} {341395200 -25200 0 MST} diff --git a/library/tzdata/America/Iqaluit b/library/tzdata/America/Iqaluit index ff82866..413a548 100644 --- a/library/tzdata/America/Iqaluit +++ b/library/tzdata/America/Iqaluit @@ -5,8 +5,22 @@ set TZData(:America/Iqaluit) { {-865296000 -14400 0 EWT} {-769395600 -14400 1 EPT} {-765396000 -18000 0 EST} - {-147898800 -10800 1 EDDT} - {-131569200 -18000 0 EST} + {73465200 -14400 1 EDT} + {89186400 -18000 0 EST} + {104914800 -14400 1 EDT} + {120636000 -18000 0 EST} + {136364400 -14400 1 EDT} + {152085600 -18000 0 EST} + {167814000 -14400 1 EDT} + {183535200 -18000 0 EST} + {199263600 -14400 1 EDT} + {215589600 -18000 0 EST} + {230713200 -14400 1 EDT} + {247039200 -18000 0 EST} + {262767600 -14400 1 EDT} + {278488800 -18000 0 EST} + {294217200 -14400 1 EDT} + {309938400 -18000 0 EST} {325666800 -14400 1 EDT} {341388000 -18000 0 EST} {357116400 -14400 1 EDT} diff --git a/library/tzdata/America/Nuuk b/library/tzdata/America/Nuuk index 8d85a81..d010cab 100644 --- a/library/tzdata/America/Nuuk +++ b/library/tzdata/America/Nuuk @@ -89,158 +89,5 @@ set TZData(:America/Nuuk) { {1635642000 -10800 0 -03} {1648342800 -7200 1 -02} {1667091600 -10800 0 -03} - {1679792400 -7200 1 -02} - {1698541200 -10800 0 -03} - {1711846800 -7200 1 -02} - {1729990800 -10800 0 -03} - {1743296400 -7200 1 -02} - {1761440400 -10800 0 -03} - {1774746000 -7200 1 -02} - {1792890000 -10800 0 -03} - {1806195600 -7200 1 -02} - {1824944400 -10800 0 -03} - {1837645200 -7200 1 -02} - {1856394000 -10800 0 -03} - {1869094800 -7200 1 -02} - {1887843600 -10800 0 -03} - {1901149200 -7200 1 -02} - {1919293200 -10800 0 -03} - {1932598800 -7200 1 -02} - {1950742800 -10800 0 -03} - {1964048400 -7200 1 -02} - {1982797200 -10800 0 -03} - {1995498000 -7200 1 -02} - {2014246800 -10800 0 -03} - {2026947600 -7200 1 -02} - {2045696400 -10800 0 -03} - {2058397200 -7200 1 -02} - {2077146000 -10800 0 -03} - {2090451600 -7200 1 -02} - {2108595600 -10800 0 -03} - {2121901200 -7200 1 -02} - {2140045200 -10800 0 -03} - {2153350800 -7200 1 -02} - {2172099600 -10800 0 -03} - {2184800400 -7200 1 -02} - {2203549200 -10800 0 -03} - {2216250000 -7200 1 -02} - {2234998800 -10800 0 -03} - {2248304400 -7200 1 -02} - {2266448400 -10800 0 -03} - {2279754000 -7200 1 -02} - {2297898000 -10800 0 -03} - {2311203600 -7200 1 -02} - {2329347600 -10800 0 -03} - {2342653200 -7200 1 -02} - {2361402000 -10800 0 -03} - {2374102800 -7200 1 -02} - {2392851600 -10800 0 -03} - {2405552400 -7200 1 -02} - {2424301200 -10800 0 -03} - {2437606800 -7200 1 -02} - {2455750800 -10800 0 -03} - {2469056400 -7200 1 -02} - {2487200400 -10800 0 -03} - {2500506000 -7200 1 -02} - {2519254800 -10800 0 -03} - {2531955600 -7200 1 -02} - {2550704400 -10800 0 -03} - {2563405200 -7200 1 -02} - {2582154000 -10800 0 -03} - {2595459600 -7200 1 -02} - {2613603600 -10800 0 -03} - {2626909200 -7200 1 -02} - {2645053200 -10800 0 -03} - {2658358800 -7200 1 -02} - {2676502800 -10800 0 -03} - {2689808400 -7200 1 -02} - {2708557200 -10800 0 -03} - {2721258000 -7200 1 -02} - {2740006800 -10800 0 -03} - {2752707600 -7200 1 -02} - {2771456400 -10800 0 -03} - {2784762000 -7200 1 -02} - {2802906000 -10800 0 -03} - {2816211600 -7200 1 -02} - {2834355600 -10800 0 -03} - {2847661200 -7200 1 -02} - {2866410000 -10800 0 -03} - {2879110800 -7200 1 -02} - {2897859600 -10800 0 -03} - {2910560400 -7200 1 -02} - {2929309200 -10800 0 -03} - {2942010000 -7200 1 -02} - {2960758800 -10800 0 -03} - {2974064400 -7200 1 -02} - {2992208400 -10800 0 -03} - {3005514000 -7200 1 -02} - {3023658000 -10800 0 -03} - {3036963600 -7200 1 -02} - {3055712400 -10800 0 -03} - {3068413200 -7200 1 -02} - {3087162000 -10800 0 -03} - {3099862800 -7200 1 -02} - {3118611600 -10800 0 -03} - {3131917200 -7200 1 -02} - {3150061200 -10800 0 -03} - {3163366800 -7200 1 -02} - {3181510800 -10800 0 -03} - {3194816400 -7200 1 -02} - {3212960400 -10800 0 -03} - {3226266000 -7200 1 -02} - {3245014800 -10800 0 -03} - {3257715600 -7200 1 -02} - {3276464400 -10800 0 -03} - {3289165200 -7200 1 -02} - {3307914000 -10800 0 -03} - {3321219600 -7200 1 -02} - {3339363600 -10800 0 -03} - {3352669200 -7200 1 -02} - {3370813200 -10800 0 -03} - {3384118800 -7200 1 -02} - {3402867600 -10800 0 -03} - {3415568400 -7200 1 -02} - {3434317200 -10800 0 -03} - {3447018000 -7200 1 -02} - {3465766800 -10800 0 -03} - {3479072400 -7200 1 -02} - {3497216400 -10800 0 -03} - {3510522000 -7200 1 -02} - {3528666000 -10800 0 -03} - {3541971600 -7200 1 -02} - {3560115600 -10800 0 -03} - {3573421200 -7200 1 -02} - {3592170000 -10800 0 -03} - {3604870800 -7200 1 -02} - {3623619600 -10800 0 -03} - {3636320400 -7200 1 -02} - {3655069200 -10800 0 -03} - {3668374800 -7200 1 -02} - {3686518800 -10800 0 -03} - {3699824400 -7200 1 -02} - {3717968400 -10800 0 -03} - {3731274000 -7200 1 -02} - {3750022800 -10800 0 -03} - {3762723600 -7200 1 -02} - {3781472400 -10800 0 -03} - {3794173200 -7200 1 -02} - {3812922000 -10800 0 -03} - {3825622800 -7200 1 -02} - {3844371600 -10800 0 -03} - {3857677200 -7200 1 -02} - {3875821200 -10800 0 -03} - {3889126800 -7200 1 -02} - {3907270800 -10800 0 -03} - {3920576400 -7200 1 -02} - {3939325200 -10800 0 -03} - {3952026000 -7200 1 -02} - {3970774800 -10800 0 -03} - {3983475600 -7200 1 -02} - {4002224400 -10800 0 -03} - {4015530000 -7200 1 -02} - {4033674000 -10800 0 -03} - {4046979600 -7200 1 -02} - {4065123600 -10800 0 -03} - {4078429200 -7200 1 -02} - {4096573200 -10800 0 -03} + {1679792400 -7200 0 -02} } diff --git a/library/tzdata/America/Ojinaga b/library/tzdata/America/Ojinaga index 7102f73..e189f72 100644 --- a/library/tzdata/America/Ojinaga +++ b/library/tzdata/America/Ojinaga @@ -65,4 +65,159 @@ set TZData(:America/Ojinaga) { {1636272000 -25200 0 MST} {1647162000 -21600 1 MDT} {1667120400 -21600 0 CST} + {1669788000 -21600 0 CST} + {1678608000 -18000 1 CDT} + {1699167600 -21600 0 CST} + {1710057600 -18000 1 CDT} + {1730617200 -21600 0 CST} + {1741507200 -18000 1 CDT} + {1762066800 -21600 0 CST} + {1772956800 -18000 1 CDT} + {1793516400 -21600 0 CST} + {1805011200 -18000 1 CDT} + {1825570800 -21600 0 CST} + {1836460800 -18000 1 CDT} + {1857020400 -21600 0 CST} + {1867910400 -18000 1 CDT} + {1888470000 -21600 0 CST} + {1899360000 -18000 1 CDT} + {1919919600 -21600 0 CST} + {1930809600 -18000 1 CDT} + {1951369200 -21600 0 CST} + {1962864000 -18000 1 CDT} + {1983423600 -21600 0 CST} + {1994313600 -18000 1 CDT} + {2014873200 -21600 0 CST} + {2025763200 -18000 1 CDT} + {2046322800 -21600 0 CST} + {2057212800 -18000 1 CDT} + {2077772400 -21600 0 CST} + {2088662400 -18000 1 CDT} + {2109222000 -21600 0 CST} + {2120112000 -18000 1 CDT} + {2140671600 -21600 0 CST} + {2152166400 -18000 1 CDT} + {2172726000 -21600 0 CST} + {2183616000 -18000 1 CDT} + {2204175600 -21600 0 CST} + {2215065600 -18000 1 CDT} + {2235625200 -21600 0 CST} + {2246515200 -18000 1 CDT} + {2267074800 -21600 0 CST} + {2277964800 -18000 1 CDT} + {2298524400 -21600 0 CST} + {2309414400 -18000 1 CDT} + {2329974000 -21600 0 CST} + {2341468800 -18000 1 CDT} + {2362028400 -21600 0 CST} + {2372918400 -18000 1 CDT} + {2393478000 -21600 0 CST} + {2404368000 -18000 1 CDT} + {2424927600 -21600 0 CST} + {2435817600 -18000 1 CDT} + {2456377200 -21600 0 CST} + {2467267200 -18000 1 CDT} + {2487826800 -21600 0 CST} + {2499321600 -18000 1 CDT} + {2519881200 -21600 0 CST} + {2530771200 -18000 1 CDT} + {2551330800 -21600 0 CST} + {2562220800 -18000 1 CDT} + {2582780400 -21600 0 CST} + {2593670400 -18000 1 CDT} + {2614230000 -21600 0 CST} + {2625120000 -18000 1 CDT} + {2645679600 -21600 0 CST} + {2656569600 -18000 1 CDT} + {2677129200 -21600 0 CST} + {2688624000 -18000 1 CDT} + {2709183600 -21600 0 CST} + {2720073600 -18000 1 CDT} + {2740633200 -21600 0 CST} + {2751523200 -18000 1 CDT} + {2772082800 -21600 0 CST} + {2782972800 -18000 1 CDT} + {2803532400 -21600 0 CST} + {2814422400 -18000 1 CDT} + {2834982000 -21600 0 CST} + {2846476800 -18000 1 CDT} + {2867036400 -21600 0 CST} + {2877926400 -18000 1 CDT} + {2898486000 -21600 0 CST} + {2909376000 -18000 1 CDT} + {2929935600 -21600 0 CST} + {2940825600 -18000 1 CDT} + {2961385200 -21600 0 CST} + {2972275200 -18000 1 CDT} + {2992834800 -21600 0 CST} + {3003724800 -18000 1 CDT} + {3024284400 -21600 0 CST} + {3035779200 -18000 1 CDT} + {3056338800 -21600 0 CST} + {3067228800 -18000 1 CDT} + {3087788400 -21600 0 CST} + {3098678400 -18000 1 CDT} + {3119238000 -21600 0 CST} + {3130128000 -18000 1 CDT} + {3150687600 -21600 0 CST} + {3161577600 -18000 1 CDT} + {3182137200 -21600 0 CST} + {3193027200 -18000 1 CDT} + {3213586800 -21600 0 CST} + {3225081600 -18000 1 CDT} + {3245641200 -21600 0 CST} + {3256531200 -18000 1 CDT} + {3277090800 -21600 0 CST} + {3287980800 -18000 1 CDT} + {3308540400 -21600 0 CST} + {3319430400 -18000 1 CDT} + {3339990000 -21600 0 CST} + {3350880000 -18000 1 CDT} + {3371439600 -21600 0 CST} + {3382934400 -18000 1 CDT} + {3403494000 -21600 0 CST} + {3414384000 -18000 1 CDT} + {3434943600 -21600 0 CST} + {3445833600 -18000 1 CDT} + {3466393200 -21600 0 CST} + {3477283200 -18000 1 CDT} + {3497842800 -21600 0 CST} + {3508732800 -18000 1 CDT} + {3529292400 -21600 0 CST} + {3540182400 -18000 1 CDT} + {3560742000 -21600 0 CST} + {3572236800 -18000 1 CDT} + {3592796400 -21600 0 CST} + {3603686400 -18000 1 CDT} + {3624246000 -21600 0 CST} + {3635136000 -18000 1 CDT} + {3655695600 -21600 0 CST} + {3666585600 -18000 1 CDT} + {3687145200 -21600 0 CST} + {3698035200 -18000 1 CDT} + {3718594800 -21600 0 CST} + {3730089600 -18000 1 CDT} + {3750649200 -21600 0 CST} + {3761539200 -18000 1 CDT} + {3782098800 -21600 0 CST} + {3792988800 -18000 1 CDT} + {3813548400 -21600 0 CST} + {3824438400 -18000 1 CDT} + {3844998000 -21600 0 CST} + {3855888000 -18000 1 CDT} + {3876447600 -21600 0 CST} + {3887337600 -18000 1 CDT} + {3907897200 -21600 0 CST} + {3919392000 -18000 1 CDT} + {3939951600 -21600 0 CST} + {3950841600 -18000 1 CDT} + {3971401200 -21600 0 CST} + {3982291200 -18000 1 CDT} + {4002850800 -21600 0 CST} + {4013740800 -18000 1 CDT} + {4034300400 -21600 0 CST} + {4045190400 -18000 1 CDT} + {4065750000 -21600 0 CST} + {4076640000 -18000 1 CDT} + {4097199600 -21600 0 CST} } diff --git a/library/tzdata/America/Pangnirtung b/library/tzdata/America/Pangnirtung index 14d8516..b7db25d 100644 --- a/library/tzdata/America/Pangnirtung +++ b/library/tzdata/America/Pangnirtung @@ -1,252 +1,5 @@ # created by tools/tclZIC.tcl - do not edit - -set TZData(:America/Pangnirtung) { - {-9223372036854775808 0 0 -00} - {-1546300800 -14400 0 AST} - {-880221600 -10800 1 AWT} - {-769395600 -10800 1 APT} - {-765399600 -14400 0 AST} - {-147902400 -7200 1 ADDT} - {-131572800 -14400 0 AST} - {325663200 -10800 1 ADT} - {341384400 -14400 0 AST} - {357112800 -10800 1 ADT} - {372834000 -14400 0 AST} - {388562400 -10800 1 ADT} - {404888400 -14400 0 AST} - {420012000 -10800 1 ADT} - {436338000 -14400 0 AST} - {452066400 -10800 1 ADT} - {467787600 -14400 0 AST} - {483516000 -10800 1 ADT} - {499237200 -14400 0 AST} - {514965600 -10800 1 ADT} - {530686800 -14400 0 AST} - {544600800 -10800 1 ADT} - {562136400 -14400 0 AST} - {576050400 -10800 1 ADT} - {594190800 -14400 0 AST} - {607500000 -10800 1 ADT} - {625640400 -14400 0 AST} - {638949600 -10800 1 ADT} - {657090000 -14400 0 AST} - {671004000 -10800 1 ADT} - {688539600 -14400 0 AST} - {702453600 -10800 1 ADT} - {719989200 -14400 0 AST} - {733903200 -10800 1 ADT} - {752043600 -14400 0 AST} - {765352800 -10800 1 ADT} - {783493200 -14400 0 AST} - {796802400 -18000 0 EST} - {796806000 -14400 1 EDT} - {814946400 -18000 0 EST} - {828860400 -14400 1 EDT} - {846396000 -18000 0 EST} - {860310000 -14400 1 EDT} - {877845600 -18000 0 EST} - {891759600 -14400 1 EDT} - {909295200 -18000 0 EST} - {923209200 -14400 1 EDT} - {941353200 -21600 0 CST} - {954662400 -18000 1 CDT} - {972806400 -18000 0 EST} - {986108400 -14400 1 EDT} - {1004248800 -18000 0 EST} - {1018162800 -14400 1 EDT} - {1035698400 -18000 0 EST} - {1049612400 -14400 1 EDT} - {1067148000 -18000 0 EST} - {1081062000 -14400 1 EDT} - {1099202400 -18000 0 EST} - {1112511600 -14400 1 EDT} - {1130652000 -18000 0 EST} - {1143961200 -14400 1 EDT} - {1162101600 -18000 0 EST} - {1173596400 -14400 1 EDT} - {1194156000 -18000 0 EST} - {1205046000 -14400 1 EDT} - {1225605600 -18000 0 EST} - {1236495600 -14400 1 EDT} - {1257055200 -18000 0 EST} - {1268550000 -14400 1 EDT} - {1289109600 -18000 0 EST} - {1299999600 -14400 1 EDT} - {1320559200 -18000 0 EST} - {1331449200 -14400 1 EDT} - {1352008800 -18000 0 EST} - {1362898800 -14400 1 EDT} - {1383458400 -18000 0 EST} - {1394348400 -14400 1 EDT} - {1414908000 -18000 0 EST} - {1425798000 -14400 1 EDT} - {1446357600 -18000 0 EST} - {1457852400 -14400 1 EDT} - {1478412000 -18000 0 EST} - {1489302000 -14400 1 EDT} - {1509861600 -18000 0 EST} - {1520751600 -14400 1 EDT} - {1541311200 -18000 0 EST} - {1552201200 -14400 1 EDT} - {1572760800 -18000 0 EST} - {1583650800 -14400 1 EDT} - {1604210400 -18000 0 EST} - {1615705200 -14400 1 EDT} - {1636264800 -18000 0 EST} - {1647154800 -14400 1 EDT} - {1667714400 -18000 0 EST} - {1678604400 -14400 1 EDT} - {1699164000 -18000 0 EST} - {1710054000 -14400 1 EDT} - {1730613600 -18000 0 EST} - {1741503600 -14400 1 EDT} - {1762063200 -18000 0 EST} - {1772953200 -14400 1 EDT} - {1793512800 -18000 0 EST} - {1805007600 -14400 1 EDT} - {1825567200 -18000 0 EST} - {1836457200 -14400 1 EDT} - {1857016800 -18000 0 EST} - {1867906800 -14400 1 EDT} - {1888466400 -18000 0 EST} - {1899356400 -14400 1 EDT} - {1919916000 -18000 0 EST} - {1930806000 -14400 1 EDT} - {1951365600 -18000 0 EST} - {1962860400 -14400 1 EDT} - {1983420000 -18000 0 EST} - {1994310000 -14400 1 EDT} - {2014869600 -18000 0 EST} - {2025759600 -14400 1 EDT} - {2046319200 -18000 0 EST} - {2057209200 -14400 1 EDT} - {2077768800 -18000 0 EST} - {2088658800 -14400 1 EDT} - {2109218400 -18000 0 EST} - {2120108400 -14400 1 EDT} - {2140668000 -18000 0 EST} - {2152162800 -14400 1 EDT} - {2172722400 -18000 0 EST} - {2183612400 -14400 1 EDT} - {2204172000 -18000 0 EST} - {2215062000 -14400 1 EDT} - {2235621600 -18000 0 EST} - {2246511600 -14400 1 EDT} - {2267071200 -18000 0 EST} - {2277961200 -14400 1 EDT} - {2298520800 -18000 0 EST} - {2309410800 -14400 1 EDT} - {2329970400 -18000 0 EST} - {2341465200 -14400 1 EDT} - {2362024800 -18000 0 EST} - {2372914800 -14400 1 EDT} - {2393474400 -18000 0 EST} - {2404364400 -14400 1 EDT} - {2424924000 -18000 0 EST} - {2435814000 -14400 1 EDT} - {2456373600 -18000 0 EST} - {2467263600 -14400 1 EDT} - {2487823200 -18000 0 EST} - {2499318000 -14400 1 EDT} - {2519877600 -18000 0 EST} - {2530767600 -14400 1 EDT} - {2551327200 -18000 0 EST} - {2562217200 -14400 1 EDT} - {2582776800 -18000 0 EST} - {2593666800 -14400 1 EDT} - {2614226400 -18000 0 EST} - {2625116400 -14400 1 EDT} - {2645676000 -18000 0 EST} - {2656566000 -14400 1 EDT} - {2677125600 -18000 0 EST} - {2688620400 -14400 1 EDT} - {2709180000 -18000 0 EST} - {2720070000 -14400 1 EDT} - {2740629600 -18000 0 EST} - {2751519600 -14400 1 EDT} - {2772079200 -18000 0 EST} - {2782969200 -14400 1 EDT} - {2803528800 -18000 0 EST} - {2814418800 -14400 1 EDT} - {2834978400 -18000 0 EST} - {2846473200 -14400 1 EDT} - {2867032800 -18000 0 EST} - {2877922800 -14400 1 EDT} - {2898482400 -18000 0 EST} - {2909372400 -14400 1 EDT} - {2929932000 -18000 0 EST} - {2940822000 -14400 1 EDT} - {2961381600 -18000 0 EST} - {2972271600 -14400 1 EDT} - {2992831200 -18000 0 EST} - {3003721200 -14400 1 EDT} - {3024280800 -18000 0 EST} - {3035775600 -14400 1 EDT} - {3056335200 -18000 0 EST} - {3067225200 -14400 1 EDT} - {3087784800 -18000 0 EST} - {3098674800 -14400 1 EDT} - {3119234400 -18000 0 EST} - {3130124400 -14400 1 EDT} - {3150684000 -18000 0 EST} - {3161574000 -14400 1 EDT} - {3182133600 -18000 0 EST} - {3193023600 -14400 1 EDT} - {3213583200 -18000 0 EST} - {3225078000 -14400 1 EDT} - {3245637600 -18000 0 EST} - {3256527600 -14400 1 EDT} - {3277087200 -18000 0 EST} - {3287977200 -14400 1 EDT} - {3308536800 -18000 0 EST} - {3319426800 -14400 1 EDT} - {3339986400 -18000 0 EST} - {3350876400 -14400 1 EDT} - {3371436000 -18000 0 EST} - {3382930800 -14400 1 EDT} - {3403490400 -18000 0 EST} - {3414380400 -14400 1 EDT} - {3434940000 -18000 0 EST} - {3445830000 -14400 1 EDT} - {3466389600 -18000 0 EST} - {3477279600 -14400 1 EDT} - {3497839200 -18000 0 EST} - {3508729200 -14400 1 EDT} - {3529288800 -18000 0 EST} - {3540178800 -14400 1 EDT} - {3560738400 -18000 0 EST} - {3572233200 -14400 1 EDT} - {3592792800 -18000 0 EST} - {3603682800 -14400 1 EDT} - {3624242400 -18000 0 EST} - {3635132400 -14400 1 EDT} - {3655692000 -18000 0 EST} - {3666582000 -14400 1 EDT} - {3687141600 -18000 0 EST} - {3698031600 -14400 1 EDT} - {3718591200 -18000 0 EST} - {3730086000 -14400 1 EDT} - {3750645600 -18000 0 EST} - {3761535600 -14400 1 EDT} - {3782095200 -18000 0 EST} - {3792985200 -14400 1 EDT} - {3813544800 -18000 0 EST} - {3824434800 -14400 1 EDT} - {3844994400 -18000 0 EST} - {3855884400 -14400 1 EDT} - {3876444000 -18000 0 EST} - {3887334000 -14400 1 EDT} - {3907893600 -18000 0 EST} - {3919388400 -14400 1 EDT} - {3939948000 -18000 0 EST} - {3950838000 -14400 1 EDT} - {3971397600 -18000 0 EST} - {3982287600 -14400 1 EDT} - {4002847200 -18000 0 EST} - {4013737200 -14400 1 EDT} - {4034296800 -18000 0 EST} - {4045186800 -14400 1 EDT} - {4065746400 -18000 0 EST} - {4076636400 -14400 1 EDT} - {4097196000 -18000 0 EST} +if {![info exists TZData(America/Iqaluit)]} { + LoadTimeZoneFile America/Iqaluit } +set TZData(:America/Pangnirtung) $TZData(:America/Iqaluit) diff --git a/library/tzdata/America/Rankin_Inlet b/library/tzdata/America/Rankin_Inlet index 9ce9f8d..0f6db70 100644 --- a/library/tzdata/America/Rankin_Inlet +++ b/library/tzdata/America/Rankin_Inlet @@ -3,8 +3,22 @@ set TZData(:America/Rankin_Inlet) { {-9223372036854775808 0 0 -00} {-410227200 -21600 0 CST} - {-147895200 -14400 1 CDDT} - {-131565600 -21600 0 CST} + {73468800 -18000 1 CDT} + {89190000 -21600 0 CST} + {104918400 -18000 1 CDT} + {120639600 -21600 0 CST} + {136368000 -18000 1 CDT} + {152089200 -21600 0 CST} + {167817600 -18000 1 CDT} + {183538800 -21600 0 CST} + {199267200 -18000 1 CDT} + {215593200 -21600 0 CST} + {230716800 -18000 1 CDT} + {247042800 -21600 0 CST} + {262771200 -18000 1 CDT} + {278492400 -21600 0 CST} + {294220800 -18000 1 CDT} + {309942000 -21600 0 CST} {325670400 -18000 1 CDT} {341391600 -21600 0 CST} {357120000 -18000 1 CDT} diff --git a/library/tzdata/America/Resolute b/library/tzdata/America/Resolute index a9881b4..27e7300 100644 --- a/library/tzdata/America/Resolute +++ b/library/tzdata/America/Resolute @@ -3,8 +3,22 @@ set TZData(:America/Resolute) { {-9223372036854775808 0 0 -00} {-704937600 -21600 0 CST} - {-147895200 -14400 1 CDDT} - {-131565600 -21600 0 CST} + {73468800 -18000 1 CDT} + {89190000 -21600 0 CST} + {104918400 -18000 1 CDT} + {120639600 -21600 0 CST} + {136368000 -18000 1 CDT} + {152089200 -21600 0 CST} + {167817600 -18000 1 CDT} + {183538800 -21600 0 CST} + {199267200 -18000 1 CDT} + {215593200 -21600 0 CST} + {230716800 -18000 1 CDT} + {247042800 -21600 0 CST} + {262771200 -18000 1 CDT} + {278492400 -21600 0 CST} + {294220800 -18000 1 CDT} + {309942000 -21600 0 CST} {325670400 -18000 1 CDT} {341391600 -21600 0 CST} {357120000 -18000 1 CDT} diff --git a/library/tzdata/America/Whitehorse b/library/tzdata/America/Whitehorse index 498a203..602ecd1 100644 --- a/library/tzdata/America/Whitehorse +++ b/library/tzdata/America/Whitehorse @@ -10,8 +10,10 @@ set TZData(:America/Whitehorse) { {-880203600 -28800 1 YWT} {-769395600 -28800 1 YPT} {-765381600 -32400 0 YST} + {-157734000 -32400 0 YST} {-147884400 -25200 1 YDDT} {-131554800 -32400 0 YST} + {-121273200 -28800 0 PST} {315561600 -28800 0 PST} {325677600 -25200 1 PDT} {341398800 -28800 0 PST} diff --git a/library/tzdata/America/Yellowknife b/library/tzdata/America/Yellowknife index c6c4ed5..65ddbb6 100644 --- a/library/tzdata/America/Yellowknife +++ b/library/tzdata/America/Yellowknife @@ -6,8 +6,22 @@ set TZData(:America/Yellowknife) { {-880210800 -21600 1 MWT} {-769395600 -21600 1 MPT} {-765388800 -25200 0 MST} - {-147891600 -18000 1 MDDT} - {-131562000 -25200 0 MST} + {73472400 -21600 1 MDT} + {89193600 -25200 0 MST} + {104922000 -21600 1 MDT} + {120643200 -25200 0 MST} + {136371600 -21600 1 MDT} + {152092800 -25200 0 MST} + {167821200 -21600 1 MDT} + {183542400 -25200 0 MST} + {199270800 -21600 1 MDT} + {215596800 -25200 0 MST} + {230720400 -21600 1 MDT} + {247046400 -25200 0 MST} + {262774800 -21600 1 MDT} + {278496000 -25200 0 MST} + {294224400 -21600 1 MDT} + {309945600 -25200 0 MST} {315558000 -25200 0 MST} {325674000 -21600 1 MDT} {341395200 -25200 0 MST} diff --git a/library/tzdata/Asia/Singapore b/library/tzdata/Asia/Singapore index f10eb1f..0fcd130 100644 --- a/library/tzdata/Asia/Singapore +++ b/library/tzdata/Asia/Singapore @@ -9,5 +9,5 @@ set TZData(:Asia/Singapore) { {-894180000 27000 0 +0730} {-879665400 32400 0 +09} {-767005200 27000 0 +0730} - {378664200 28800 0 +08} + {378662400 28800 0 +08} } -- cgit v0.12 From 6c7ad3b1183f1a912bac6ba4fcdf0231749c359e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 30 Nov 2022 21:16:15 +0000 Subject: Let Tcl_GetEncodingNulLength() return size_t on 9.0, for consisancy with other API's. No change on 8.7 --- doc/Encoding.3 | 6 +++--- generic/tcl.decls | 2 +- generic/tcl.h | 4 ++-- generic/tclDecls.h | 4 ++-- generic/tclEncoding.c | 8 ++++---- 5 files changed, 12 insertions(+), 12 deletions(-) diff --git a/doc/Encoding.3 b/doc/Encoding.3 index 43bb2b8..9b88c11 100644 --- a/doc/Encoding.3 +++ b/doc/Encoding.3 @@ -347,7 +347,7 @@ typedef struct Tcl_EncodingType { Tcl_EncodingConvertProc *\fItoUtfProc\fR; Tcl_EncodingConvertProc *\fIfromUtfProc\fR; Tcl_EncodingFreeProc *\fIfreeProc\fR; - ClientData \fIclientData\fR; + void *\fIclientData\fR; int \fInullSize\fR; } \fBTcl_EncodingType\fR; .CE @@ -378,7 +378,7 @@ type \fBTcl_EncodingConvertProc\fR: .PP .CS typedef int \fBTcl_EncodingConvertProc\fR( - ClientData \fIclientData\fR, + void *\fIclientData\fR, const char *\fIsrc\fR, int \fIsrcLen\fR, int \fIflags\fR, @@ -410,7 +410,7 @@ The callback procedure \fIfreeProc\fR, if non-NULL, should match the type .PP .CS typedef void \fBTcl_EncodingFreeProc\fR( - ClientData \fIclientData\fR); + void *\fIclientData\fR); .CE .PP This \fIfreeProc\fR function is called when the encoding is deleted. The diff --git a/generic/tcl.decls b/generic/tcl.decls index a9c042c..a48ab02 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2549,7 +2549,7 @@ declare 682 { # TIP 643 declare 683 { - int Tcl_GetEncodingNulLength(Tcl_Encoding encoding) + Tcl_Size Tcl_GetEncodingNulLength(Tcl_Encoding encoding) } # TIP #650 diff --git a/generic/tcl.h b/generic/tcl.h index ebe989c..c6afaa1 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2078,11 +2078,11 @@ typedef struct Tcl_EncodingType { * encoding is deleted. */ void *clientData; /* Arbitrary value associated with encoding * type. Passed to conversion functions. */ - int nullSize; /* Number of zero bytes that signify + Tcl_Size nullSize; /* Number of zero bytes that signify * end-of-string in this encoding. This number * is used to determine the source string * length when the srcLen argument is - * negative. Must be 1 or 2. */ + * negative. Must be 1, 2, or 4. */ } Tcl_EncodingType; /* diff --git a/generic/tclDecls.h b/generic/tclDecls.h index d8b4b5d..77517e8 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -2039,7 +2039,7 @@ EXTERN int Tcl_GetNumber(Tcl_Interp *interp, const char *bytes, EXTERN int Tcl_RemoveChannelMode(Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 683 */ -EXTERN int Tcl_GetEncodingNulLength(Tcl_Encoding encoding); +EXTERN Tcl_Size Tcl_GetEncodingNulLength(Tcl_Encoding encoding); /* 684 */ EXTERN int Tcl_GetWideUIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); @@ -2766,7 +2766,7 @@ typedef struct TclStubs { int (*tcl_GetNumberFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void **clientDataPtr, int *typePtr); /* 680 */ int (*tcl_GetNumber) (Tcl_Interp *interp, const char *bytes, size_t numBytes, void **clientDataPtr, int *typePtr); /* 681 */ int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 682 */ - int (*tcl_GetEncodingNulLength) (Tcl_Encoding encoding); /* 683 */ + Tcl_Size (*tcl_GetEncodingNulLength) (Tcl_Encoding encoding); /* 683 */ int (*tcl_GetWideUIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); /* 684 */ Tcl_Obj * (*tcl_DStringToObj) (Tcl_DString *dsPtr); /* 685 */ void (*reserved686)(void); diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 5be6a2e..169e975 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -33,13 +33,13 @@ typedef struct { Tcl_EncodingFreeProc *freeProc; /* If non-NULL, function to call when this * encoding is deleted. */ + void *clientData; /* Arbitrary value associated with encoding + * type. Passed to conversion functions. */ int nullSize; /* Number of 0x00 bytes that signify * end-of-string in this encoding. This number * is used to determine the source string * length when the srcLen argument is * negative. This number can be 1, 2, or 4. */ - void *clientData; /* Arbitrary value associated with encoding - * type. Passed to conversion functions. */ LengthProc *lengthProc; /* Function to compute length of * null-terminated strings in this encoding. * If nullSize is 1, this is strlen; if @@ -888,7 +888,7 @@ FreeEncoding( * * Tcl_GetEncodingName -- * - * Given an encoding, return the name that was used to constuct the + * Given an encoding, return the name that was used to construct the * encoding. * * Results: @@ -991,7 +991,7 @@ Tcl_GetEncodingNames( * string termination. * * Results: - * The name of the encoding. + * The number of nul bytes used for the string termination. * * Side effects: * None. -- cgit v0.12 From 36c94773b45337052801cf689d1c2a3ab1ea790b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 1 Dec 2022 10:18:35 +0000 Subject: Handle "deprecated" condition correctly in test-cases --- tests/chan.test | 3 ++- tests/chanio.test | 4 ++-- tests/io.test | 8 ++++---- 3 files changed, 8 insertions(+), 7 deletions(-) diff --git a/tests/chan.test b/tests/chan.test index cb44f06..87d642c 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -11,6 +11,7 @@ if {"::tcltest" ni [namespace children]} { package require tcltest 2.5 namespace import -force ::tcltest::* } +source [file join [file dirname [info script]] tcltests.tcl] package require tcltests @@ -55,7 +56,7 @@ test chan-4.2 {chan command: [Bug 800753]} -body { test chan-4.3 {chan command: [Bug 800753]} -body { chan configure stdout -eofchar \x00 } -returnCodes error -result {bad value for -eofchar: must be non-NUL ASCII character} -test chan-4.4 {chan command: check valid inValue, no outValue} -body { +test chan-4.4 {chan command: check valid inValue, no outValue} -constraints deprecated -body { chan configure stdout -eofchar [list \x27 {}] } -result {} test chan-4.5 {chan command: check valid inValue, invalid outValue} -body { diff --git a/tests/chanio.test b/tests/chanio.test index 6cd3955..4ad59f1 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -5285,7 +5285,7 @@ test chan-io-39.21 {Tcl_SetChannelOption, setting read mode independently} \ test chan-io-39.22 {Tcl_SetChannelOption, invariance} -setup { file delete $path(test1) set l "" -} -constraints unix -body { +} -constraints {unix deprecated} -body { set f1 [open $path(test1) w+] lappend l [chan configure $f1 -eofchar] chan configure $f1 -eofchar {O {}} @@ -5295,7 +5295,7 @@ test chan-io-39.22 {Tcl_SetChannelOption, invariance} -setup { } -cleanup { chan close $f1 } -result {{} O D} -test chan-io-39.22a {Tcl_SetChannelOption, invariance} -setup { +test chan-io-39.22a {Tcl_SetChannelOption, invariance} -constraints deprecated -setup { file delete $path(test1) set l [list] } -body { diff --git a/tests/io.test b/tests/io.test index 52ec200..cbf20c1 100644 --- a/tests/io.test +++ b/tests/io.test @@ -5756,7 +5756,7 @@ test io-39.21 {Tcl_SetChannelOption, setting read mode independently} \ close $s2 set modes } {auto crlf} -test io-39.22 {Tcl_SetChannelOption, invariance} unix { +test io-39.22 {Tcl_SetChannelOption, invariance} -constraints {unix deprecated} -body { file delete $path(test1) set f1 [open $path(test1) w+] set l "" @@ -5767,8 +5767,8 @@ test io-39.22 {Tcl_SetChannelOption, invariance} unix { lappend l [fconfigure $f1 -eofchar] close $f1 set l -} {{} O D} -test io-39.22a {Tcl_SetChannelOption, invariance} { +} -result {{} O D} +test io-39.22a {Tcl_SetChannelOption, invariance} -constraints deprecated -body { file delete $path(test1) set f1 [open $path(test1) w+] set l [list] @@ -5779,7 +5779,7 @@ test io-39.22a {Tcl_SetChannelOption, invariance} { lappend l [list [catch {fconfigure $f1 -eofchar {1 2 3}} msg] $msg] close $f1 set l -} {O D {1 {bad value for -eofchar: must be non-NUL ASCII character}}} +} -result {O D {1 {bad value for -eofchar: must be non-NUL ASCII character}}} test io-39.23 {Tcl_GetChannelOption, server socket is not readable or writeable, it should still have valid -eofchar and -translation options } { set l [list] -- cgit v0.12 From b3838ea4450c4d290daa647c9a7f62d4e55ee7c0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 1 Dec 2022 17:27:03 +0000 Subject: Backport TIP #402: General Platform UNC Support from 8.7, but only for Cygwin and QNX. This was already partially present, but was never completed. --- generic/tclFileName.c | 32 +++++++------------------------- unix/tclUnixFile.c | 5 ++--- 2 files changed, 9 insertions(+), 28 deletions(-) diff --git a/generic/tclFileName.c b/generic/tclFileName.c index b6a6439..dcd3d0e 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -5,7 +5,7 @@ * and network form. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -422,22 +422,11 @@ TclpGetNativePathType( while (*path && *path != '/') { ++path; } -#if defined(__CYGWIN__) - /* UNC paths need to be followed by a share name */ - if (*path++ && (*path && *path != '/')) { - ++path; - while (*path && *path != '/') { - ++path; - } - } else { - path = origPath + 1; - } -#endif } #endif if (driveNameLengthPtr != NULL) { /* - * We need this addition in case the QNX or Cygwin code was used. + * We need this addition in case the "//" code was used. */ *driveNameLengthPtr = (path - origPath); @@ -664,17 +653,6 @@ SplitUnixPath( while (*path && *path != '/') { ++path; } -#if defined(__CYGWIN__) - /* UNC paths need to be followed by a share name */ - if (*path++ && (*path && *path != '/')) { - ++path; - while (*path && *path != '/') { - ++path; - } - } else { - path = origPath + 1; - } -#endif } #endif rootElt = Tcl_NewStringObj(origPath, path - origPath); @@ -1889,7 +1867,11 @@ TclGlob( separators = "/\\"; } else if (tclPlatform == TCL_PLATFORM_UNIX) { - if (pathPrefix == NULL && tail[0] == '/') { + if (pathPrefix == NULL && tail[0] == '/' +#if defined(__CYGWIN__) || defined(__QNX__) + && tail[1] != '/' +#endif + ) { pathPrefix = Tcl_NewStringObj(tail, 1); tail++; Tcl_IncrRefCount(pathPrefix); diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index a75ae22..c269079 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -39,7 +39,6 @@ TclpFindExecutable( const char *argv0) /* The value of the application's argv[0] * (native). */ { - Tcl_Encoding encoding; #ifdef __CYGWIN__ int length; wchar_t buf[PATH_MAX] = L""; @@ -52,10 +51,10 @@ TclpFindExecutable( /* Strip '.exe' part. */ length -= 4; } - encoding = Tcl_GetEncoding(NULL, NULL); TclSetObjNameOfExecutable( - Tcl_NewStringObj(name, length), encoding); + Tcl_NewStringObj(name, length), NULL); #else + Tcl_Encoding encoding; const char *name, *p; Tcl_StatBuf statBuf; Tcl_DString buffer, nameString, cwd, utfName; -- cgit v0.12 From ae115792863b91165a1da7d6d51509061cb574b9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 2 Dec 2022 08:19:36 +0000 Subject: Make options -nocomplain and -strictencoding truly independant. Leftover from initial implementation. Noted by Rolf Ade (thanks!) --- generic/tclIO.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 64b309d..0686571 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8252,7 +8252,6 @@ Tcl_SetChannelOption( } if (newMode) { ResetFlag(statePtr, CHANNEL_ENCODING_STRICT); - SetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); } else { ResetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); } @@ -8265,7 +8264,6 @@ Tcl_SetChannelOption( } if (newMode) { ResetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); - SetFlag(statePtr, CHANNEL_ENCODING_STRICT); } else { ResetFlag(statePtr, CHANNEL_ENCODING_STRICT); } -- cgit v0.12 From 25b3cffdd2b616b796b57e6f6766456cfb6ce8e7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 2 Dec 2022 08:35:05 +0000 Subject: Oops, that's the wrong one ... --- generic/tclIO.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 0686571..93d1d46 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8251,7 +8251,7 @@ Tcl_SetChannelOption( return TCL_ERROR; } if (newMode) { - ResetFlag(statePtr, CHANNEL_ENCODING_STRICT); + SetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); } else { ResetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); } @@ -8263,7 +8263,7 @@ Tcl_SetChannelOption( return TCL_ERROR; } if (newMode) { - ResetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); + SetFlag(statePtr, CHANNEL_ENCODING_STRICT); } else { ResetFlag(statePtr, CHANNEL_ENCODING_STRICT); } -- cgit v0.12 From 635dd1a69689dbc6054b475fd4d15c92aa59dfd4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 2 Dec 2022 11:27:10 +0000 Subject: Fix utf32 lables in testcases (some not necessary any more, one missing), indicating differences between Tcl 8.x and 9.0 --- tests/encoding.test | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/tests/encoding.test b/tests/encoding.test index a87cd24..89209d0 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -43,7 +43,7 @@ testConstraint testgetencpath [llength [info commands testgetencpath]] testConstraint fullutf [expr {[format %c 0x010000] ne "\uFFFD"}] testConstraint utf32 [expr {[testConstraint fullutf] && [string length [format %c 0x10000]] == 1}] - + # TclInitEncodingSubsystem is tested by the rest of this file # TclFinalizeEncodingSubsystem is not currently tested @@ -353,55 +353,55 @@ test encoding-15.6 {UtfToUtfProc emoji character output} utf32 { binary scan $y H* z list [string length $y] $z } {12 edb882eda0bdedb882eda0bd} -test encoding-15.7 {UtfToUtfProc emoji character output} utf32 { +test encoding-15.7 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uD83D set y [encoding convertto -nocomplain utf-8 \uDE02\uD83D\uD83D] binary scan $y H* z list [string length $x] [string length $y] $z } {3 9 edb882eda0bdeda0bd} -test encoding-15.8 {UtfToUtfProc emoji character output} utf32 { +test encoding-15.8 {UtfToUtfProc emoji character output} { set x \uDE02\uD83Dé set y [encoding convertto -nocomplain utf-8 \uDE02\uD83Dé] binary scan $y H* z list [string length $x] [string length $y] $z } {3 8 edb882eda0bdc3a9} -test encoding-15.9 {UtfToUtfProc emoji character output} utf32 { +test encoding-15.9 {UtfToUtfProc emoji character output} { set x \uDE02\uD83DX set y [encoding convertto -nocomplain utf-8 \uDE02\uD83DX] binary scan $y H* z list [string length $x] [string length $y] $z } {3 7 edb882eda0bd58} -test encoding-15.10 {UtfToUtfProc high surrogate character output} utf32 { +test encoding-15.10 {UtfToUtfProc high surrogate character output} { set x \uDE02é set y [encoding convertto -nocomplain utf-8 \uDE02é] binary scan $y H* z list [string length $x] [string length $y] $z } {2 5 edb882c3a9} -test encoding-15.11 {UtfToUtfProc low surrogate character output} utf32 { +test encoding-15.11 {UtfToUtfProc low surrogate character output} { set x \uDA02é set y [encoding convertto -nocomplain utf-8 \uDA02é] binary scan $y H* z list [string length $x] [string length $y] $z } {2 5 eda882c3a9} -test encoding-15.12 {UtfToUtfProc high surrogate character output} utf32 { +test encoding-15.12 {UtfToUtfProc high surrogate character output} { set x \uDE02Y set y [encoding convertto -nocomplain utf-8 \uDE02Y] binary scan $y H* z list [string length $x] [string length $y] $z } {2 4 edb88259} -test encoding-15.13 {UtfToUtfProc low surrogate character output} utf32 { +test encoding-15.13 {UtfToUtfProc low surrogate character output} { set x \uDA02Y set y [encoding convertto -nocomplain utf-8 \uDA02Y] binary scan $y H* z list [string length $x] [string length $y] $z } {2 4 eda88259} -test encoding-15.14 {UtfToUtfProc high surrogate character output} utf32 { +test encoding-15.14 {UtfToUtfProc high surrogate character output} { set x \uDE02 set y [encoding convertto -nocomplain utf-8 \uDE02] binary scan $y H* z list [string length $x] [string length $y] $z } {1 3 edb882} -test encoding-15.15 {UtfToUtfProc low surrogate character output} utf32 { +test encoding-15.15 {UtfToUtfProc low surrogate character output} { set x \uDA02 set y [encoding convertto -nocomplain utf-8 \uDA02] binary scan $y H* z @@ -707,7 +707,7 @@ test encoding-24.33 {Try to generate invalid utf-8 with -strict} -body { test encoding-24.34 {Try to generate invalid utf-8 with -nocomplain} -body { encoding convertto -nocomplain utf-8 \uFFFF } -result \xEF\xBF\xBF -test encoding-24.35 {Parse invalid utf-8} -body { +test encoding-24.35 {Parse invalid utf-8} -constraints utf32 -body { encoding convertfrom utf-8 \xED\xA0\x80 } -result \uD800 test encoding-24.36 {Parse invalid utf-8 with -strict} -body { -- cgit v0.12 From f029161eb76f8c022ce2d07098f8c92967bd12f2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 5 Dec 2022 13:10:20 +0000 Subject: Eliminate (gcc) warning in tclTest.c --- generic/tclTest.c | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index c5eb6eb..f4450ff 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -3122,15 +3122,16 @@ TestlinkCmd( tmp = Tcl_NewWideIntObj(longVar); Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); +#ifdef TCL_WIDE_INT_IS_LONG if (ulongVar > WIDE_MAX) { mp_int bignumValue; if (mp_init_u64(&bignumValue, ulongVar) != MP_OKAY) { Tcl_Panic("%s: memory overflow", "Tcl_SetWideUIntObj"); } tmp = Tcl_NewBignumObj(&bignumValue); - } else { - tmp = Tcl_NewWideIntObj((Tcl_WideInt)ulongVar); - } + } else +#endif /* TCL_WIDE_INT_IS_LONG */ + tmp = Tcl_NewWideIntObj((Tcl_WideInt)ulongVar); Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); Tcl_PrintDouble(NULL, (double)floatVar, buffer); -- cgit v0.12 From b1af92a6e9b1b3d5beb88352a5d8f610cb7bf0e0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 5 Dec 2022 15:33:57 +0000 Subject: On Cygwin, dev_t == unsigned, and long long == long --- generic/tcl.h | 16 ++++------------ generic/tclTomMath.h | 2 +- 2 files changed, 5 insertions(+), 13 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index c6afaa1..d36448b0 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -406,9 +406,7 @@ typedef int Tcl_Size; #endif #ifdef _WIN32 -# if TCL_MAJOR_VERSION > 8 - typedef struct __stat64 Tcl_StatBuf; -# elif defined(_WIN64) || defined(_USE_64BIT_TIME_T) +# if TCL_MAJOR_VERSION > 8 || defined(_WIN64) || defined(_USE_64BIT_TIME_T) typedef struct __stat64 Tcl_StatBuf; # elif defined(_USE_32BIT_TIME_T) typedef struct _stati64 Tcl_StatBuf; @@ -417,26 +415,20 @@ typedef int Tcl_Size; # endif #elif defined(__CYGWIN__) typedef struct { - dev_t st_dev; + unsigned st_dev; unsigned short st_ino; unsigned short st_mode; short st_nlink; short st_uid; short st_gid; /* Here is a 2-byte gap */ - dev_t st_rdev; + unsigned st_rdev; /* Here is a 4-byte gap */ - long long st_size; -#if TCL_MAJOR_VERSION > 8 - struct {long long tv_sec;} st_atim; - struct {long long tv_sec;} st_mtim; - struct {long long tv_sec;} st_ctim; -#else + long st_size; struct {long tv_sec;} st_atim; struct {long tv_sec;} st_mtim; struct {long tv_sec;} st_ctim; /* Here is a 4-byte gap */ -#endif } Tcl_StatBuf; #elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__) typedef struct stat64 Tcl_StatBuf; diff --git a/generic/tclTomMath.h b/generic/tclTomMath.h index b421cde..40a4e9d 100644 --- a/generic/tclTomMath.h +++ b/generic/tclTomMath.h @@ -4,7 +4,7 @@ #ifdef MP_NO_STDINT # ifdef HAVE_STDINT_H # include -#else +# else # include "../compat/stdint.h" # endif #endif -- cgit v0.12 From d8d1a902ef6f907032ea693bd66f898e56e6827c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 5 Dec 2022 15:39:50 +0000 Subject: There's no gap on Cygwin any more --- generic/tcl.h | 1 - 1 file changed, 1 deletion(-) diff --git a/generic/tcl.h b/generic/tcl.h index d36448b0..68e3082 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -428,7 +428,6 @@ typedef int Tcl_Size; struct {long tv_sec;} st_atim; struct {long tv_sec;} st_mtim; struct {long tv_sec;} st_ctim; - /* Here is a 4-byte gap */ } Tcl_StatBuf; #elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__) typedef struct stat64 Tcl_StatBuf; -- cgit v0.12 From 7b530373393bfc62e3f8a32bdfb427e6487d1fe2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 5 Dec 2022 23:05:25 +0000 Subject: dev_t -> unsigned for Cygwin in tcl.h, so we don't need sys/types.h any more. There's no gap in Tcl_StatBuf for 64-bit Cygwin --- generic/tcl.h | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 3a4622e..8b7c4ed 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -464,20 +464,19 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; # endif /* _MSC_VER < 1400 */ #elif defined(__CYGWIN__) typedef struct { - dev_t st_dev; + unsigned st_dev; unsigned short st_ino; unsigned short st_mode; short st_nlink; short st_uid; short st_gid; /* Here is a 2-byte gap */ - dev_t st_rdev; + unsigned st_rdev; /* Here is a 4-byte gap */ long long st_size; struct {long tv_sec;} st_atim; struct {long tv_sec;} st_mtim; struct {long tv_sec;} st_ctim; - /* Here is a 4-byte gap */ } Tcl_StatBuf; #elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__) typedef struct stat64 Tcl_StatBuf; -- cgit v0.12 From 1a21edb59250cdae54af5eab910e283beb0a12e0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 8 Dec 2022 17:17:48 +0000 Subject: Eliminate TclArithSeriesObjLength and TclArithSeriesObjStep from tclArithSeries.h: they can be static internal. --- generic/tclArithSeries.c | 19 ++++++++++--------- generic/tclArithSeries.h | 3 --- generic/tclCmdAH.c | 4 ++-- generic/tclCmdIL.c | 2 +- generic/tclExecute.c | 4 ++-- generic/tclListObj.c | 4 ++-- 6 files changed, 17 insertions(+), 19 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 632d812..ab4258a 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -42,6 +42,7 @@ static void DupArithSeriesInternalRep (Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeArithSeriesInternalRep (Tcl_Obj *listPtr); static int SetArithSeriesFromAny (Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfArithSeries (Tcl_Obj *listPtr); +static Tcl_Size ArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); /* * The structure below defines the arithmetic series Tcl object type by @@ -77,7 +78,7 @@ const TclObjTypeWithAbstractList tclArithSeriesType = { UpdateStringOfArithSeries, /* updateStringProc */ SetArithSeriesFromAny, /* setFromAnyProc */ TCL_OBJTYPE_V0_1( - TclArithSeriesObjLength + ArithSeriesObjLength )} }; @@ -364,7 +365,7 @@ TclNewArithSeriesObj( /* *---------------------------------------------------------------------- * - * TclArithSeriesObjStep -- + * ArithSeriesObjStep -- * * Return a Tcl_Obj with the step value from the give ArithSeries Obj. * refcount = 0. @@ -380,10 +381,10 @@ TclNewArithSeriesObj( *---------------------------------------------------------------------- */ /* - * TclArithSeriesObjStep -- + * ArithSeriesObjStep -- */ -int -TclArithSeriesObjStep( +static int +ArithSeriesObjStep( Tcl_Obj *arithSeriesPtr, Tcl_Obj **stepObj) { @@ -448,7 +449,7 @@ TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **ele /* *---------------------------------------------------------------------- * - * TclArithSeriesObjLength + * ArithSeriesObjLength * * Returns the length of the arithmetic series. * @@ -462,7 +463,7 @@ TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **ele * *---------------------------------------------------------------------- */ -Tcl_Size TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr) +Tcl_Size ArithSeriesObjLength(Tcl_Obj *arithSeriesPtr) { ArithSeries *arithSeriesRepPtr = (ArithSeries*) arithSeriesPtr->internalRep.twoPtrValue.ptr1; @@ -749,7 +750,7 @@ TclArithSeriesObjRange( return NULL; } Tcl_IncrRefCount(endObj); - TclArithSeriesObjStep(arithSeriesPtr, &stepObj); + ArithSeriesObjStep(arithSeriesPtr, &stepObj); Tcl_IncrRefCount(stepObj); if (Tcl_IsShared(arithSeriesPtr) || @@ -941,7 +942,7 @@ TclArithSeriesObjReverse( Tcl_IncrRefCount(startObj); TclArithSeriesObjIndex(arithSeriesPtr, 0, &endObj); Tcl_IncrRefCount(endObj); - TclArithSeriesObjStep(arithSeriesPtr, &stepObj); + ArithSeriesObjStep(arithSeriesPtr, &stepObj); Tcl_IncrRefCount(stepObj); if (isDouble) { diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h index 28fd993..91243db 100644 --- a/generic/tclArithSeries.h +++ b/generic/tclArithSeries.h @@ -35,11 +35,8 @@ typedef struct { MODULE_SCOPE Tcl_Obj * TclArithSeriesObjCopy(Tcl_Interp *interp, Tcl_Obj *arithSeriesPtr); -MODULE_SCOPE int TclArithSeriesObjStep(Tcl_Obj *arithSeriesPtr, - Tcl_Obj **stepObj); MODULE_SCOPE int TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **elementObj); -MODULE_SCOPE Tcl_Size TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Interp *interp, Tcl_Obj *arithSeriesPtr, Tcl_Size fromIdx, Tcl_Size toIdx); MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Interp *interp, diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 6a1de71..875bbdd 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -2735,8 +2735,8 @@ EachloopCmd( result = TCL_ERROR; goto done; } - /* Don't compute values here, wait until the last momement */ - statePtr->argcList[i] = TclArithSeriesObjLength(statePtr->aCopyList[i]); + /* Don't compute values here, wait until the last moment */ + statePtr->argcList[i] = ABSTRACTLIST_PROC(statePtr->aCopyList[i], lengthProc)(statePtr->aCopyList[i]); } else { /* List values */ statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]); diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 552548b..fbc4995 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2217,7 +2217,7 @@ Tcl_JoinObjCmd( if (TclHasInternalRep(objv[1],&tclArithSeriesType.objType)) { isArithSeries = 1; - listLen = TclArithSeriesObjLength(objv[1]); + listLen = ABSTRACTLIST_PROC(objv[1], lengthProc)(objv[1]); } else { if (TclListObjGetElementsM(interp, objv[1], &listLen, &elemPtrs) != TCL_OK) { diff --git a/generic/tclExecute.c b/generic/tclExecute.c index c1a2bfd..d1d7df1 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4661,7 +4661,7 @@ TEBCresume( /* special case for ArithSeries */ if (TclHasInternalRep(valuePtr,&tclArithSeriesType.objType)) { - length = TclArithSeriesObjLength(valuePtr); + length = ABSTRACTLIST_PROC(valuePtr, lengthProc)(valuePtr); if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); @@ -4724,7 +4724,7 @@ TEBCresume( /* special case for ArithSeries */ if (TclHasInternalRep(valuePtr,&tclArithSeriesType.objType)) { - length = TclArithSeriesObjLength(valuePtr); + length = ABSTRACTLIST_PROC(valuePtr, lengthProc)(valuePtr); /* Decode end-offset index values. */ diff --git a/generic/tclListObj.c b/generic/tclListObj.c index e29c307..8583bad 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -2641,7 +2641,7 @@ TclLindexFlat( /* Handle ArithSeries as special case */ if (TclHasInternalRep(listObj,&tclArithSeriesType.objType)) { - Tcl_Size listLen = TclArithSeriesObjLength(listObj); + Tcl_Size listLen = ABSTRACTLIST_PROC(listObj, lengthProc)(listObj); Tcl_Size index; Tcl_Obj *elemObj = NULL; for (i=0 ; i Date: Fri, 9 Dec 2022 10:22:11 +0000 Subject: Partial solution for [b8f575aa23]. Still missing: 1) testcases. 2) What if both EOF and ENCODING_ERROR happens (because there is both an eofchar and an invalid byte in the stream) --- generic/tclIO.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 8e4ecee..afe6aec 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -7588,7 +7588,7 @@ Tcl_Eof( ChannelState *statePtr = ((Channel *) chan)->state; /* State of real channel structure. */ - return GotFlag(statePtr, CHANNEL_EOF) ? 1 : 0; + return (GotFlag(statePtr, CHANNEL_EOF) && !GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) ? 1 : 0; } /* -- cgit v0.12 From ae31cee4ae595cd1a16f50df82add275c41d8cde Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 9 Dec 2022 14:53:25 +0000 Subject: Add 2 unit-tests, for the 2 cornercases mentioned in the TIP. This shows that the fix works as expected --- tests/io.test | 40 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) diff --git a/tests/io.test b/tests/io.test index c58bbce..d4839f5 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9065,6 +9065,46 @@ test io-75.6 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} -s removeFile io-75.6 } -match glob -result {41 1 {error reading "*": illegal byte sequence}} +test io-75.7 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { + set fn [makeFile {} io-75.7] + set f [open $fn w+] + fconfigure $f -encoding binary + # \x81 is invalid in utf-8. -eofchar is not detected, because it comes later. + puts -nonewline $f "A\x81\x1A" + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -strictencoding 1 +} -body { + set d [read $f] + binary scan $d H* hd + lappend hd [eof $f] + lappend hd [catch {read $f} msg] + close $f + lappend hd $msg +} -cleanup { + removeFile io-75.6 +} -match glob -result {41 0 1 {error reading "*": illegal byte sequence}} + +test io-75.8 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { + set fn [makeFile {} io-75.8] + set f [open $fn w+] + fconfigure $f -encoding binary + # \x81 is invalid in utf-8, but since \x1A comes first, -eofchar takes precedence. + puts -nonewline $f "A\x1A\x81" + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -strictencoding 1 +} -body { + set d [read $f] + binary scan $d H* hd + lappend hd [eof $f] + lappend hd [read $f] + close $f + set hd +} -cleanup { + removeFile io-75.6 +} -result {41 1 {}} + # ### ### ### ######### ######### ######### -- cgit v0.12 From 4f69a6f297bc3013c0c00a24db52fd34a59f902e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 9 Dec 2022 19:55:38 +0000 Subject: Fix compilation with tcc. Thanks, Cyan Ogilvie for the report --- generic/tcl.h | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index da3d1f0..f373382 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -156,8 +156,13 @@ extern "C" { # endif #else # define TCL_FORMAT_PRINTF(a,b) -# define TCL_NORETURN _declspec(noreturn) -# define TCL_NOINLINE __declspec(noinline) +# if defined(_MSC_VER) +# define TCL_NORETURN _declspec(noreturn) +# define TCL_NOINLINE __declspec(noinline) +# else +# define TCL_NORETURN /* nothing */ +# define TCL_NOINLINE /* nothing */ +# endif # define TCL_NORETURN1 /* nothing */ #endif -- cgit v0.12 From 196f704d08e8b1dd8cf3a6db055931a03d614ffb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 11 Dec 2022 17:57:55 +0000 Subject: More io test-cases. Mostly backported (and modified) from 9.0 --- tests/io.test | 155 ++++++++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 124 insertions(+), 31 deletions(-) diff --git a/tests/io.test b/tests/io.test index 65ebcbd..d10e1e4 100644 --- a/tests/io.test +++ b/tests/io.test @@ -13,12 +13,12 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -namespace eval ::tcl::test::io { +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.5 +} - if {"::tcltest" ni [namespace children]} { - package require tcltest 2.5 - namespace import -force ::tcltest::* - } +namespace eval ::tcl::test::io { + namespace import ::tcltest::* variable umaskValue variable path @@ -8924,7 +8924,7 @@ test io-73.5 {effect of eof on encoding end flags} -setup { read $rfd } -body { set result [eof $rfd] - puts -nonewline $wfd "more\xC2\xA0data" + puts -nonewline $wfd more\xC2\xA0data lappend result [eof $rfd] lappend result [read $rfd] lappend result [eof $rfd] @@ -8955,16 +8955,16 @@ test io-74.1 {[104f2885bb] improper cache validity check} -setup { # The following tests 75.1 to 75.5 exercise strict or tolerant channel # encoding. # TCL 8.7 only offers tolerant channel encoding, what is tested here. -test io-75.1 {multibyte encoding error read results in raw bytes} -constraints deprecated -setup { +test io-75.1 {multibyte encoding error read results in raw bytes} -setup { set fn [makeFile {} io-75.1] set f [open $fn w+] fconfigure $f -encoding binary # In UTF-8, a byte 0xCx starts a multibyte sequence and must be followed # by a byte > 0x7F. This is violated to get an invalid sequence. - puts -nonewline $f "A\xC0\x40" + puts -nonewline $f A\xC0\x40 flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none + fconfigure $f -encoding utf-8 -nocomplainencoding 1 -buffering none } -body { set d [read $f] binary scan $d H* hd @@ -8972,33 +8972,33 @@ test io-75.1 {multibyte encoding error read results in raw bytes} -constraints d } -cleanup { close $f removeFile io-75.1 -} -result "41c040" +} -result 41c040 -test io-75.2 {unrepresentable character write passes and is replaced by ?} -constraints deprecated -setup { +test io-75.2 {unrepresentable character write passes and is replaced by ? (-nocomplainencoding 1)} -setup { set fn [makeFile {} io-75.2] set f [open $fn w+] - fconfigure $f -encoding iso8859-1 + fconfigure $f -encoding iso8859-1 -nocomplainencoding 1 } -body { - puts -nonewline $f "A\u2022" + puts -nonewline $f A\u2022 flush $f seek $f 0 read $f } -cleanup { close $f removeFile io-75.2 -} -result "A?" +} -result A? # Incomplete sequence test. # This error may IMHO only be detected with the close. # But the read already returns the incomplete sequence. -test io-75.3 {incomplete multibyte encoding read is ignored} -setup { +test io-75.3 {incomplete multibyte encoding read is ignored (-nocomplainencoding 1)} -setup { set fn [makeFile {} io-75.3] set f [open $fn w+] fconfigure $f -encoding binary puts -nonewline $f "A\xC0" flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none + fconfigure $f -encoding utf-8 -buffering none -nocomplainencoding 1 } -body { set d [read $f] close $f @@ -9006,37 +9006,37 @@ test io-75.3 {incomplete multibyte encoding read is ignored} -setup { set hd } -cleanup { removeFile io-75.3 -} -result "41c0" +} -result 41c0 # As utf-8 has a special treatment in multi-byte decoding, also test another # one. -test io-75.4 {shiftjis encoding error read results in raw bytes} -setup { +test io-75.4 {shiftjis encoding error read results in raw bytes (-nocomplainencoding 1)} -setup { set fn [makeFile {} io-75.4] set f [open $fn w+] fconfigure $f -encoding binary # In shiftjis, \x81 starts a two-byte sequence. # But 2nd byte \xFF is not allowed - puts -nonewline $f "A\x81\xFFA" + puts -nonewline $f A\x81\xFFA flush $f seek $f 0 - fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf -} -constraints deprecated -body { + fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf -nocomplainencoding 1 +} -body { set d [read $f] binary scan $d H* hd set hd } -cleanup { close $f removeFile io-75.4 -} -result "4181ff41" +} -result 4181ff41 -test io-75.5 {invalid utf-8 encoding read is ignored} -setup { +test io-75.5 {invalid utf-8 encoding read is ignored (-nocomplainencoding 1)} -setup { set fn [makeFile {} io-75.5] set f [open $fn w+] fconfigure $f -encoding binary - puts -nonewline $f "A\x81" + puts -nonewline $f A\x81 flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf + fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -nocomplainencoding 1 } -body { set d [read $f] close $f @@ -9044,14 +9044,14 @@ test io-75.5 {invalid utf-8 encoding read is ignored} -setup { set hd } -cleanup { removeFile io-75.5 -} -result "4181" +} -result 4181 test io-75.6 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} -setup { set fn [makeFile {} io-75.6] set f [open $fn w+] fconfigure $f -encoding binary # \x81 is invalid in utf-8 - puts -nonewline $f "A\x81" + puts -nonewline $f A\x81 flush $f seek $f 0 fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -strictencoding 1 @@ -9070,7 +9070,7 @@ test io-75.7 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { set f [open $fn w+] fconfigure $f -encoding binary # \xA1 is invalid in utf-8. -eofchar is not detected, because it comes later. - puts -nonewline $f "A\xA1\x1A" + puts -nonewline $f A\xA1\x1A flush $f seek $f 0 fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -strictencoding 1 @@ -9085,7 +9085,7 @@ test io-75.7 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { close $f set hd } -cleanup { - removeFile io-75.6 + removeFile io-75.7 } -match glob -result {41 0 1 {error reading "*": illegal byte sequence} ¡} test io-75.8 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { @@ -9093,7 +9093,7 @@ test io-75.8 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { set f [open $fn w+] fconfigure $f -encoding binary # \x81 is invalid in utf-8, but since \x1A comes first, -eofchar takes precedence. - puts -nonewline $f "A\x1A\x81" + puts -nonewline $f A\x1A\x81 flush $f seek $f 0 fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -strictencoding 1 @@ -9105,9 +9105,102 @@ test io-75.8 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { close $f set hd } -cleanup { - removeFile io-75.6 + removeFile io-75.8 } -result {41 1 {}} +test io-75.9 {unrepresentable character write passes and is replaced by ?} -setup { + set fn [makeFile {} io-75.9] + set f [open $fn w+] + fconfigure $f -encoding iso8859-1 -strictencoding 1 +} -body { + catch {puts -nonewline $f "A\u2022"} msg + flush $f + seek $f 0 + list [read $f] $msg +} -cleanup { + close $f + removeFile io-75.9 +} -match glob -result [list {A} {error writing "*": illegal byte sequence}] + +# Incomplete sequence test. +# This error may IMHO only be detected with the close. +# But the read already returns the incomplete sequence. +test io-75.10 {incomplete multibyte encoding read is ignored} -setup { + set fn [makeFile {} io-75.10] + set f [open $fn w+] + fconfigure $f -encoding binary + puts -nonewline $f A\xC0 + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none +} -body { + set d [read $f] + close $f + binary scan $d H* hd + set hd +} -cleanup { + removeFile io-75.10 +} -result 41c0 +# The current result returns the orphan byte as byte. +# This may be expected due to special utf-8 handling. + +# As utf-8 has a special treatment in multi-byte decoding, also test another +# one. +test io-75.11 {shiftjis encoding error read results in raw bytes} -setup { + set fn [makeFile {} io-75.11] + set f [open $fn w+] + fconfigure $f -encoding binary + # In shiftjis, \x81 starts a two-byte sequence. + # But 2nd byte \xFF is not allowed + puts -nonewline $f A\x81\xFFA + flush $f + seek $f 0 + fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf -strictencoding 1 +} -body { + set d [read $f] + binary scan $d H* hd + lappend hd [catch {set d [read $f]} msg] + lappend hd $msg +} -cleanup { + close $f + removeFile io-75.11 +} -match glob -result {41 1 {error reading "*": illegal byte sequence}} + +test io-75.12 {invalid utf-8 encoding read is ignored} -setup { + set fn [makeFile {} io-75.12] + set f [open $fn w+] + fconfigure $f -encoding binary + puts -nonewline $f A\x81 + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf +} -body { + set d [read $f] + close $f + binary scan $d H* hd + set hd +} -cleanup { + removeFile io-75.12 +} -result 4181 +test io-75.13 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} -setup { + set fn [makeFile {} io-75.13] + set f [open $fn w+] + fconfigure $f -encoding binary + # \x81 is invalid in utf-8 + puts -nonewline $f "A\x81" + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -strictencoding 1 +} -body { + set d [read $f] + binary scan $d H* hd + lappend hd [catch {read $f} msg] + close $f + lappend hd $msg +} -cleanup { + removeFile io-75.13 +} -match glob -result {41 1 {error reading "*": illegal byte sequence}} + # ### ### ### ######### ######### ######### -- cgit v0.12 From 89be5d2d3d0734da0af7a0d6a678f292be3013c3 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 12 Dec 2022 06:08:21 +0000 Subject: Change copyright in Windows rc from Activestate to UCal and others to match license. --- win/tcl.rc | 3 +-- win/tclsh.rc | 3 +-- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/win/tcl.rc b/win/tcl.rc index be5e0a7..06024d4 100644 --- a/win/tcl.rc +++ b/win/tcl.rc @@ -43,9 +43,8 @@ BEGIN BEGIN VALUE "FileDescription", "Tcl DLL\0" VALUE "OriginalFilename", "tcl" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".dll\0" - VALUE "CompanyName", "ActiveState Corporation\0" VALUE "FileVersion", TCL_PATCH_LEVEL - VALUE "LegalCopyright", "Copyright \251 2001 by ActiveState Corporation, et al\0" + VALUE "LegalCopyright", "Copyright \251 1987-2022 Regents of the University of California and other parties\0" VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0" VALUE "ProductVersion", TCL_PATCH_LEVEL END diff --git a/win/tclsh.rc b/win/tclsh.rc index 161da50..685bebd1 100644 --- a/win/tclsh.rc +++ b/win/tclsh.rc @@ -50,9 +50,8 @@ BEGIN BEGIN VALUE "FileDescription", "Tclsh Application\0" VALUE "OriginalFilename", "tclsh" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".exe\0" - VALUE "CompanyName", "ActiveState Corporation\0" VALUE "FileVersion", TCL_PATCH_LEVEL - VALUE "LegalCopyright", "Copyright \251 2000 by ActiveState Corporation, et al\0" + VALUE "LegalCopyright", "Copyright \251 1987-2022 Regents of the University of California and other parties\0" VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0" VALUE "ProductVersion", TCL_PATCH_LEVEL END -- cgit v0.12 From 2e1db6850f0a6da09fd1457c2f2cf851f4c5f315 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 13 Dec 2022 07:42:17 +0000 Subject: Clarify what "-strict" means for the utf-8 encoder, making it clear that this is not the same as "strict" in python --- doc/encoding.n | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/doc/encoding.n b/doc/encoding.n index bbe197d..78580f2 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -54,9 +54,9 @@ The option \fB-nocomplain\fR has no effect and is available for compatibility wi TCL 9. In TCL 9, the encoding command fails with an error on any encoding issue. This switch restores the TCL8.7 behaviour. .PP -The \fB-strict\fR option followes more strict rules in conversion. Currently, only -the sequence \fB\\xC0\\x80\fR in \fButf-8\fR encoding is disallowed. Additional rules -may follow. +The \fB-strict\fR option follows more strict rules in conversion. For the \fButf-8\fR +encoder, it disallows the the sequence \fB\\xC0\\x80\fR and noncharacters (which - +otherwise - are just passed through). .VE "TCL8.7 TIP346, TIP607, TIP601" .RE .TP @@ -87,8 +87,9 @@ The option \fB-nocomplain\fR has no effect and is available for compatibility wi TCL 9. In TCL 9, the encoding command fails with an error on any encoding issue. This switch restores the TCL8.7 behaviour. .PP -The \fB-strict\fR option followes more strict rules in conversion. Currently, it has -no effect but may be used in future to add additional encoding checks. +The \fB-strict\fR option follows more strict rules in conversion. For the \fButf-8\fR +encoder, it disallows the the sequence \fB\\xC0\\x80\fR and noncharacters (which - +otherwise - are just passed through). .VE "TCL8.7 TIP346, TIP607, TIP601" .RE .TP -- cgit v0.12 From 7b36aa11b6880b342a177a864601d97d839b7279 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 15 Dec 2022 14:38:24 +0000 Subject: Fix Tcl_BadChannelOption(), new -nocomplainencoding and -strictencoding options were still missing (reported by Rolf Ade, thanks!) --- generic/tclIO.c | 2 +- tests/winConsole.test | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 8a551f3..730d963 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -7862,7 +7862,7 @@ Tcl_BadChannelOption( { if (interp != NULL) { const char *genericopt = - "blocking buffering buffersize encoding eofchar translation"; + "blocking buffering buffersize encoding eofchar nocomplainencoding strictencoding translation"; const char **argv; int argc, i; Tcl_DString ds; diff --git a/tests/winConsole.test b/tests/winConsole.test index 821a143..b04f3e9 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -224,7 +224,7 @@ test console-fconfigure-get-1.[incr testnum] { fconfigure -winsize } -constraints {win interactive} -body { fconfigure stdin -winsize -} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -inputmode} -returnCodes error +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -nocomplainencoding, -strictencoding, -translation, or -inputmode} -returnCodes error ## fconfigure get stdout/stderr foreach chan {stdout stderr} major {2 3} { @@ -260,7 +260,7 @@ foreach chan {stdout stderr} major {2 3} { fconfigure -inputmode } -constraints {win interactive} -body { fconfigure $chan -inputmode - } -result {bad option "-inputmode": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -winsize} -returnCodes error + } -result {bad option "-inputmode": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -nocomplainencoding, -strictencoding, -translation, or -winsize} -returnCodes error } @@ -330,7 +330,7 @@ test console-fconfigure-set-1.3 { fconfigure stdin -winsize } -constraints {win interactive} -body { fconfigure stdin -winsize {10 30} -} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -inputmode} -returnCodes error +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -nocomplainencoding, -strictencoding, -translation, or -inputmode} -returnCodes error ## fconfigure set stdout,stderr @@ -338,13 +338,13 @@ test console-fconfigure-set-2.0 { fconfigure stdout -winsize } -constraints {win interactive} -body { fconfigure stdout -winsize {10 30} -} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation} -returnCodes error +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -nocomplainencoding, -strictencoding, or -translation} -returnCodes error test console-fconfigure-set-3.0 { fconfigure stderr -winsize } -constraints {win interactive} -body { fconfigure stderr -winsize {10 30} -} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation} -returnCodes error +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -nocomplainencoding, -strictencoding, or -translation} -returnCodes error # Multiple threads -- cgit v0.12 From 9faf91402bd760daffdd9a305bd63065e9c9dc11 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 15 Dec 2022 23:59:48 +0000 Subject: Make -strict work the same for UTF-16 as for UTF-8 --- generic/tclEncoding.c | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 169e975..78b0b9d 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2565,6 +2565,13 @@ Utf32ToUtfProc( } else { ch = (src[0] & 0xFF) << 24 | (src[1] & 0xFF) << 16 | (src[2] & 0xFF) << 8 | (src[3] & 0xFF); } + if (ch >= 0x10FFFF || (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) + && !Tcl_UniCharIsUnicode(ch))) { + if (STOPONERROR) { + result = TCL_CONVERT_SYNTAX; + break; + } + } /* * Special case for 1-byte utf chars for speed. Make sure we work with @@ -2655,12 +2662,11 @@ UtfToUtf32Proc( break; } len = TclUtfToUCS4(src, &ch); - if (!Tcl_UniCharIsUnicode(ch)) { + if (!Tcl_UniCharIsUnicode(ch) && (((ch & ~0x7FF) == 0xD800) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT))) { if (STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; } - ch = 0xFFFD; } src += len; if (flags & TCL_ENCODING_LE) { @@ -2858,12 +2864,11 @@ UtfToUtf16Proc( break; } len = TclUtfToUCS4(src, &ch); - if (!Tcl_UniCharIsUnicode(ch)) { + if (!Tcl_UniCharIsUnicode(ch) && (((ch & ~0x7FF) == 0xD800) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT))) { if (STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; } - ch = 0xFFFD; } src += len; if (flags & TCL_ENCODING_LE) { -- cgit v0.12 From 94c928a85902c6e9cd103d3b2e9f6fca2cfacc6b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 16 Dec 2022 08:15:02 +0000 Subject: Add testcase --- tests/encoding.test | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/tests/encoding.test b/tests/encoding.test index 1125397..db70744 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -490,16 +490,22 @@ test encoding-17.2 {UtfToUcs2Proc} -body { } -result "\uFFFD" test encoding-17.3 {UtfToUtf16Proc} -body { encoding convertto -nocomplain utf-16be "\uDCDC" -} -result "\xFF\xFD" +} -result "\xDC\xDC" test encoding-17.4 {UtfToUtf16Proc} -body { encoding convertto -nocomplain utf-16le "\uD8D8" -} -result "\xFD\xFF" +} -result "\xD8\xD8" test encoding-17.5 {UtfToUtf16Proc} -body { encoding convertto utf-32le "\U460DC" } -result "\xDC\x60\x04\x00" test encoding-17.6 {UtfToUtf16Proc} -body { encoding convertto utf-32be "\U460DC" } -result "\x00\x04\x60\xDC" +test encoding-17.7 {UtfToUtf16Proc} -body { + encoding convertto -strict utf-16be "\uDCDC" +} -returnCodes error -result {unexpected character at index 0: 'U+00DCDC'} +test encoding-17.8 {UtfToUtf16Proc} -body { + encoding convertto -strict utf-16le "\uD8D8" +} -returnCodes error -result {unexpected character at index 0: 'U+00D8D8'} test encoding-18.1 {TableToUtfProc} { } {} -- cgit v0.12 From c78879e7075b00638b1dc25237b2e208e35a82ca Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 16 Dec 2022 09:25:54 +0000 Subject: Adapt iocmd-8.* testcases to change in previous commit --- tests/ioCmd.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/ioCmd.test b/tests/ioCmd.test index c4edd25..73f0e1c 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -207,7 +207,7 @@ test iocmd-7.5 {close command} -setup { proc expectedOpts {got extra} { set basicOpts { - -blocking -buffering -buffersize -encoding -eofchar -translation + -blocking -buffering -buffersize -encoding -eofchar -nocomplainencoding -strictencoding -translation } set opts [list {*}$basicOpts {*}$extra] lset opts end [string cat "or " [lindex $opts end]] -- cgit v0.12 From fd98096770210ed4e5e1ddbf93c7d3860716efcb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 16 Dec 2022 10:23:56 +0000 Subject: Addendum to [https://core.tcl-lang.org/tips/doc/trunk/tip/601.md|TIP #601]. Add check for characters > U+10FFFF in utf-32. Since utf-8 cannot handle that, either replace it with the replacement character (-nocomplain) or throw an exception (-strict). --- generic/tclEncoding.c | 2 +- tests/encoding.test | 6 ++++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 78b0b9d..f81b0eb 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2565,7 +2565,7 @@ Utf32ToUtfProc( } else { ch = (src[0] & 0xFF) << 24 | (src[1] & 0xFF) << 16 | (src[2] & 0xFF) << 8 | (src[3] & 0xFF); } - if (ch >= 0x10FFFF || (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) + if ((unsigned)ch > 0x10FFFF || (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) && !Tcl_UniCharIsUnicode(ch))) { if (STOPONERROR) { result = TCL_CONVERT_SYNTAX; diff --git a/tests/encoding.test b/tests/encoding.test index db70744..19c7cca 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -506,6 +506,12 @@ test encoding-17.7 {UtfToUtf16Proc} -body { test encoding-17.8 {UtfToUtf16Proc} -body { encoding convertto -strict utf-16le "\uD8D8" } -returnCodes error -result {unexpected character at index 0: 'U+00D8D8'} +test encoding-17.9 {Utf32ToUtfProc} -body { + encoding convertfrom -strict utf-32 "\xFF\xFF\xFF\xFF" +} -returnCodes error -result {unexpected byte sequence starting at index 0: '\xFF'} +test encoding-17.10 {Utf32ToUtfProc} -body { + encoding convertfrom -nocomplain utf-32 "\xFF\xFF\xFF\xFF" +} -result \uFFFD test encoding-18.1 {TableToUtfProc} { } {} -- cgit v0.12 From f632ecb40650fc82b537e938435e44e2c1f2fb14 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 16 Dec 2022 12:16:54 +0000 Subject: Now that 32-bit cygwin is dead, eliminate the need for --enable-64bit in a Cygwin build --- unix/configure | 50 ++++++++++++++++++------------------- unix/tcl.m4 | 78 +++++++++++++++++++++++++++++----------------------------- 2 files changed, 64 insertions(+), 64 deletions(-) diff --git a/unix/configure b/unix/configure index 043da1c..11ee9ef 100755 --- a/unix/configure +++ b/unix/configure @@ -6782,7 +6782,7 @@ fi LD_SEARCH_FLAGS="" ;; CYGWIN_*|MINGW32_*|MSYS_*) - SHLIB_CFLAGS="" + SHLIB_CFLAGS="-fno-common" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".dll" DL_OBJS="tclLoadDl.o" @@ -6864,9 +6864,9 @@ echo "$as_me: error: CYGWIN compile is only supported with --enable-threads" >&2 fi do64bit_ok=yes if test "x${SHARED_BUILD}" = "x1"; then - echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args" + echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args --enable-64bit --host=x86_64-w64-mingw32" # The eval makes quoting arguments work. - if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args; cd ../unix + if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args --enable-64bit --host=x86_64-w64-mingw32; cd ../unix then : else { echo "configure: error: configure failed for ../win" 1>&2; exit 1; } @@ -7307,7 +7307,7 @@ fi ;; Linux*|GNU*|NetBSD-Debian|DragonFly-*|FreeBSD-*) - SHLIB_CFLAGS="-fPIC" + SHLIB_CFLAGS="-fPIC -fno-common" SHLIB_SUFFIX=".so" CFLAGS_OPTIMIZE="-O2" @@ -7517,7 +7517,7 @@ fi # The -pthread needs to go in the CFLAGS, not LIBS LIBS=`echo $LIBS | sed s/-pthread//` CFLAGS="$CFLAGS -pthread" - LDFLAGS="$LDFLAGS -pthread" + LDFLAGS="$LDFLAGS -pthread" fi @@ -8207,13 +8207,13 @@ fi # below. if test "$GCC" = yes; then - SHLIB_CFLAGS="-fPIC -melf" - LDFLAGS="$LDFLAGS -melf -Wl,-Bexport" + SHLIB_CFLAGS="-fPIC -melf" + LDFLAGS="$LDFLAGS -melf -Wl,-Bexport" else - SHLIB_CFLAGS="-Kpic -belf" - LDFLAGS="$LDFLAGS -belf -Wl,-Bexport" + SHLIB_CFLAGS="-Kpic -belf" + LDFLAGS="$LDFLAGS -belf -Wl,-Bexport" fi @@ -8848,11 +8848,11 @@ fi - # See if the compiler supports casting to a union type. - # This is used to stop gcc from printing a compiler - # warning when initializing a union member. + # See if the compiler supports casting to a union type. + # This is used to stop gcc from printing a compiler + # warning when initializing a union member. - echo "$as_me:$LINENO: checking for cast to union support" >&5 + echo "$as_me:$LINENO: checking for cast to union support" >&5 echo $ECHO_N "checking for cast to union support... $ECHO_C" >&6 if test "${tcl_cv_cast_to_union+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 @@ -8868,8 +8868,8 @@ int main () { - union foo { int i; double d; }; - union foo f = (union foo) (int) 0; + union foo { int i; double d; }; + union foo f = (union foo) (int) 0; ; return 0; @@ -8909,15 +8909,15 @@ rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $tcl_cv_cast_to_union" >&5 echo "${ECHO_T}$tcl_cv_cast_to_union" >&6 - if test "$tcl_cv_cast_to_union" = "yes"; then + if test "$tcl_cv_cast_to_union" = "yes"; then cat >>confdefs.h <<\_ACEOF #define HAVE_CAST_TO_UNION 1 _ACEOF - fi - hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -fno-lto" - echo "$as_me:$LINENO: checking for working -fno-lto" >&5 + fi + hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -fno-lto" + echo "$as_me:$LINENO: checking for working -fno-lto" >&5 echo $ECHO_N "checking for working -fno-lto... $ECHO_C" >&6 if test "${ac_cv_nolto+set}" = set; then echo $ECHO_N "(cached) $ECHO_C" >&6 @@ -8971,12 +8971,12 @@ rm -f conftest.err conftest.$ac_objext conftest.$ac_ext fi echo "$as_me:$LINENO: result: $ac_cv_nolto" >&5 echo "${ECHO_T}$ac_cv_nolto" >&6 - CFLAGS=$hold_cflags - if test "$ac_cv_nolto" = "yes" ; then - CFLAGS_NOLTO="-fno-lto" - else - CFLAGS_NOLTO="" - fi + CFLAGS=$hold_cflags + if test "$ac_cv_nolto" = "yes" ; then + CFLAGS_NOLTO="-fno-lto" + else + CFLAGS_NOLTO="" + fi # FIXME: This subst was left in only because the TCL_DL_LIBS # entry in tclConfig.sh uses it. It is not clear why someone diff --git a/unix/tcl.m4 b/unix/tcl.m4 index ca94abd..6063847 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1185,7 +1185,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ LD_SEARCH_FLAGS="" ;; CYGWIN_*|MINGW32_*|MSYS_*) - SHLIB_CFLAGS="" + SHLIB_CFLAGS="-fno-common" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".dll" DL_OBJS="tclLoadDl.o" @@ -1215,9 +1215,9 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ fi do64bit_ok=yes if test "x${SHARED_BUILD}" = "x1"; then - echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args" + echo "running cd ../win; ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args --enable-64bit --host=x86_64-w64-mingw32" # The eval makes quoting arguments work. - if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args; cd ../unix + if cd ../win; eval ${CONFIG_SHELL-/bin/sh} ./configure $ac_configure_args --enable-64bit --host=x86_64-w64-mingw32; cd ../unix then : else { echo "configure: error: configure failed for ../win" 1>&2; exit 1; } @@ -1373,7 +1373,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ ]) ;; Linux*|GNU*|NetBSD-Debian|DragonFly-*|FreeBSD-*) - SHLIB_CFLAGS="-fPIC" + SHLIB_CFLAGS="-fPIC -fno-common" SHLIB_SUFFIX=".so" CFLAGS_OPTIMIZE="-O2" @@ -1500,7 +1500,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ # The -pthread needs to go in the CFLAGS, not LIBS LIBS=`echo $LIBS | sed s/-pthread//` CFLAGS="$CFLAGS -pthread" - LDFLAGS="$LDFLAGS -pthread" + LDFLAGS="$LDFLAGS -pthread" ]) ;; Darwin-*) @@ -1740,11 +1740,11 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ # this test works, since "uname -s" was non-standard in 3.2.4 and # below. AS_IF([test "$GCC" = yes], [ - SHLIB_CFLAGS="-fPIC -melf" - LDFLAGS="$LDFLAGS -melf -Wl,-Bexport" + SHLIB_CFLAGS="-fPIC -melf" + LDFLAGS="$LDFLAGS -melf -Wl,-Bexport" ], [ - SHLIB_CFLAGS="-Kpic -belf" - LDFLAGS="$LDFLAGS -belf -Wl,-Bexport" + SHLIB_CFLAGS="-Kpic -belf" + LDFLAGS="$LDFLAGS -belf -Wl,-Bexport" ]) SHLIB_LD="ld -G" SHLIB_LD_LIBS="" @@ -2037,36 +2037,36 @@ dnl # preprocessing tests use only CPPFLAGS. TCL_LIBS="${DL_LIBS} ${LIBS} ${MATH_LIBS}"]) AC_SUBST(TCL_LIBS) - # See if the compiler supports casting to a union type. - # This is used to stop gcc from printing a compiler - # warning when initializing a union member. - - AC_CACHE_CHECK(for cast to union support, - tcl_cv_cast_to_union, - AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]], [[ - union foo { int i; double d; }; - union foo f = (union foo) (int) 0; - ]])], - [tcl_cv_cast_to_union=yes], - [tcl_cv_cast_to_union=no]) - ) - if test "$tcl_cv_cast_to_union" = "yes"; then - AC_DEFINE(HAVE_CAST_TO_UNION, 1, - [Defined when compiler supports casting to union type.]) - fi - hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -fno-lto" - AC_CACHE_CHECK(for working -fno-lto, - ac_cv_nolto, - AC_COMPILE_IFELSE([AC_LANG_PROGRAM([])], - [ac_cv_nolto=yes], - [ac_cv_nolto=no]) - ) - CFLAGS=$hold_cflags - if test "$ac_cv_nolto" = "yes" ; then - CFLAGS_NOLTO="-fno-lto" - else - CFLAGS_NOLTO="" - fi + # See if the compiler supports casting to a union type. + # This is used to stop gcc from printing a compiler + # warning when initializing a union member. + + AC_CACHE_CHECK(for cast to union support, + tcl_cv_cast_to_union, + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]], [[ + union foo { int i; double d; }; + union foo f = (union foo) (int) 0; + ]])], + [tcl_cv_cast_to_union=yes], + [tcl_cv_cast_to_union=no]) + ) + if test "$tcl_cv_cast_to_union" = "yes"; then + AC_DEFINE(HAVE_CAST_TO_UNION, 1, + [Defined when compiler supports casting to union type.]) + fi + hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -fno-lto" + AC_CACHE_CHECK(for working -fno-lto, + ac_cv_nolto, + AC_COMPILE_IFELSE([AC_LANG_PROGRAM([])], + [ac_cv_nolto=yes], + [ac_cv_nolto=no]) + ) + CFLAGS=$hold_cflags + if test "$ac_cv_nolto" = "yes" ; then + CFLAGS_NOLTO="-fno-lto" + else + CFLAGS_NOLTO="" + fi # FIXME: This subst was left in only because the TCL_DL_LIBS # entry in tclConfig.sh uses it. It is not clear why someone -- cgit v0.12 From 2031d40f819aee5bbd3c5b550228204ff2897e0c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 16 Dec 2022 15:16:56 +0000 Subject: Add checks to the configure script for mknod, tcdrain and uname, for systems (like VxWorks) which don't have it. See [aa4d088e5d] --- unix/configure | 300 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ unix/configure.in | 3 + 2 files changed, 303 insertions(+) diff --git a/unix/configure b/unix/configure index 11ee9ef..8981ef8 100755 --- a/unix/configure +++ b/unix/configure @@ -10687,6 +10687,306 @@ _ACEOF fi +echo "$as_me:$LINENO: checking for fork" >&5 +echo $ECHO_N "checking for fork... $ECHO_C" >&6 +if test "${ac_cv_func_fork+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define fork to an innocuous variant, in case declares fork. + For example, HP-UX 11i declares gettimeofday. */ +#define fork innocuous_fork + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char fork (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef fork + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char fork (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_fork) || defined (__stub___fork) +choke me +#else +char (*f) () = fork; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != fork; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_fork=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_fork=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_fork" >&5 +echo "${ECHO_T}$ac_cv_func_fork" >&6 +if test $ac_cv_func_fork = yes; then + : +else + +cat >>confdefs.h <<\_ACEOF +#define NO_FORK 1 +_ACEOF + +fi + +echo "$as_me:$LINENO: checking for mknod" >&5 +echo $ECHO_N "checking for mknod... $ECHO_C" >&6 +if test "${ac_cv_func_mknod+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define mknod to an innocuous variant, in case declares mknod. + For example, HP-UX 11i declares gettimeofday. */ +#define mknod innocuous_mknod + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char mknod (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef mknod + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char mknod (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_mknod) || defined (__stub___mknod) +choke me +#else +char (*f) () = mknod; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != mknod; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_mknod=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_mknod=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_mknod" >&5 +echo "${ECHO_T}$ac_cv_func_mknod" >&6 +if test $ac_cv_func_mknod = yes; then + : +else + +cat >>confdefs.h <<\_ACEOF +#define NO_MKNOD 1 +_ACEOF + +fi + +echo "$as_me:$LINENO: checking for tcdrain" >&5 +echo $ECHO_N "checking for tcdrain... $ECHO_C" >&6 +if test "${ac_cv_func_tcdrain+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define tcdrain to an innocuous variant, in case declares tcdrain. + For example, HP-UX 11i declares gettimeofday. */ +#define tcdrain innocuous_tcdrain + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char tcdrain (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef tcdrain + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char tcdrain (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_tcdrain) || defined (__stub___tcdrain) +choke me +#else +char (*f) () = tcdrain; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != tcdrain; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_tcdrain=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_func_tcdrain=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_func_tcdrain" >&5 +echo "${ECHO_T}$ac_cv_func_tcdrain" >&6 +if test $ac_cv_func_tcdrain = yes; then + : +else + +cat >>confdefs.h <<\_ACEOF +#define NO_TCDRAIN 1 +_ACEOF + +fi + echo "$as_me:$LINENO: checking for uname" >&5 echo $ECHO_N "checking for uname... $ECHO_C" >&6 if test "${ac_cv_func_uname+set}" = set; then diff --git a/unix/configure.in b/unix/configure.in index 62ab90e..55f09eb 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -215,6 +215,9 @@ AC_REPLACE_FUNCS(mkstemp opendir strtol waitpid) AC_CHECK_FUNC(strerror, , [AC_DEFINE(NO_STRERROR, 1, [Do we have strerror()])]) AC_CHECK_FUNC(getwd, , [AC_DEFINE(NO_GETWD, 1, [Do we have getwd()])]) AC_CHECK_FUNC(wait3, , [AC_DEFINE(NO_WAIT3, 1, [Do we have wait3()])]) +AC_CHECK_FUNC(fork, , [AC_DEFINE(NO_FORK, 1, [Do we have fork()])]) +AC_CHECK_FUNC(mknod, , [AC_DEFINE(NO_MKNOD, 1, [Do we have mknod()])]) +AC_CHECK_FUNC(tcdrain, , [AC_DEFINE(NO_TCDRAIN, 1, [Do we have tcdrain()])]) AC_CHECK_FUNC(uname, , [AC_DEFINE(NO_UNAME, 1, [Do we have uname()])]) if test "`uname -s`" = "Darwin" && test "${TCL_THREADS}" = 1 && \ -- cgit v0.12 From c05419204a477060c97bc9991114b62ee2324c8f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 16 Dec 2022 15:26:40 +0000 Subject: Update tclConfig.h.in --- unix/tclConfig.h.in | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in index c8d4e0c..0b7ed35 100644 --- a/unix/tclConfig.h.in +++ b/unix/tclConfig.h.in @@ -309,6 +309,9 @@ /* Do we have ? */ #undef NO_FLOAT_H +/* Do we have fork() */ +#undef NO_FORK + /* Do we have fstatfs()? */ #undef NO_FSTATFS @@ -324,6 +327,9 @@ /* Do we have memmove()? */ #undef NO_MEMMOVE +/* Do we have mknod() */ +#undef NO_MKNOD + /* Do we have realpath() */ #undef NO_REALPATH @@ -339,6 +345,9 @@ /* Do we have ? */ #undef NO_SYS_WAIT_H +/* Do we have tcdrain() */ +#undef NO_TCDRAIN + /* Do we have uname() */ #undef NO_UNAME -- cgit v0.12 From 002511bea498081ece2abcbbc0b065a48f0cf8af Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 18 Dec 2022 18:08:38 +0000 Subject: MODULE_SCOPE TclLengthOne (in stead of 2 separate static functions doing the same) --- generic/tclInt.h | 2 ++ generic/tclObj.c | 10 ++++------ generic/tclUtil.c | 13 +++++++++---- 3 files changed, 15 insertions(+), 10 deletions(-) diff --git a/generic/tclInt.h b/generic/tclInt.h index 392ccab..827fd6f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -1103,6 +1103,8 @@ typedef struct { /* For internal core use only */ && ((objPtr)->typePtr->version > offsetof(TclObjTypeWithAbstractList, abstractList.proc))) ? \ ((const TclObjTypeWithAbstractList *)(objPtr)->typePtr)->abstractList.proc : NULL) +MODULE_SCOPE size_t TclLengthOne(Tcl_Obj *); + /* * The structure below defines an entry in the assocData hash table which is * associated with an interpreter. The entry contains a pointer to a function diff --git a/generic/tclObj.c b/generic/tclObj.c index 67b7487..eaa6766 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -225,8 +225,6 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); * implementations. */ -static size_t LengthOne(TCL_UNUSED(Tcl_Obj *)) {return 1;} - const TclObjTypeWithAbstractList tclBooleanType= { {"boolean", /* name */ NULL, /* freeIntRepProc */ @@ -234,7 +232,7 @@ const TclObjTypeWithAbstractList tclBooleanType= { NULL, /* updateStringProc */ TclSetBooleanFromAny, /* setFromAnyProc */ TCL_OBJTYPE_V0_1( - LengthOne + TclLengthOne )} }; const TclObjTypeWithAbstractList tclDoubleType= { @@ -244,7 +242,7 @@ const TclObjTypeWithAbstractList tclDoubleType= { UpdateStringOfDouble, /* updateStringProc */ SetDoubleFromAny, /* setFromAnyProc */ TCL_OBJTYPE_V0_1( - LengthOne + TclLengthOne )} }; const TclObjTypeWithAbstractList tclIntType = { @@ -254,7 +252,7 @@ const TclObjTypeWithAbstractList tclIntType = { UpdateStringOfInt, /* updateStringProc */ SetIntFromAny, /* setFromAnyProc */ TCL_OBJTYPE_V0_1( - LengthOne + TclLengthOne )} }; const TclObjTypeWithAbstractList tclBignumType = { @@ -264,7 +262,7 @@ const TclObjTypeWithAbstractList tclBignumType = { UpdateStringOfBignum, /* updateStringProc */ NULL, /* setFromAnyProc */ TCL_OBJTYPE_V0_1( - LengthOne + TclLengthOne )} }; diff --git a/generic/tclUtil.c b/generic/tclUtil.c index a53ca28..e96a564 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -122,8 +122,6 @@ static int FindElement(Tcl_Interp *interp, const char *string, * is unregistered, so has no need of a setFromAnyProc either. */ -static size_t LengthOne(TCL_UNUSED(Tcl_Obj *)) {return 1;} - static const TclObjTypeWithAbstractList endOffsetType = { {"end-offset", /* name */ NULL, /* freeIntRepProc */ @@ -131,10 +129,17 @@ static const TclObjTypeWithAbstractList endOffsetType = { NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ TCL_OBJTYPE_V0_1( - LengthOne + TclLengthOne )} }; - + +size_t +TclLengthOne( + TCL_UNUSED(Tcl_Obj *)) +{ + return 1; +} + /* * * STRING REPRESENTATION OF LISTS * * * * -- cgit v0.12 From 9dabd6f1accf6870c461a9ed5ae931aee09de1fe Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 19 Dec 2022 15:40:40 +0000 Subject: When changing the -nocomplainencoding or -strictencoding settings of a channel, reset the CHANNEL_NEED_MORE_DATA and CHANNEL_ENCODING_ERROR flags, so we can continue reading the channel and find out what's going on. --- generic/tclIO.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/generic/tclIO.c b/generic/tclIO.c index 730d963..e6e3560 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8364,6 +8364,7 @@ Tcl_SetChannelOption( } #endif } + ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA|CHANNEL_ENCODING_ERROR); return TCL_OK; } else if (HaveOpt(1, "-strictencoding")) { int newMode; @@ -8377,6 +8378,7 @@ Tcl_SetChannelOption( } else { ResetFlag(statePtr, CHANNEL_ENCODING_STRICT); } + ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA|CHANNEL_ENCODING_ERROR); return TCL_OK; } else if (HaveOpt(1, "-translation")) { const char *readMode, *writeMode; -- cgit v0.12 From 5db223f8ece1c31149d24e5ebddb1d2190aa62f6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 19 Dec 2022 15:43:22 +0000 Subject: Add two testcases, showing how we can distinguish Invalid Byte sequences, Surrogates, and Noncharacters when an exception occurred. --- tests/io.test | 78 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 78 insertions(+) diff --git a/tests/io.test b/tests/io.test index d10e1e4..eb49b44 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9201,6 +9201,84 @@ test io-75.13 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} - removeFile io-75.13 } -match glob -result {41 1 {error reading "*": illegal byte sequence}} +# Testcase for Rolf's use-case (detecting Invalid byte sequence, but allowing noncharacter) +test io-75.14 {How to use -strict, but allow non-characters} -setup { + set fn [makeFile {} io-75.14] + set f [open $fn w+] + fconfigure $f -encoding binary + # Noncharacter followed by a single + puts -nonewline $f pre\xEF\xBF\xBE\x81post + flush $f + seek $f 0 + fconfigure stdout -nocomplainencoding 1 + catch {fconfigure $f -nocomplainencoding 0};# Only needed on Tcl 9 + fconfigure $f -encoding utf-8 -buffering none -translation lf -strictencoding 1 +} -body { + set hd {} + catch { + while {![eof $f]} { + if {[catch { + append hd [read $f] + }]} { + fconfigure $f -nocomplainencoding 1 -strictencoding 0 + set char [read $f 1] + if {[string is unicode $char]} { + error "InvalidByteSequence" + } elseif {$char >= "\uD800" && $char < "\uE000"} { + error "Surrogate" + } else { + append hd $char + } + catch {fconfigure $f -nocomplainencoding 0};# Only needed on Tcl 9 + fconfigure $f -strictencoding 1 -encoding utf-8 + } + } + } msg + close $f + append hd +$msg +} -cleanup { + removeFile io-75.14 +} -result "pre\uFFFE+InvalidByteSequence" + +# Testcase for Rolf's use-case (detecting Surrogate, but allowing noncharacter) +test io-75.15 {How to use -strict, but allow non-characters} -setup { + set fn [makeFile {} io-75.14] + set f [open $fn w+] + fconfigure $f -encoding utf-8 -nocomplainencoding 1 + # Noncharacter followed by a single + puts -nonewline $f pre\uFFFE\uD800post + flush $f + seek $f 0 + fconfigure stdout -nocomplainencoding 1 + catch {fconfigure $f -nocomplainencoding 0};# Only needed on Tcl 9 + fconfigure $f -buffering none -translation lf -strictencoding 1 +} -body { + set hd {} + catch { + while {![eof $f]} { + if {[catch { + append hd [read $f] + }]} { + fconfigure $f -nocomplainencoding 1 -strictencoding 0 + set char [read $f 1] + if {[string is unicode $char]} { + error "Invalid Byte Sequence" + } elseif {$char >= "\uD800" && $char < "\uE000"} { + error "Surrogate" + } else { + append hd $char + } + catch {fconfigure $f -nocomplainencoding 0};# Only needed on Tcl 9 + fconfigure $f -strictencoding 1 + } + } + } msg + close $f + append hd +$msg +} -cleanup { + removeFile io-75.15 +} -result "pre\uFFFE+Surrogate" + # ### ### ### ######### ######### ######### -- cgit v0.12 From af98d8fa201c3de5ef583d20e6eacb2d556c15bd Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 19 Dec 2022 22:19:59 +0000 Subject: Remove all checks for noncharacters --- generic/tclEncoding.c | 11 +++++------ tests/encoding.test | 8 ++++---- 2 files changed, 9 insertions(+), 10 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index f81b0eb..d10d9ca 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2468,13 +2468,12 @@ UtfToUtfProc( src += len; dst += Tcl_UniCharToUtf(ch, dst); ch = low; - } else if (STOPONERROR && !(flags & TCL_ENCODING_MODIFIED) && !Tcl_UniCharIsUnicode(ch) - && (((ch & ~0x7FF) == 0xD800) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT))) { + } else if (STOPONERROR && !(flags & TCL_ENCODING_MODIFIED) && (((ch & ~0x7FF) == 0xD800))) { result = TCL_CONVERT_UNKNOWN; src = saveSrc; break; } else if (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) - && (flags & TCL_ENCODING_MODIFIED) && !Tcl_UniCharIsUnicode(ch)) { + && (flags & TCL_ENCODING_MODIFIED) && ((ch & ~0x7FF) == 0xD800)) { result = TCL_CONVERT_SYNTAX; src = saveSrc; break; @@ -2566,7 +2565,7 @@ Utf32ToUtfProc( ch = (src[0] & 0xFF) << 24 | (src[1] & 0xFF) << 16 | (src[2] & 0xFF) << 8 | (src[3] & 0xFF); } if ((unsigned)ch > 0x10FFFF || (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) - && !Tcl_UniCharIsUnicode(ch))) { + && ((ch & ~0x7FF) == 0xD800))) { if (STOPONERROR) { result = TCL_CONVERT_SYNTAX; break; @@ -2662,7 +2661,7 @@ UtfToUtf32Proc( break; } len = TclUtfToUCS4(src, &ch); - if (!Tcl_UniCharIsUnicode(ch) && (((ch & ~0x7FF) == 0xD800) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT))) { + if ((ch & ~0x7FF) == 0xD800) { if (STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; @@ -2864,7 +2863,7 @@ UtfToUtf16Proc( break; } len = TclUtfToUCS4(src, &ch); - if (!Tcl_UniCharIsUnicode(ch) && (((ch & ~0x7FF) == 0xD800) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT))) { + if ((ch & ~0x7FF) == 0xD800) { if (STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; diff --git a/tests/encoding.test b/tests/encoding.test index 19c7cca..5fd4e8c 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -703,18 +703,18 @@ test encoding-24.28 {Parse invalid utf-8 with -strict} -body { test encoding-24.29 {Parse invalid utf-8} -body { encoding convertfrom utf-8 \xEF\xBF\xBF } -result \uFFFF -test encoding-24.30 {Parse invalid utf-8 with -strict} -body { +test encoding-24.30 {Parse noncharacter with -strict} -body { encoding convertfrom -strict utf-8 \xEF\xBF\xBF -} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xEF'} +} -result \uFFFF test encoding-24.31 {Parse invalid utf-8 with -nocomplain} -body { encoding convertfrom -nocomplain utf-8 \xEF\xBF\xBF } -result \uFFFF test encoding-24.32 {Try to generate invalid utf-8} -body { encoding convertto utf-8 \uFFFF } -result \xEF\xBF\xBF -test encoding-24.33 {Try to generate invalid utf-8 with -strict} -body { +test encoding-24.33 {Try to generate noncharacter with -strict} -body { encoding convertto -strict utf-8 \uFFFF -} -returnCodes 1 -result {unexpected character at index 0: 'U+00FFFF'} +} -result \xEF\xBF\xBF test encoding-24.34 {Try to generate invalid utf-8 with -nocomplain} -body { encoding convertto -nocomplain utf-8 \uFFFF } -result \xEF\xBF\xBF -- cgit v0.12 From e872538a2e315cffa0f5279b3044f904029f14c0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 21 Dec 2022 13:15:54 +0000 Subject: Tweaks to dde and registry extension, so they "load" without 3th argument in Tcl 8.6 too. --- win/tclWinDde.c | 16 ++++++++++++++++ win/tclWinReg.c | 2 +- 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/win/tclWinDde.c b/win/tclWinDde.c index e232471..fb2be99 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -171,6 +171,14 @@ Dde_Init( Tcl_CreateExitHandler(DdeExitProc, NULL); return Tcl_PkgProvideEx(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION, NULL); } +#if TCL_MAJOR_VERSION < 9 +int +Tcldde_Init( + Tcl_Interp *interp) +{ + return Dde_Init(interp); +} +#endif /* *---------------------------------------------------------------------- @@ -198,6 +206,14 @@ Dde_SafeInit( } return result; } +#if TCL_MAJOR_VERSION < 9 +int +Tcldde_SafeInit( + Tcl_Interp *interp) +{ + return Dde_SafeInit(interp); +} +#endif /* *---------------------------------------------------------------------- diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 6fafead..f9481be 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -144,7 +144,7 @@ DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags); #if TCL_MAJOR_VERSION < 9 /* With those additional entries, "load registry13.dll" works without 3th argument */ DLLEXPORT int Tclregistry_Init(Tcl_Interp *interp); -DLLEXPORT int Tclregistry_SafeInit(Tcl_Interp *interp); +DLLEXPORT int Tclregistry_Unload(Tcl_Interp *interp, int flags); #endif #ifdef __cplusplus } -- cgit v0.12 From a01390fa0bb4b8455b38528cb895b70ed49cd75b Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 21 Dec 2022 20:43:53 +0000 Subject: Add 'interp' argument to some arith functions, for better error-handling --- generic/tclArithSeries.c | 210 +++++++++++++++++++++++------------------------ generic/tclArithSeries.h | 6 +- generic/tclCmdAH.c | 3 +- generic/tclCmdIL.c | 7 +- generic/tclExecute.c | 8 +- generic/tclListObj.c | 5 +- 6 files changed, 118 insertions(+), 121 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index b278644..6c52469 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -41,7 +41,8 @@ static void DupArithSeriesInternalRep (Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeArithSeriesInternalRep (Tcl_Obj *listPtr); static int SetArithSeriesFromAny (Tcl_Interp *interp, Tcl_Obj *objPtr); -static void UpdateStringOfArithSeries (Tcl_Obj *listPtr); +static void UpdateStringOfArithSeries (Tcl_Obj *arithSeriesObj); +static Tcl_Obj *ArithSeriesObjStep(Tcl_Obj *arithSeriesPtr); /* * The structure below defines the arithmetic series Tcl object type by @@ -64,7 +65,7 @@ static void UpdateStringOfArithSeries (Tcl_Obj *listPtr); * And where the equivalent's list I-th element is calculated * as: * - * LIST[i] = START+(STEP*i) + * LIST[i] = START + (STEP * i) * * Zero elements ranges, like in the case of START=10 END=10 STEP=1 * are valid and will be equivalent to the empty list. @@ -135,13 +136,13 @@ Tcl_Obj * TclNewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len) { Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step)); - Tcl_Obj *arithSeriesPtr; + Tcl_Obj *arithSeriesObj; ArithSeries *arithSeriesRepPtr; - TclNewObj(arithSeriesPtr); + TclNewObj(arithSeriesObj); if (length <= 0) { - return arithSeriesPtr; + return arithSeriesObj; } arithSeriesRepPtr = (ArithSeries*) ckalloc(sizeof (ArithSeries)); @@ -151,13 +152,13 @@ TclNewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_W arithSeriesRepPtr->step = step; arithSeriesRepPtr->len = length; arithSeriesRepPtr->elements = NULL; - arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; - arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL; - arithSeriesPtr->typePtr = &tclArithSeriesType; + arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; + arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL; + arithSeriesObj->typePtr = &tclArithSeriesType; if (length > 0) - Tcl_InvalidateStringRep(arithSeriesPtr); + Tcl_InvalidateStringRep(arithSeriesObj); - return arithSeriesPtr; + return arithSeriesObj; } /* @@ -182,13 +183,13 @@ Tcl_Obj * TclNewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) { Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step)); - Tcl_Obj *arithSeriesPtr; + Tcl_Obj *arithSeriesObj; ArithSeriesDbl *arithSeriesRepPtr; - TclNewObj(arithSeriesPtr); + TclNewObj(arithSeriesObj); if (length <= 0) { - return arithSeriesPtr; + return arithSeriesObj; } arithSeriesRepPtr = (ArithSeriesDbl*) ckalloc(sizeof (ArithSeriesDbl)); @@ -198,13 +199,13 @@ TclNewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) arithSeriesRepPtr->step = step; arithSeriesRepPtr->len = length; arithSeriesRepPtr->elements = NULL; - arithSeriesPtr->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; - arithSeriesPtr->internalRep.twoPtrValue.ptr2 = NULL; - arithSeriesPtr->typePtr = &tclArithSeriesType; + arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; + arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL; + arithSeriesObj->typePtr = &tclArithSeriesType; if (length > 0) - Tcl_InvalidateStringRep(arithSeriesPtr); + Tcl_InvalidateStringRep(arithSeriesObj); - return arithSeriesPtr; + return arithSeriesObj; } /* @@ -227,7 +228,11 @@ TclNewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) *---------------------------------------------------------------------- */ static void -assignNumber(int useDoubles, Tcl_WideInt *intNumberPtr, double *dblNumberPtr, Tcl_Obj *numberObj) +assignNumber( + int useDoubles, + Tcl_WideInt *intNumberPtr, + double *dblNumberPtr, + Tcl_Obj *numberObj) { void *clientData; int tcl_number_type; @@ -270,6 +275,7 @@ assignNumber(int useDoubles, Tcl_WideInt *intNumberPtr, double *dblNumberPtr, Tc * None. *---------------------------------------------------------------------- */ + int TclNewArithSeriesObj( Tcl_Interp *interp, /* For error reporting */ @@ -360,7 +366,7 @@ TclNewArithSeriesObj( /* *---------------------------------------------------------------------- * - * TclArithSeriesObjStep -- + * ArithSeriesObjStep -- * * Return a Tcl_Obj with the step value from the give ArithSeries Obj. * refcount = 0. @@ -375,26 +381,23 @@ TclNewArithSeriesObj( * None. *---------------------------------------------------------------------- */ -/* - * TclArithSeriesObjStep -- - */ -int -TclArithSeriesObjStep( - Tcl_Obj *arithSeriesPtr, - Tcl_Obj **stepObj) +Tcl_Obj * +ArithSeriesObjStep( + Tcl_Obj *arithSeriesObj) { ArithSeries *arithSeriesRepPtr; + Tcl_Obj *stepObj; - if (arithSeriesPtr->typePtr != &tclArithSeriesType) { - Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); + if (arithSeriesObj->typePtr != &tclArithSeriesType) { + Tcl_Panic("ArithSeriesObjStep called with a not ArithSeries Obj."); } - arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesPtr); + arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesObj); if (arithSeriesRepPtr->isDouble) { - TclNewDoubleObj(*stepObj, ((ArithSeriesDbl*)(arithSeriesRepPtr))->step); + TclNewDoubleObj(stepObj, ((ArithSeriesDbl*)(arithSeriesRepPtr))->step); } else { - TclNewIntObj(*stepObj, arithSeriesRepPtr->step); + TclNewIntObj(stepObj, arithSeriesRepPtr->step); } - return TCL_OK; + return stepObj; } @@ -405,13 +408,11 @@ TclArithSeriesObjStep( * * Returns the element with the specified index in the list * represented by the specified Arithmetic Sequence object. - * If the index is out of range, TCL_ERROR is returned, - * otherwise TCL_OK is returned and the integer value of the - * element is stored in *element. + * If the index is out of range, NULL is returned. * * Results: * - * TCL_OK on success, TCL_ERROR on index out of range. + * The element on success, NULL on index out of range. * * Side Effects: * @@ -420,27 +421,35 @@ TclArithSeriesObjStep( *---------------------------------------------------------------------- */ -int -TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **elementObj) +Tcl_Obj * +TclArithSeriesObjIndex( + Tcl_Interp *interp, + Tcl_Obj *arithSeriesObj, + Tcl_Size index) { ArithSeries *arithSeriesRepPtr; - if (arithSeriesPtr->typePtr != &tclArithSeriesType) { + if (arithSeriesObj->typePtr != &tclArithSeriesType) { Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); } - arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesPtr); + arithSeriesRepPtr = ArithSeriesRepPtr(arithSeriesObj); if (index < 0 || index >= arithSeriesRepPtr->len) { - return TCL_ERROR; + if (interp) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("index %d is out of bounds 0 to %" + "d", index, (arithSeriesRepPtr->len-1))); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; } /* List[i] = Start + (Step * index) */ if (arithSeriesRepPtr->isDouble) { - *elementObj = Tcl_NewDoubleObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); + return Tcl_NewDoubleObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); } else { - *elementObj = Tcl_NewWideIntObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); + return Tcl_NewWideIntObj(ArithSeriesIndexM(arithSeriesRepPtr, index)); } - return TCL_OK; } - + /* *---------------------------------------------------------------------- * @@ -458,10 +467,10 @@ TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, Tcl_WideInt index, Tcl_Obj **ele * *---------------------------------------------------------------------- */ -Tcl_Size TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr) +Tcl_Size TclArithSeriesObjLength(Tcl_Obj *arithSeriesObj) { ArithSeries *arithSeriesRepPtr = (ArithSeries*) - arithSeriesPtr->internalRep.twoPtrValue.ptr1; + arithSeriesObj->internalRep.twoPtrValue.ptr1; return arithSeriesRepPtr->len; } @@ -477,17 +486,17 @@ Tcl_Size TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr) * None. * * Side effects: - * Frees arithSeriesPtr's ArithSeries* internal representation and + * Frees arithSeriesObj's ArithSeries* internal representation and * sets listPtr's internalRep.twoPtrValue.ptr1 to NULL. * *---------------------------------------------------------------------- */ static void -FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesPtr) +FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObj) { ArithSeries *arithSeriesRepPtr = - (ArithSeries *) arithSeriesPtr->internalRep.twoPtrValue.ptr1; + (ArithSeries *) arithSeriesObj->internalRep.twoPtrValue.ptr1; if (arithSeriesRepPtr->elements) { Tcl_WideInt i; Tcl_Obj**elmts = arithSeriesRepPtr->elements; @@ -499,7 +508,7 @@ FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesPtr) ckfree((char *) arithSeriesRepPtr->elements); } ckfree((char *) arithSeriesRepPtr); - arithSeriesPtr->internalRep.twoPtrValue.ptr1 = NULL; + arithSeriesObj->internalRep.twoPtrValue.ptr1 = NULL; } /* @@ -568,10 +577,10 @@ DupArithSeriesInternalRep( */ static void -UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr) +UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObj) { ArithSeries *arithSeriesRepPtr = - (ArithSeries*) arithSeriesPtr->internalRep.twoPtrValue.ptr1; + (ArithSeries*) arithSeriesObj->internalRep.twoPtrValue.ptr1; char *elem, *p; Tcl_Obj *elemObj; Tcl_WideInt i; @@ -582,7 +591,7 @@ UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr) * Pass 1: estimate space. */ for (i = 0; i < arithSeriesRepPtr->len; i++) { - TclArithSeriesObjIndex(arithSeriesPtr, i, &elemObj); + elemObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, i); elem = TclGetStringFromObj(elemObj, &slen); Tcl_DecrRefCount(elemObj); slen += 1; /* + 1 is for the space or the nul-term */ @@ -593,17 +602,17 @@ UpdateStringOfArithSeries(Tcl_Obj *arithSeriesPtr) * Pass 2: generate the string repr. */ - p = Tcl_InitStringRep(arithSeriesPtr, NULL, length); + p = Tcl_InitStringRep(arithSeriesObj, NULL, length); for (i = 0; i < arithSeriesRepPtr->len; i++) { - TclArithSeriesObjIndex(arithSeriesPtr, i, &elemObj); + elemObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, i); elem = TclGetStringFromObj(elemObj, &slen); strcpy(p, elem); p[slen] = ' '; p += slen+1; Tcl_DecrRefCount(elemObj); } - if (length > 0) arithSeriesPtr->bytes[length-1] = '\0'; - arithSeriesPtr->length = length-1; + if (length > 0) arithSeriesObj->bytes[length-1] = '\0'; + arithSeriesObj->length = length-1; } /* @@ -649,8 +658,8 @@ SetArithSeriesFromAny( * Results: * * Normally returns a pointer to a new Tcl_Obj, that contains the same - * arithSeries value as *arithSeriesPtr does. The returned Tcl_Obj has a - * refCount of zero. If *arithSeriesPtr does not hold an arithSeries, + * arithSeries value as *arithSeriesObj does. The returned Tcl_Obj has a + * refCount of zero. If *arithSeriesObj does not hold an arithSeries, * NULL is returned, and if interp is non-NULL, an error message is * recorded there. * @@ -663,15 +672,15 @@ SetArithSeriesFromAny( Tcl_Obj * TclArithSeriesObjCopy( Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *arithSeriesPtr) /* List object for which an element array is + Tcl_Obj *arithSeriesObj) /* List object for which an element array is * to be returned. */ { Tcl_Obj *copyPtr; ArithSeries *arithSeriesRepPtr; - ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); + ArithSeriesGetInternalRep(arithSeriesObj, arithSeriesRepPtr); if (NULL == arithSeriesRepPtr) { - if (SetArithSeriesFromAny(interp, arithSeriesPtr) != TCL_OK) { + if (SetArithSeriesFromAny(interp, arithSeriesObj) != TCL_OK) { /* We know this is going to panic, but it's the message we want */ return NULL; } @@ -679,7 +688,7 @@ TclArithSeriesObjCopy( TclNewObj(copyPtr); TclInvalidateStringRep(copyPtr); - DupArithSeriesInternalRep(arithSeriesPtr, copyPtr); + DupArithSeriesInternalRep(arithSeriesObj, copyPtr); return copyPtr; } @@ -689,7 +698,7 @@ TclArithSeriesObjCopy( * TclArithSeriesObjRange -- * * Makes a slice of an ArithSeries value. - * *arithSeriesPtr must be known to be a valid list. + * *arithSeriesObj must be known to be a valid list. * * Results: * Returns a pointer to the sliced series. @@ -705,14 +714,14 @@ TclArithSeriesObjCopy( Tcl_Obj * TclArithSeriesObjRange( Tcl_Interp *interp, /* For error message(s) */ - Tcl_Obj *arithSeriesPtr, /* List object to take a range from. */ - int fromIdx, /* Index of first element to include. */ - int toIdx) /* Index of last element to include. */ + Tcl_Obj *arithSeriesObj, /* List object to take a range from. */ + Tcl_Size fromIdx, /* Index of first element to include. */ + Tcl_Size toIdx) /* Index of last element to include. */ { ArithSeries *arithSeriesRepPtr; Tcl_Obj *startObj, *endObj, *stepObj; - ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); + ArithSeriesGetInternalRep(arithSeriesObj, arithSeriesRepPtr); if (fromIdx < 0) { fromIdx = 0; @@ -723,31 +732,21 @@ TclArithSeriesObjRange( return obj; } - if (TclArithSeriesObjIndex(arithSeriesPtr, fromIdx, &startObj) != TCL_OK) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("index %d is out of bounds 0 to %" - "d", fromIdx, (arithSeriesRepPtr->len-1))); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } + startObj = TclArithSeriesObjIndex(interp, arithSeriesObj, fromIdx); + if (startObj == NULL) { return NULL; } Tcl_IncrRefCount(startObj); - if (TclArithSeriesObjIndex(arithSeriesPtr, toIdx, &endObj) != TCL_OK) { - if (interp) { - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("index %d is out of bounds 0 to %" - "d", fromIdx, (arithSeriesRepPtr->len-1))); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } + endObj = TclArithSeriesObjIndex(interp, arithSeriesObj, toIdx); + if (endObj == NULL) { return NULL; } Tcl_IncrRefCount(endObj); - TclArithSeriesObjStep(arithSeriesPtr, &stepObj); + stepObj = ArithSeriesObjStep(arithSeriesObj); Tcl_IncrRefCount(stepObj); - if (Tcl_IsShared(arithSeriesPtr) || - ((arithSeriesPtr->refCount > 1))) { + if (Tcl_IsShared(arithSeriesObj) || + ((arithSeriesObj->refCount > 1))) { Tcl_Obj *newSlicePtr; if (TclNewArithSeriesObj(interp, &newSlicePtr, arithSeriesRepPtr->isDouble, startObj, endObj, @@ -769,10 +768,10 @@ TclArithSeriesObjRange( * string-canonizing effect of [lrange 0 end]. */ - TclInvalidateStringRep(arithSeriesPtr); + TclInvalidateStringRep(arithSeriesObj); if (arithSeriesRepPtr->isDouble) { - ArithSeriesDbl *arithSeriesDblRepPtr = (ArithSeriesDbl*)arithSeriesPtr; + ArithSeriesDbl *arithSeriesDblRepPtr = (ArithSeriesDbl*)arithSeriesObj; double start, end, step; Tcl_GetDoubleFromObj(NULL, startObj, &start); Tcl_GetDoubleFromObj(NULL, endObj, &end); @@ -799,7 +798,7 @@ TclArithSeriesObjRange( Tcl_DecrRefCount(endObj); Tcl_DecrRefCount(stepObj); - return arithSeriesPtr; + return arithSeriesObj; } /* @@ -834,7 +833,7 @@ TclArithSeriesObjRange( int TclArithSeriesGetElements( Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *objPtr, /* AbstractList object for which an element + Tcl_Obj *objPtr, /* ArithSeries object for which an element * array is to be returned. */ Tcl_Size *objcPtr, /* Where to store the count of objects * referenced by objv. */ @@ -866,13 +865,8 @@ TclArithSeriesGetElements( } arithSeriesRepPtr->elements = objv; for (i = 0; i < objc; i++) { - if (TclArithSeriesObjIndex(objPtr, i, &objv[i]) != TCL_OK) { - if (interp) { - Tcl_SetObjResult( - interp, - Tcl_NewStringObj("indexing error", -1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - } + objv[i] = TclArithSeriesObjIndex(interp, objPtr, i); + if (objv[i] == NULL) { return TCL_ERROR; } Tcl_IncrRefCount(objv[i]); @@ -901,7 +895,7 @@ TclArithSeriesGetElements( * TclArithSeriesObjReverse -- * * Reverse the order of the ArithSeries value. - * *arithSeriesPtr must be known to be a valid list. + * *arithSeriesObj must be known to be a valid list. * * Results: * Returns a pointer to the reordered series. @@ -917,7 +911,7 @@ TclArithSeriesGetElements( Tcl_Obj * TclArithSeriesObjReverse( Tcl_Interp *interp, /* For error message(s) */ - Tcl_Obj *arithSeriesPtr) /* List object to reverse. */ + Tcl_Obj *arithSeriesObj) /* List object to reverse. */ { ArithSeries *arithSeriesRepPtr; Tcl_Obj *startObj, *endObj, *stepObj; @@ -926,16 +920,16 @@ TclArithSeriesObjReverse( double dstart, dend, dstep; int isDouble; - ArithSeriesGetInternalRep(arithSeriesPtr, arithSeriesRepPtr); + ArithSeriesGetInternalRep(arithSeriesObj, arithSeriesRepPtr); isDouble = arithSeriesRepPtr->isDouble; len = arithSeriesRepPtr->len; - TclArithSeriesObjIndex(arithSeriesPtr, (len-1), &startObj); + startObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, (len-1)); Tcl_IncrRefCount(startObj); - TclArithSeriesObjIndex(arithSeriesPtr, 0, &endObj); + endObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, 0); Tcl_IncrRefCount(endObj); - TclArithSeriesObjStep(arithSeriesPtr, &stepObj); + stepObj = ArithSeriesObjStep(arithSeriesObj); Tcl_IncrRefCount(stepObj); if (isDouble) { @@ -952,8 +946,8 @@ TclArithSeriesObjReverse( TclSetIntObj(stepObj, step); } - if (Tcl_IsShared(arithSeriesPtr) || - ((arithSeriesPtr->refCount > 1))) { + if (Tcl_IsShared(arithSeriesObj) || + ((arithSeriesObj->refCount > 1))) { Tcl_Obj *lenObj; TclNewIntObj(lenObj, len); if (TclNewArithSeriesObj(interp, &resultObj, @@ -967,7 +961,7 @@ TclArithSeriesObjReverse( * In-place is possible. */ - TclInvalidateStringRep(arithSeriesPtr); + TclInvalidateStringRep(arithSeriesObj); if (isDouble) { ArithSeriesDbl *arithSeriesDblRepPtr = @@ -989,7 +983,7 @@ TclArithSeriesObjReverse( } arithSeriesRepPtr->elements = NULL; - resultObj = arithSeriesPtr; + resultObj = arithSeriesObj; } Tcl_DecrRefCount(startObj); diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h index 28fd993..af770a9 100644 --- a/generic/tclArithSeries.h +++ b/generic/tclArithSeries.h @@ -35,10 +35,8 @@ typedef struct { MODULE_SCOPE Tcl_Obj * TclArithSeriesObjCopy(Tcl_Interp *interp, Tcl_Obj *arithSeriesPtr); -MODULE_SCOPE int TclArithSeriesObjStep(Tcl_Obj *arithSeriesPtr, - Tcl_Obj **stepObj); -MODULE_SCOPE int TclArithSeriesObjIndex(Tcl_Obj *arithSeriesPtr, - Tcl_WideInt index, Tcl_Obj **elementObj); +MODULE_SCOPE Tcl_Obj *TclArithSeriesObjIndex(Tcl_Interp *, Tcl_Obj *, + Tcl_Size index); MODULE_SCOPE Tcl_Size TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Interp *interp, Tcl_Obj *arithSeriesPtr, Tcl_Size fromIdx, Tcl_Size toIdx); diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 2281b5a..b4084d1 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -3022,7 +3022,8 @@ ForeachAssignments( k = statePtr->index[i]++; if (k < statePtr->argcList[i]) { if (isarithseries) { - if (TclArithSeriesObjIndex(statePtr->aCopyList[i], k, &valuePtr) != TCL_OK) { + valuePtr = TclArithSeriesObjIndex(interp, statePtr->aCopyList[i], k); + if (valuePtr == NULL) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (setting %s loop variable \"%s\")", (statePtr->resultList != NULL ? "lmap" : "foreach"), diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 8e52d65..1838f7f 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -2232,8 +2232,8 @@ Tcl_JoinObjCmd( if (listLen == 1) { /* One element; return it */ if (isArithSeries) { - Tcl_Obj *valueObj; - if (TclArithSeriesObjIndex(objv[1], 0, &valueObj) != TCL_OK) { + Tcl_Obj *valueObj = TclArithSeriesObjIndex(interp, objv[1], 0); + if (valueObj == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, valueObj); @@ -2267,7 +2267,8 @@ Tcl_JoinObjCmd( Tcl_AppendObjToObj(resObjPtr, joinObjPtr); } - if (TclArithSeriesObjIndex(objv[1], i, &valueObj) != TCL_OK) { + valueObj = TclArithSeriesObjIndex(interp, objv[1], i); + if (valueObj == NULL) { return TCL_ERROR; } Tcl_AppendObjToObj(resObjPtr, valueObj); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index a8d9d57..ec144a2 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4876,7 +4876,8 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - if (TclArithSeriesObjIndex(valuePtr, index, &objResultPtr) != TCL_OK) { + objResultPtr = TclArithSeriesObjIndex(interp, valuePtr, index); + if (objResultPtr == NULL) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; @@ -4941,7 +4942,8 @@ TEBCresume( /* Compute value @ index */ if (index >= 0 && index < length) { - if (TclArithSeriesObjIndex(valuePtr, index, &objResultPtr) != TCL_OK) { + objResultPtr = TclArithSeriesObjIndex(interp, valuePtr, index); + if (objResultPtr == NULL) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; @@ -5187,7 +5189,7 @@ TEBCresume( do { if (isArithSeries) { - TclArithSeriesObjIndex(value2Ptr, i, &o); + o = TclArithSeriesObjIndex(NULL, value2Ptr, i); } else { Tcl_ListObjIndex(NULL, value2Ptr, i, &o); } diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 80477f7..3f17e90 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -2640,7 +2640,7 @@ TclLindexFlat( &index) == TCL_OK) { } if (i==0) { - TclArithSeriesObjIndex(listObj, index, &elemObj); + elemObj = TclArithSeriesObjIndex(NULL, listObj, index); } else if (index > 0) { /* ArithSeries cannot be a list of lists */ Tcl_DecrRefCount(elemObj); @@ -3301,7 +3301,8 @@ SetListFromAny( listRep.storePtr->numUsed = size; elemPtrs = listRep.storePtr->slots; for (j = 0; j < size; j++) { - if (TclArithSeriesObjIndex(objPtr, j, &elemPtrs[j]) != TCL_OK) { + elemPtrs[j] = TclArithSeriesObjIndex(interp, objPtr, j); + if (elemPtrs[j] == NULL) { return TCL_ERROR; } } -- cgit v0.12 From ecaf98ffad23b0a547d0cedb852e0186d5c0c0af Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 21 Dec 2022 21:07:33 +0000 Subject: Make two more functions static --- generic/tclArithSeries.c | 14 ++++++++------ generic/tclArithSeries.h | 5 ----- 2 files changed, 8 insertions(+), 11 deletions(-) diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index 6c52469..0419841 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -117,7 +117,7 @@ ArithSeriesLen(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step) /* *---------------------------------------------------------------------- * - * TclNewArithSeriesInt -- + * NewArithSeriesInt -- * * Creates a new ArithSeries object. The returned object has * refcount = 0. @@ -132,8 +132,9 @@ ArithSeriesLen(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step) * None. *---------------------------------------------------------------------- */ +static Tcl_Obj * -TclNewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len) +NewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len) { Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step)); Tcl_Obj *arithSeriesObj; @@ -164,7 +165,7 @@ TclNewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_W /* *---------------------------------------------------------------------- * - * TclNewArithSeriesDbl -- + * NewArithSeriesDbl -- * * Creates a new ArithSeries object with doubles. The returned object has * refcount = 0. @@ -179,8 +180,9 @@ TclNewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_W * None. *---------------------------------------------------------------------- */ +static Tcl_Obj * -TclNewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) +NewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) { Tcl_WideInt length = (len>=0 ? len : ArithSeriesLen(start, end, step)); Tcl_Obj *arithSeriesObj; @@ -357,8 +359,8 @@ TclNewArithSeriesObj( if (arithSeriesObj) { *arithSeriesObj = (useDoubles) - ? TclNewArithSeriesDbl(dstart, dend, dstep, len) - : TclNewArithSeriesInt(start, end, step, len); + ? NewArithSeriesDbl(dstart, dend, dstep, len) + : NewArithSeriesInt(start, end, step, len); } return TCL_OK; } diff --git a/generic/tclArithSeries.h b/generic/tclArithSeries.h index af770a9..947d437 100644 --- a/generic/tclArithSeries.h +++ b/generic/tclArithSeries.h @@ -44,11 +44,6 @@ MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Interp *interp, Tcl_Obj *arithSeriesPtr); MODULE_SCOPE int TclArithSeriesGetElements(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); -MODULE_SCOPE Tcl_Obj * TclNewArithSeriesInt(Tcl_WideInt start, - Tcl_WideInt end, Tcl_WideInt step, - Tcl_WideInt len); -MODULE_SCOPE Tcl_Obj * TclNewArithSeriesDbl(double start, double end, - double step, Tcl_WideInt len); MODULE_SCOPE int TclNewArithSeriesObj(Tcl_Interp *interp, Tcl_Obj **arithSeriesObj, int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj, -- cgit v0.12 From a1de562f5c569cc85c2d2e3cddc82970f503b2d4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 24 Dec 2022 14:36:57 +0000 Subject: First part of fix for [4a7397e0b3]: Take flags into account when deciding to do a binary fcopy or not. TODO: Handle generating an exception --- generic/tclIO.c | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index cfb97ec..98315db 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -9347,7 +9347,9 @@ TclCopyChannel( moveBytes = inStatePtr->inEofChar == '\0' /* No eofChar to stop input */ && inStatePtr->inputTranslation == TCL_TRANSLATE_LF && outStatePtr->outputTranslation == TCL_TRANSLATE_LF - && inStatePtr->encoding == outStatePtr->encoding; + && inStatePtr->encoding == outStatePtr->encoding + && (inStatePtr->flags & TCL_ENCODING_STRICT) != TCL_ENCODING_STRICT + && outStatePtr->flags & TCL_ENCODING_NOCOMPLAIN; /* * Allocate a new CopyState to maintain info about the current copy in @@ -9674,7 +9676,9 @@ CopyData( inBinary = (inStatePtr->encoding == NULL); outBinary = (outStatePtr->encoding == NULL); - sameEncoding = (inStatePtr->encoding == outStatePtr->encoding); + sameEncoding = inStatePtr->encoding == outStatePtr->encoding + && (inStatePtr->flags & TCL_ENCODING_STRICT) != TCL_ENCODING_STRICT + && outStatePtr->flags & TCL_ENCODING_NOCOMPLAIN; if (!(inBinary || sameEncoding)) { TclNewObj(bufObj); -- cgit v0.12 From 4a8b2cf10f8ebcebaa9d3546f3399d3d9a8aa00e Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 28 Dec 2022 12:07:18 +0000 Subject: A better fix for [b8f575aa23], as it maintains the expectation that synchronous [read] results in an error when invalid data is encountered. someone other than pooryorick: Pushed this check-in back on to a review branch. It needs more baking/review. As is, it makes two tests fail, and it introduces a new element "-result" to the return options dictionary. --- generic/tclIO.c | 13 +++++++++++-- generic/tclIOCmd.c | 10 +++++++++- tests/io.test | 29 ++++++++++++++++------------- 3 files changed, 36 insertions(+), 16 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index e6e3560..63b9a7d 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -6041,7 +6041,7 @@ DoReadChars( assert(statePtr->inputEncodingFlags & TCL_ENCODING_END); assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR)); - /* TODO: We don't need this call? */ + /* TODO: UpdateInterest isn't needed here? */ UpdateInterest(chanPtr); return 0; } @@ -6055,7 +6055,7 @@ DoReadChars( } ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; - /* TODO: We don't need this call? */ + /* TODO: UpdateInterest isn't needed here? */ UpdateInterest(chanPtr); return 0; } @@ -6084,6 +6084,15 @@ DoReadChars( } else { copiedNow = ReadChars(statePtr, objPtr, toRead, &factor); } + if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR) && !GotFlag(statePtr, CHANNEL_NONBLOCKING)) { + /* Channel is Synchronous. Return an error so that [read] and + * friends can return an error + */ + TclChannelRelease((Tcl_Channel)chanPtr); + UpdateInterest(chanPtr); + Tcl_SetErrno(EILSEQ); + return -1; + } /* * If the current buffer is empty recycle it. diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index e8a534f..8794365 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -381,7 +381,7 @@ Tcl_ReadObjCmd( int toRead; /* How many bytes to read? */ int charactersRead; /* How many characters were read? */ int mode; /* Mode in which channel is opened. */ - Tcl_Obj *resultPtr, *chanObjPtr; + Tcl_Obj *resultPtr, *returnOptsPtr, *chanObjPtr; if ((objc != 2) && (objc != 3)) { Interp *iPtr; @@ -470,8 +470,16 @@ Tcl_ReadObjCmd( "error reading \"%s\": %s", TclGetString(chanObjPtr), Tcl_PosixError(interp))); } + returnOptsPtr = Tcl_NewDictObj(); + Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-code", -1) + , Tcl_NewStringObj("error", -1)); + Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-level", -1) + , Tcl_NewIntObj(0)); + Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-result", -1) + , resultPtr); TclChannelRelease(chan); Tcl_DecrRefCount(resultPtr); + Tcl_SetReturnOptions(interp, returnOptsPtr); return TCL_ERROR; } diff --git a/tests/io.test b/tests/io.test index d10e1e4..451a790 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9056,12 +9056,12 @@ test io-75.6 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} -s seek $f 0 fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -strictencoding 1 } -body { - set d [read $f] + set status [catch {read $f} cres copts] + set d [dict get $copts -result] binary scan $d H* hd - lappend hd [catch {read $f} msg] - close $f - lappend hd $msg + lappend hd $status $cres } -cleanup { + close $f removeFile io-75.6 } -match glob -result {41 1 {error reading "*": illegal byte sequence}} @@ -9075,11 +9075,12 @@ test io-75.7 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { seek $f 0 fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -strictencoding 1 } -body { - set d [read $f] + set status [catch {read $f} cres copts] + set d [dict get $copts -result] binary scan $d H* hd lappend hd [eof $f] - lappend hd [catch {read $f} msg] - lappend hd $msg + lappend hd $status + lappend hd $cres fconfigure $f -encoding iso8859-1 lappend hd [read $f];# We changed encoding, so now we can read the \xA1 close $f @@ -9157,10 +9158,11 @@ test io-75.11 {shiftjis encoding error read results in raw bytes} -setup { seek $f 0 fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf -strictencoding 1 } -body { - set d [read $f] + set status [catch {read $f} cres copts] + set d [dict get $copts -result] binary scan $d H* hd - lappend hd [catch {set d [read $f]} msg] - lappend hd $msg + lappend hd $status + lappend hd $cres } -cleanup { close $f removeFile io-75.11 @@ -9192,11 +9194,12 @@ test io-75.13 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} - seek $f 0 fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -strictencoding 1 } -body { - set d [read $f] + set status [catch {read $f} cres copts] + set d [dict get $copts -result] binary scan $d H* hd - lappend hd [catch {read $f} msg] + lappend hd $status close $f - lappend hd $msg + lappend hd $cres } -cleanup { removeFile io-75.13 } -match glob -result {41 1 {error reading "*": illegal byte sequence}} -- cgit v0.12 From dbd4edc3d53208fc92252173a0714d8f6524d1a1 Mon Sep 17 00:00:00 2001 From: fvogel Date: Wed, 28 Dec 2022 20:39:17 +0000 Subject: Fix [8e811bc1f1]: Wrong formatting of arguments in man page --- tools/tcltk-man2html-utils.tcl | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl index 6e4f1fb..1e9e31e 100644 --- a/tools/tcltk-man2html-utils.tcl +++ b/tools/tcltk-man2html-utils.tcl @@ -583,6 +583,7 @@ proc output-IP-list {context code rest} { backup-text 1 set accept_RE 0 set para {} + set endpara {} while {[more-text]} { set line [next-text] if {[is-a-directive $line]} { @@ -594,7 +595,7 @@ proc output-IP-list {context code rest} { continue } if {$manual(section) eq "ARGUMENTS"} { - man-puts "$para
$rest
" + man-puts "$para
$rest
$endpara" } elseif {[regexp {^\[([\da-f]+)\]$} $rest -> value]} { man-puts "$para
  • " } elseif {[regexp {^\(?([\da-f]+)\)$} $rest -> value]} { @@ -664,6 +665,7 @@ proc output-IP-list {context code rest} { man-puts $line } set para

    + set endpara

    } man-puts "$para$enddl" lappend manual(section-toc) $enddl -- cgit v0.12 From f2cc84c99a732dbde0a6845d0809443e43276d17 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 28 Dec 2022 22:46:37 +0000 Subject: Update fix so that the two failing tests, iocmd-23.8 and iortrans-4.7 now pass. --- generic/tclIOCmd.c | 4 ---- 1 file changed, 4 deletions(-) diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 8794365..e5ba298 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -471,10 +471,6 @@ Tcl_ReadObjCmd( TclGetString(chanObjPtr), Tcl_PosixError(interp))); } returnOptsPtr = Tcl_NewDictObj(); - Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-code", -1) - , Tcl_NewStringObj("error", -1)); - Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-level", -1) - , Tcl_NewIntObj(0)); Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-result", -1) , resultPtr); TclChannelRelease(chan); -- cgit v0.12 From 23d30205a5621acc748c0c3b6ad79a21bb80e327 Mon Sep 17 00:00:00 2001 From: fvogel Date: Thu, 29 Dec 2022 17:04:43 +0000 Subject: Instead of fiddling with html tags, simply enlarge a bit the width in the CSS stylesheet. --- tools/tcltk-man2html-utils.tcl | 4 +--- tools/tcltk-man2html.tcl | 4 ++-- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl index 1e9e31e..6e4f1fb 100644 --- a/tools/tcltk-man2html-utils.tcl +++ b/tools/tcltk-man2html-utils.tcl @@ -583,7 +583,6 @@ proc output-IP-list {context code rest} { backup-text 1 set accept_RE 0 set para {} - set endpara {} while {[more-text]} { set line [next-text] if {[is-a-directive $line]} { @@ -595,7 +594,7 @@ proc output-IP-list {context code rest} { continue } if {$manual(section) eq "ARGUMENTS"} { - man-puts "$para
    $rest
    $endpara" + man-puts "$para
    $rest
    " } elseif {[regexp {^\[([\da-f]+)\]$} $rest -> value]} { man-puts "$para
  • " } elseif {[regexp {^\(?([\da-f]+)\)$} $rest -> value]} { @@ -665,7 +664,6 @@ proc output-IP-list {context code rest} { man-puts $line } set para

    - set endpara

    } man-puts "$para$enddl" lappend manual(section-toc) $enddl diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index 236a49f..caececa 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -221,14 +221,14 @@ proc css-stylesheet {} { font-size: 11px; } css-style ".keylist dt" ".arguments dt" { - width: 20em; + width: 25em; float: left; padding: 2px; border-top: 1px solid #999999; } css-style ".keylist dt" { font-weight: bold; } css-style ".keylist dd" ".arguments dd" { - margin-left: 20em; + margin-left: 25em; padding: 2px; border-top: 1px solid #999999; } -- cgit v0.12 From 3b45005127de0885251471d5591ecb58c5b3e286 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Thu, 29 Dec 2022 22:59:10 +0000 Subject: Arrange new code in DoReadChars to ensure that final steps are always taken. --- generic/tclIO.c | 28 +++++++++++++++------------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 63b9a7d..9ae8fb5 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -6024,8 +6024,9 @@ DoReadChars( } if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { - /* TODO: We don't need this call? */ + /* TODO: UpdateInterest not needed here? */ UpdateInterest(chanPtr); + Tcl_SetErrno(EILSEQ); return -1; } @@ -6041,7 +6042,7 @@ DoReadChars( assert(statePtr->inputEncodingFlags & TCL_ENCODING_END); assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR)); - /* TODO: UpdateInterest isn't needed here? */ + /* TODO: UpdateInterest not needed here? */ UpdateInterest(chanPtr); return 0; } @@ -6055,7 +6056,7 @@ DoReadChars( } ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; - /* TODO: UpdateInterest isn't needed here? */ + /* TODO: UpdateInterest not needed here? */ UpdateInterest(chanPtr); return 0; } @@ -6084,18 +6085,9 @@ DoReadChars( } else { copiedNow = ReadChars(statePtr, objPtr, toRead, &factor); } - if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR) && !GotFlag(statePtr, CHANNEL_NONBLOCKING)) { - /* Channel is Synchronous. Return an error so that [read] and - * friends can return an error - */ - TclChannelRelease((Tcl_Channel)chanPtr); - UpdateInterest(chanPtr); - Tcl_SetErrno(EILSEQ); - return -1; - } /* - * If the current buffer is empty recycle it. + * Recycle current buffer if empty. */ bufPtr = statePtr->inQueueHead; @@ -6108,6 +6100,15 @@ DoReadChars( statePtr->inQueueTail = NULL; } } + + if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR) && !GotFlag(statePtr, CHANNEL_NONBLOCKING)) { + /* Channel is synchronous. Return an error so that callers + * like [read] can return an error. + */ + Tcl_SetErrno(EILSEQ); + copied = -1; + goto finish; + } } if (copiedNow < 0) { @@ -6136,6 +6137,7 @@ DoReadChars( } } +finish: /* * Failure to fill a channel buffer may have left channel reporting a * "blocked" state, but so long as we fulfilled the request here, the -- cgit v0.12 From a801c2d4741015dbb5875938248eff1701e1ff29 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Fri, 30 Dec 2022 20:27:47 +0000 Subject: Fix DoReadChars() to correctly discard encoding errors after eofchar has been seen, and add new test, io-75.8.invalid. --- generic/tclEncoding.c | 7 ++++++- generic/tclIO.c | 16 ++++++++++++++-- tests/io.test | 36 ++++++++++++++++++++++++++++++++++-- 3 files changed, 54 insertions(+), 5 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index d10d9ca..37b3073 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2386,7 +2386,12 @@ UtfToUtfProc( *dst++ = *src++; } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) - && (UCHAR(src[1]) == 0x80) && (!(flags & TCL_ENCODING_MODIFIED) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT))) { + && (UCHAR(src[1]) == 0x80) + && ( + !(flags & TCL_ENCODING_MODIFIED) + || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) + )) + { /* * If in input mode, and -strict is specified: This is an error. */ diff --git a/generic/tclIO.c b/generic/tclIO.c index 9ae8fb5..3b47de5 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -6101,7 +6101,16 @@ DoReadChars( } } - if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR) && !GotFlag(statePtr, CHANNEL_NONBLOCKING)) { + /* + * If CHANNEL_ENCODING_ERROR and CHANNEL_STICKY_EOF are both set, + * then CHANNEL_ENCODING_ERROR was caused by data that occurred + * after the EOF character was encountered, so it doesn't count as + * a real error. + */ + + if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR) + && !GotFlag(statePtr, CHANNEL_STICKY_EOF) + && !GotFlag(statePtr, CHANNEL_NONBLOCKING)) { /* Channel is synchronous. Return an error so that callers * like [read] can return an error. */ @@ -6816,11 +6825,14 @@ TranslateInputEOL( * EOF character was seen in EOL translated range. Leave current file * position pointing at the EOF character, but don't store the EOF * character in the output string. + * + * If CHANNEL_ENCODING_ERROR is set, it can only be because of data + * encountered after the EOF character, so it is nonsense. Unset it. */ SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF); statePtr->inputEncodingFlags |= TCL_ENCODING_END; - ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR); + ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR|CHANNEL_ENCODING_ERROR); } } diff --git a/tests/io.test b/tests/io.test index 451a790..aece338 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9089,11 +9089,15 @@ test io-75.7 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { removeFile io-75.7 } -match glob -result {41 0 1 {error reading "*": illegal byte sequence} ¡} -test io-75.8 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { +test io-75.8.incomplete { + incomplete uft-8 char after eof char is not an error (-strictencoding 1) +} -setup { + set hd {} set fn [makeFile {} io-75.8] set f [open $fn w+] fconfigure $f -encoding binary - # \x81 is invalid in utf-8, but since \x1A comes first, -eofchar takes precedence. + # \x81 is invalid and also incomplete utf-8 data, but because the eof + # character \x1A appears first, it's not an error. puts -nonewline $f A\x1A\x81 flush $f seek $f 0 @@ -9102,6 +9106,7 @@ test io-75.8 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { set d [read $f] binary scan $d H* hd lappend hd [eof $f] + # there should be no error on additional reads lappend hd [read $f] close $f set hd @@ -9109,6 +9114,33 @@ test io-75.8 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { removeFile io-75.8 } -result {41 1 {}} + +test io-75.8.invalid {invalid utf-8 after eof char is not an error (-strictencoding 1)} -setup { + set res {} + set fn [makeFile {} io-75.8] + set f [open $fn w+] + fconfigure $f -encoding binary + # \xc0\x80 is invalid utf-8 data, but because the eof character \x1A + # appears first, it's not an error. + puts -nonewline $f A\x1a\xc0\x80 + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -strictencoding 1 +} -body { + set d [read $f] + foreach char [split $d {}] { + lappend res [format %x [scan $char %c]] + } + lappend res [eof $f] + # there should be no error on additional reads + lappend res [read $f] + close $f + set res +} -cleanup { + removeFile io-75.8 +} -result {41 1 {}} + + test io-75.9 {unrepresentable character write passes and is replaced by ?} -setup { set fn [makeFile {} io-75.9] set f [open $fn w+] -- cgit v0.12 From 63e04b3c2dc7ecaf014a93f2116b5913a256e875 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Fri, 30 Dec 2022 21:05:56 +0000 Subject: New test, io-12.9.strict, for issue report [1bedc53c8cb878f0]. --- tests/io.test | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/tests/io.test b/tests/io.test index aece338..6fb3587 100644 --- a/tests/io.test +++ b/tests/io.test @@ -1555,11 +1555,29 @@ test io-12.9 {ReadChars: multibyte chars split} -body { set f [open $path(test1)] fconfigure $f -encoding utf-8 -buffersize 10 set in [read $f] + read $f close $f scan [string index $in end] %c } -cleanup { catch {close $f} } -result 194 +test io-12.9.strict {ReadChars: multibyte chars split} -body { + set res {} + set f [open $path(test1) w] + fconfigure $f -translation binary + puts -nonewline $f [string repeat a 9]\xC2 + close $f + set f [open $path(test1)] + fconfigure $f -encoding utf-8 -strictencoding 1 -buffersize 10 + set status [catch {read $f} cres copts] + set in [dict get $copts -result] + lappend res $in + lappend res $status $cres + set res +} -cleanup { + close $f + catch {close $f} +} -match glob -result {aaaaaaaaa 1 {error reading "*": illegal byte sequence}} test io-12.10 {ReadChars: multibyte chars split} -body { set f [open $path(test1) w] fconfigure $f -translation binary -- cgit v0.12 From 3919b0a0b4e371b574d16adaa1c73df6da8007ce Mon Sep 17 00:00:00 2001 From: pooryorick Date: Fri, 30 Dec 2022 21:53:47 +0000 Subject: Add test for [gets] in non-strict mode after an encoding error. --- tests/io.test | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/tests/io.test b/tests/io.test index 6fb3587..2fa06ea 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9254,6 +9254,28 @@ test io-75.13 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} - removeFile io-75.13 } -match glob -result {41 1 {error reading "*": illegal byte sequence}} +test io-75.14 {invalid utf-8 encoding [gets] coninues in non-strict mode after error} -setup { + set fn [makeFile {} io-75.14] + set f [open $fn w+] + fconfigure $f -encoding binary + # \xc0 is invalid in utf-8 + puts -nonewline $f a\nb\xc0\nc\n + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf -strictencoding 1 +} -body { + lappend res [gets $f] + set status [catch {gets $f} cres copts] + lappend res $status $cres + chan configure $f -strictencoding 0 + lappend res [gets $f] + lappend res [gets $f] + close $f + return $res +} -cleanup { + removeFile io-75.14 +} -match glob -result {a 1 {error reading "*": illegal byte sequence} bÀ c} + # ### ### ### ######### ######### ######### -- cgit v0.12 From 985ea00b16865c0dccc99eb9b006f97e8e59edb0 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 2 Jan 2023 23:12:02 +0000 Subject: Merge py-b8f575aa23: Fix for [154ed7ce56], Tcl 9: [gets] on -strictencoding 1 configured channel. --- generic/tclIO.c | 28 ++++++++++++++++++++++++++-- generic/tclIOCmd.c | 7 +++++-- tests/io.test | 32 ++++++++++++++++++++++++++++++-- 3 files changed, 61 insertions(+), 6 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 3b47de5..81af96e 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4656,7 +4656,8 @@ Tcl_GetsObj( /* State info for channel */ ChannelBuffer *bufPtr; int inEofChar, skip, copiedTotal, oldFlags, oldRemoved; - int oldLength; + int reportError = 0; + size_t oldLength; Tcl_Encoding encoding; char *dst, *dstEnd, *eol, *eof; Tcl_EncodingState oldState; @@ -4664,6 +4665,7 @@ Tcl_GetsObj( if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { UpdateInterest(chanPtr); Tcl_SetErrno(EILSEQ); + ResetFlag(statePtr, CHANNEL_ENCODING_ERROR); return TCL_INDEX_NONE; } @@ -4938,6 +4940,19 @@ Tcl_GetsObj( goto done; } goto gotEOL; + } else if (gs.bytesWrote == 0 + && GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { + /* Set eol to the position that caused the encoding error, and then + * coninue to gotEOL, which stores the data that was decoded + * without error to objPtr. This allows the caller to do something + * useful with the data decoded so far, and also results in the + * position of the file being the first byte that was not + * succesfully decoded, allowing further processing at exactly that + * point, if desired. + */ + eol = dstEnd; + reportError = 1; + goto gotEOL; } dst = dstEnd; } @@ -4981,7 +4996,16 @@ Tcl_GetsObj( Tcl_SetObjLength(objPtr, eol - objPtr->bytes); CommonGetsCleanup(chanPtr); ResetFlag(statePtr, CHANNEL_BLOCKED); - copiedTotal = gs.totalChars + gs.charsWrote - skip; + if (reportError) { + ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR|CHANNEL_ENCODING_ERROR); + /* reset CHANNEL_ENCODING_ERROR to afford a chance to reconfigure + * the channel and try again + */ + Tcl_SetErrno(EILSEQ); + copiedTotal = -1; + } else { + copiedTotal = gs.totalChars + gs.charsWrote - skip; + } goto done; /* diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index e5ba298..bc52b8e 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -295,7 +295,7 @@ Tcl_GetsObjCmd( Tcl_Channel chan; /* The channel to read from. */ int lineLen; /* Length of line just read. */ int mode; /* Mode in which channel is opened. */ - Tcl_Obj *linePtr, *chanObjPtr; + Tcl_Obj *linePtr, *chanObjPtr, *returnOptsPtr; int code = TCL_OK; if ((objc != 2) && (objc != 3)) { @@ -318,7 +318,6 @@ Tcl_GetsObjCmd( lineLen = Tcl_GetsObj(chan, linePtr); if (lineLen < 0) { if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { - Tcl_DecrRefCount(linePtr); /* * TIP #219. @@ -332,7 +331,11 @@ Tcl_GetsObjCmd( "error reading \"%s\": %s", TclGetString(chanObjPtr), Tcl_PosixError(interp))); } + returnOptsPtr = Tcl_NewDictObj(); + Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-result", -1) + , linePtr); code = TCL_ERROR; + Tcl_SetReturnOptions(interp, returnOptsPtr); goto done; } lineLen = TCL_INDEX_NONE; diff --git a/tests/io.test b/tests/io.test index 2fa06ea..854759e 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9255,6 +9255,7 @@ test io-75.13 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} - } -match glob -result {41 1 {error reading "*": illegal byte sequence}} test io-75.14 {invalid utf-8 encoding [gets] coninues in non-strict mode after error} -setup { + set res {} set fn [makeFile {} io-75.14] set f [open $fn w+] fconfigure $f -encoding binary @@ -9271,13 +9272,40 @@ test io-75.14 {invalid utf-8 encoding [gets] coninues in non-strict mode after e lappend res [gets $f] lappend res [gets $f] close $f - return $res + return $res } -cleanup { removeFile io-75.14 } -match glob -result {a 1 {error reading "*": illegal byte sequence} bÀ c} -# ### ### ### ######### ######### ######### +test io-75.15 {invalid utf-8 encoding strict gets should not hang} -setup { + set res {} + set fn [makeFile {} io-75.15] + set chan [open $fn w+] + fconfigure $chan -encoding binary + # This is not valid UTF-8 + puts $chan hello\nAB\xc0\x40CD\nEFG + close $chan +} -body { + #Now try to read it with [gets] + set chan [open $fn] + fconfigure $chan -encoding utf-8 -strictencoding 1 + lappend res [gets $chan] + set status [catch {gets $chan} cres copts] + lappend res $status $cres + set status [catch {gets $chan} cres copts] + lappend res $status $cres + lappend res [dict get $copts -result] + chan configur $chan -encoding binary + foreach char [split [read $chan 2] {}] { + lappend res [format %x [scan $char %c]] + } + return $res +} -cleanup { + close $chan + removeFile io-75.15 +} -match glob -result {hello 1 {error reading "*": illegal byte sequence}\ + 1 {error reading "*": illegal byte sequence} AB c0 40} test io-76.0 {channel modes} -setup { -- cgit v0.12 From ce9fb3bcfb5727f83db328e2ee54bc6b56c6e7ea Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 4 Jan 2023 23:21:16 +0000 Subject: Fix [0f19edcb78]: Windows 11 not reported in tcl_platform(osVersion) --- unix/tclUnixInit.c | 3 +++ win/tclWinInit.c | 3 +++ 2 files changed, 6 insertions(+) diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index 7467938..47b8df3 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -895,6 +895,9 @@ TclpSetVariables( GetSystemInfo(&sysInfo); + if (osInfo.dwMajorVersion == 10 && osInfo.dwBuildNumber >= 22000) { + osInfo.dwMajorVersion = 11; + } Tcl_SetVar2(interp, "tcl_platform", "os", "Windows NT", TCL_GLOBAL_ONLY); sprintf(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion); Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY); diff --git a/win/tclWinInit.c b/win/tclWinInit.c index eae4404..582c700 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -552,6 +552,9 @@ TclpSetVariables( TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "tcl_platform", "os", "Windows NT", TCL_GLOBAL_ONLY); + if (osInfo.dwMajorVersion == 10 && osInfo.dwBuildNumber >= 22000) { + osInfo.dwMajorVersion = 11; + } wsprintfA(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion); Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY); if (sys.oemId.wProcessorArchitecture < NUMPROCESSORS) { -- cgit v0.12 From 72eb4e42290dccb6db60a66a085c355fb1e779e9 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 6 Jan 2023 16:56:14 +0000 Subject: Fix [ad393071c2]: Use different LD_LIBRARY_PATH_VAR on macOS --- unix/configure | 2 +- unix/tcl.m4 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/unix/configure b/unix/configure index 8981ef8..94ecfc6 100755 --- a/unix/configure +++ b/unix/configure @@ -7898,7 +7898,7 @@ fi CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" - LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH" + LD_LIBRARY_PATH_VAR="DYLD_FALLBACK_LIBRARY_PATH" cat >>confdefs.h <<\_ACEOF #define MAC_OSX_TCL 1 diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 6063847..6cee92c 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1594,7 +1594,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ ]) CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" - LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH" + LD_LIBRARY_PATH_VAR="DYLD_FALLBACK_LIBRARY_PATH" AC_DEFINE(MAC_OSX_TCL, 1, [Is this a Mac I see before me?]) PLAT_OBJS='${MAC_OSX_OBJS}' PLAT_SRCS='${MAC_OSX_SRCS}' -- cgit v0.12 From 805fa175fc88005a9955a6202f05d17b91b70c19 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sun, 8 Jan 2023 10:07:46 +0000 Subject: For [read] and [gets] encoding errors, use "-result read" in return options dictionary instead of just "-result". --- generic/tclIOCmd.c | 14 ++++-- tests/io.test | 141 ++++++++++++++++++++++++++++++++++++----------------- 2 files changed, 106 insertions(+), 49 deletions(-) diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index bc52b8e..2eeb04c 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -295,7 +295,7 @@ Tcl_GetsObjCmd( Tcl_Channel chan; /* The channel to read from. */ int lineLen; /* Length of line just read. */ int mode; /* Mode in which channel is opened. */ - Tcl_Obj *linePtr, *chanObjPtr, *returnOptsPtr; + Tcl_Obj *linePtr, *chanObjPtr, *resultDictPtr, *returnOptsPtr; int code = TCL_OK; if ((objc != 2) && (objc != 3)) { @@ -331,9 +331,12 @@ Tcl_GetsObjCmd( "error reading \"%s\": %s", TclGetString(chanObjPtr), Tcl_PosixError(interp))); } + resultDictPtr = Tcl_NewDictObj(); + Tcl_DictObjPut(NULL, resultDictPtr, Tcl_NewStringObj("read", -1) + , linePtr); returnOptsPtr = Tcl_NewDictObj(); Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-result", -1) - , linePtr); + , resultDictPtr); code = TCL_ERROR; Tcl_SetReturnOptions(interp, returnOptsPtr); goto done; @@ -384,7 +387,7 @@ Tcl_ReadObjCmd( int toRead; /* How many bytes to read? */ int charactersRead; /* How many characters were read? */ int mode; /* Mode in which channel is opened. */ - Tcl_Obj *resultPtr, *returnOptsPtr, *chanObjPtr; + Tcl_Obj *resultPtr, *resultDictPtr, *returnOptsPtr, *chanObjPtr; if ((objc != 2) && (objc != 3)) { Interp *iPtr; @@ -473,9 +476,12 @@ Tcl_ReadObjCmd( "error reading \"%s\": %s", TclGetString(chanObjPtr), Tcl_PosixError(interp))); } + resultDictPtr = Tcl_NewDictObj(); + Tcl_DictObjPut(NULL, resultDictPtr, Tcl_NewStringObj("read", -1) + , resultPtr); returnOptsPtr = Tcl_NewDictObj(); Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-result", -1) - , resultPtr); + , resultDictPtr); TclChannelRelease(chan); Tcl_DecrRefCount(resultPtr); Tcl_SetReturnOptions(interp, returnOptsPtr); diff --git a/tests/io.test b/tests/io.test index 854759e..3f00561 100644 --- a/tests/io.test +++ b/tests/io.test @@ -1547,37 +1547,43 @@ test io-12.8 {ReadChars: multibyte chars split} { close $f scan [string index $in end] %c } 160 -test io-12.9 {ReadChars: multibyte chars split} -body { - set f [open $path(test1) w] - fconfigure $f -translation binary - puts -nonewline $f [string repeat a 9]\xC2 - close $f - set f [open $path(test1)] - fconfigure $f -encoding utf-8 -buffersize 10 - set in [read $f] - read $f - close $f - scan [string index $in end] %c -} -cleanup { - catch {close $f} -} -result 194 -test io-12.9.strict {ReadChars: multibyte chars split} -body { - set res {} - set f [open $path(test1) w] - fconfigure $f -translation binary - puts -nonewline $f [string repeat a 9]\xC2 - close $f - set f [open $path(test1)] - fconfigure $f -encoding utf-8 -strictencoding 1 -buffersize 10 - set status [catch {read $f} cres copts] - set in [dict get $copts -result] - lappend res $in - lappend res $status $cres - set res -} -cleanup { - close $f - catch {close $f} -} -match glob -result {aaaaaaaaa 1 {error reading "*": illegal byte sequence}} + + +apply [list {} { + set template { + test io-12.9.@variant@ {ReadChars: multibyte chars split, default (strict)} -body { + set res {} + set f [open $path(test1) w] + fconfigure $f -translation binary + puts -nonewline $f [string repeat a 9]\xC2 + close $f + set f [open $path(test1)] + fconfigure $f -encoding utf-8 @strict@ -buffersize 10 + set status [catch {read $f} cres copts] + set in [dict get $copts -result] + lappend res $in + lappend res $status $cres + set status [catch {read $f} cres copts] + set in [dict get $copts -result] + lappend res $in + lappend res $status $cres + set res + } -cleanup { + catch {close $f} + } -match glob -result {{read aaaaaaaaa} 1\ + {error reading "*": illegal byte sequence}\ + {read {}} 1 {error reading "*": illegal byte sequence}} + } + + # strict encoding may be the default in Tcl 9, but in 8 it is not + foreach variant {encodingstrict} strict {{-strictencoding 1}} { + set script [string map [ + list @variant@ $variant @strict@ $strict] $template] + uplevel 1 $script + } +} [namespace current]] + + test io-12.10 {ReadChars: multibyte chars split} -body { set f [open $path(test1) w] fconfigure $f -translation binary @@ -9075,7 +9081,7 @@ test io-75.6 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} -s fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -strictencoding 1 } -body { set status [catch {read $f} cres copts] - set d [dict get $copts -result] + set d [dict get $copts -result read] binary scan $d H* hd lappend hd $status $cres } -cleanup { @@ -9094,7 +9100,7 @@ test io-75.7 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -strictencoding 1 } -body { set status [catch {read $f} cres copts] - set d [dict get $copts -result] + set d [dict get $copts -result read] binary scan $d H* hd lappend hd [eof $f] lappend hd $status @@ -9173,9 +9179,7 @@ test io-75.9 {unrepresentable character write passes and is replaced by ?} -setu removeFile io-75.9 } -match glob -result [list {A} {error writing "*": illegal byte sequence}] -# Incomplete sequence test. -# This error may IMHO only be detected with the close. -# But the read already returns the incomplete sequence. + test io-75.10 {incomplete multibyte encoding read is ignored} -setup { set fn [makeFile {} io-75.10] set f [open $fn w+] @@ -9183,7 +9187,7 @@ test io-75.10 {incomplete multibyte encoding read is ignored} -setup { puts -nonewline $f A\xC0 flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none + fconfigure $f -encoding utf-8 -strictencoding 0 -buffering none } -body { set d [read $f] close $f @@ -9192,8 +9196,32 @@ test io-75.10 {incomplete multibyte encoding read is ignored} -setup { } -cleanup { removeFile io-75.10 } -result 41c0 -# The current result returns the orphan byte as byte. -# This may be expected due to special utf-8 handling. + + +test io-75.10_strict {incomplete multibyte encoding read is an error} -setup { + set res {} + set fn [makeFile {} io-75.10] + set f [open $fn w+] + fconfigure $f -encoding binary + puts -nonewline $f A\xC0 + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -strictencoding 1 -buffering none +} -body { + set status [catch {read $f} cres copts] + set d [dict get $copts -result read] + binary scan $d H* hd + lappend res $hd $cres + chan configure $f -encoding iso8859-1 + set d [read $f] + binary scan $d H* hd + lappend res $hd + close $f + return $res +} -cleanup { + removeFile io-75.10 +} -match glob -result {41 {error reading "*": illegal byte sequence} c0} + # As utf-8 has a special treatment in multi-byte decoding, also test another # one. @@ -9206,10 +9234,11 @@ test io-75.11 {shiftjis encoding error read results in raw bytes} -setup { puts -nonewline $f A\x81\xFFA flush $f seek $f 0 - fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf -strictencoding 1 + fconfigure $f -encoding shiftjis -buffering none -eofchar "" \ + -translation lf -strictencoding 1 } -body { set status [catch {read $f} cres copts] - set d [dict get $copts -result] + set d [dict get $copts -result read] binary scan $d H* hd lappend hd $status lappend hd $cres @@ -9218,14 +9247,36 @@ test io-75.11 {shiftjis encoding error read results in raw bytes} -setup { removeFile io-75.11 } -match glob -result {41 1 {error reading "*": illegal byte sequence}} -test io-75.12 {invalid utf-8 encoding read is ignored} -setup { + +test io-75.12 {invalid utf-8 encoding read is an error} -setup { + set res {} + set fn [makeFile {} io-75.12] + set f [open $fn w+] + fconfigure $f -encoding binary + puts -nonewline $f A\x81 + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf \ + -strictencoding 1 +} -body { + set status [catch {read $f} cres copts] + set d [dict get $copts -result read] + close $f + binary scan $d H* hd + lappend res $hd $status $cres + return $res +} -cleanup { + removeFile io-75.12 +} -match glob -result {41 1 {error reading "*": illegal byte sequence}} +test io-75.12_ignore {invalid utf-8 encoding read is ignored} -setup { set fn [makeFile {} io-75.12] set f [open $fn w+] fconfigure $f -encoding binary puts -nonewline $f A\x81 flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf + fconfigure $f -encoding utf-8 -buffering none -eofchar {} \ + -translation lf -strictencoding 0 } -body { set d [read $f] close $f @@ -9245,7 +9296,7 @@ test io-75.13 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} - fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -strictencoding 1 } -body { set status [catch {read $f} cres copts] - set d [dict get $copts -result] + set d [dict get $copts -result read] binary scan $d H* hd lappend hd $status close $f @@ -9305,7 +9356,7 @@ test io-75.15 {invalid utf-8 encoding strict gets should not hang} -setup { close $chan removeFile io-75.15 } -match glob -result {hello 1 {error reading "*": illegal byte sequence}\ - 1 {error reading "*": illegal byte sequence} AB c0 40} + 1 {error reading "*": illegal byte sequence} {read AB} c0 40} test io-76.0 {channel modes} -setup { -- cgit v0.12 From 33f4149ee57d7c60a267c0f72bec5dabba389613 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 8 Jan 2023 22:47:45 +0000 Subject: Fix for [https://core.tcl-lang.org/tk/tktview?name=370b1ff03e|370b1ff03e]. Not complete/correct yet, since this backouts the fix for [4dbfa46caa] --- generic/tclEncoding.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index d10d9ca..cfad548 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2409,7 +2409,7 @@ UtfToUtfProc( */ if (flags & TCL_ENCODING_MODIFIED) { - if ((STOPONERROR) && (flags & TCL_ENCODING_CHAR_LIMIT)) { + if (STOPONERROR) { result = TCL_CONVERT_MULTIBYTE; break; } @@ -3199,7 +3199,7 @@ TableFromUtfProc( word = fromUnicode[(ch >> 8)][ch & 0xFF]; if ((word == 0) && (ch != 0)) { - if ((STOPONERROR) && (flags & TCL_ENCODING_CHAR_LIMIT)) { + if (STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; } -- cgit v0.12 From 24656c280590bbc66e98685342c461af58f478a1 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sat, 14 Jan 2023 22:07:21 +0000 Subject: Properly quote contents of Make variables to pass through gdb.run file. --- unix/Makefile.in | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index eac47a6..21d4085 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -270,6 +270,8 @@ VALGRINDARGS = --tool=memcheck --num-callers=24 \ --keep-debuginfo=yes \ --suppressions=$(TOOL_DIR)/valgrind_suppress +shquotequote = $(subst ",\",$(subst ',\',$(1))) +shquotesingle = $(subst ','\'',$(1)) #-------------------------------------------------------------------------- # The information below should be usable as is. The configure script won't # modify it and you shouldn't need to modify it either. @@ -816,9 +818,12 @@ test-tcl: ${TCLTEST_EXE} $(SHELL_ENV) ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) gdb-test: ${TCLTEST_EXE} - @echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > gdb.run - @echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run - @echo "set args $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) -singleproc 1" >> gdb.run + @printf '%s ' set env @LD_LIBRARY_PATH_VAR@=\"`pwd`$${@LD_LIBRARY_PATH_VAR@:+:$${@LD_LIBRARY_PATH_VAR}}\" > gdb.run + @printf '\n' >>gdb.run + @printf '%s ' set env TCL_LIBRARY=\'$(call shquotesingle,${TCL_BUILDTIME_LIBRARY})\' >> gdb.run + @printf '\n' >>gdb.run + @printf '%s ' set args $(call shquotequote,$(TOP_DIR))/tests/all.tcl\ + $(call shquotequote,$(TESTFLAGS)) -singleproc 1 >> gdb.run $(GDB) ./${TCLTEST_EXE} --command=gdb.run rm gdb.run -- cgit v0.12 From 5aef206d2d6f165c0997b8050cf92c5645afb8b4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 14 Jan 2023 22:20:53 +0000 Subject: Proposed fix for [a31caff057]: encoding command does not allow -strict to be used with -failindex --- doc/encoding.n | 13 ++++++------- generic/tclCmdAH.c | 6 +++--- tests/cmdAH.test | 28 ++++++++++++++-------------- tests/encoding.test | 4 ++-- tests/safe.test | 8 ++++---- 5 files changed, 29 insertions(+), 30 deletions(-) diff --git a/doc/encoding.n b/doc/encoding.n index 78580f2..7eae61a 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -28,7 +28,7 @@ formats. Performs one of several encoding related operations, depending on \fIoption\fR. The legal \fIoption\fRs are: .TP -\fBencoding convertfrom\fR ?\fB-nocomplain\fR? ?\fB-failindex var\fR? ?\fB-strict\fR? ?\fIencoding\fR? \fIdata\fR +\fBencoding convertfrom\fR ?\fB-nocomplain\fR|\fB-strict\fR|\fB-failindex var\fR? ?\fIencoding\fR? \fIdata\fR . Convert \fIdata\fR to a Unicode string from the specified \fIencoding\fR. The characters in \fIdata\fR are 8 bit binary data. The resulting @@ -48,19 +48,19 @@ in case of a conversion error, the position of the input byte causing the error is returned in the given variable. The return value of the command are the converted characters until the first error position. In case of no error, the value \fI-1\fR is written to the variable. This option -may not be used together with \fB-nocomplain\fR. +may not be used together with \fB-nocomplain\fR, and it already implies \fB-strict\fR. .PP The option \fB-nocomplain\fR has no effect and is available for compatibility with TCL 9. In TCL 9, the encoding command fails with an error on any encoding issue. This switch restores the TCL8.7 behaviour. .PP The \fB-strict\fR option follows more strict rules in conversion. For the \fButf-8\fR -encoder, it disallows the the sequence \fB\\xC0\\x80\fR and noncharacters (which - +encoder, it disallows invalid byte sequences and surrogates (which - otherwise - are just passed through). .VE "TCL8.7 TIP346, TIP607, TIP601" .RE .TP -\fBencoding convertto\fR ?\fB-nocomplain\fR? ?\fB-failindex var\fR? ?\fB-strict\fR? ?\fIencoding\fR? \fIstring\fR +\fBencoding convertto\fR ?\fB-nocomplain\fR|\fB-strict\fR|\fB-failindex var\fR? ?\fIencoding\fR? \fIstring\fR . Convert \fIstring\fR from Unicode to the specified \fIencoding\fR. The result is a sequence of bytes that represents the converted @@ -81,15 +81,14 @@ in case of a conversion error, the position of the input character causing the e is returned in the given variable. The return value of the command are the converted bytes until the first error position. No error condition is raised. In case of no error, the value \fI-1\fR is written to the variable. This option -may not be used together with \fB-nocomplain\fR. +may not be used together with \fB-nocomplain\fR, and it already implies \fB-strict\fR. .PP The option \fB-nocomplain\fR has no effect and is available for compatibility with TCL 9. In TCL 9, the encoding command fails with an error on any encoding issue. This switch restores the TCL8.7 behaviour. .PP The \fB-strict\fR option follows more strict rules in conversion. For the \fButf-8\fR -encoder, it disallows the the sequence \fB\\xC0\\x80\fR and noncharacters (which - -otherwise - are just passed through). +encoder, it disallows surrogates (which - otherwise - are just passed through). .VE "TCL8.7 TIP346, TIP607, TIP601" .RE .TP diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index b4084d1..8f1bf1d 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -593,7 +593,7 @@ EncodingConvertfromObjCmd( goto encConvFromError; } failVarObj = objv[2]; - flags = TCL_ENCODING_STOPONERROR; + flags = TCL_ENCODING_STRICT; objcUnprocessed -= 2; } switch (objcUnprocessed) { @@ -610,7 +610,7 @@ EncodingConvertfromObjCmd( } } else { encConvFromError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain|-strict|-failindex var? ?encoding? data"); return TCL_ERROR; } @@ -749,7 +749,7 @@ EncodingConverttoObjCmd( } } else { encConvToError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain|-strict|-failindex var? ?encoding? data"); return TCL_ERROR; } diff --git a/tests/cmdAH.test b/tests/cmdAH.test index cb7e1cf..3533cb6 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -179,7 +179,7 @@ test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { } -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto -} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto foo bar } -result {unknown encoding "foo"} @@ -201,7 +201,7 @@ test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { } -result 8C test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom foo bar } -result {unknown encoding "foo"} @@ -238,10 +238,10 @@ test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup { test cmdAH-4.14.1 {Syntax error, -nocomplain and -failindex, no encoding} -body { encoding convertfrom -nocomplain -failindex 2 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} test cmdAH-4.14.2 {Syntax error, -nocomplain and -failindex, no encoding} -body { encoding convertto -nocomplain -failindex 2 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} test cmdAH-4.15.1 {Syntax error, -failindex and -nocomplain, no encoding} -body { encoding convertfrom -failindex 2 -nocomplain ABC } -returnCodes 1 -result {unknown encoding "-nocomplain"} @@ -250,19 +250,19 @@ test cmdAH-4.15.2 {Syntax error, -failindex and -nocomplain, no encoding} -body } -returnCodes 1 -result {unknown encoding "-nocomplain"} test cmdAH-4.16.1 {Syntax error, -nocomplain and -failindex, encoding} -body { encoding convertfrom -nocomplain -failindex 2 utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} test cmdAH-4.16.2 {Syntax error, -nocomplain and -failindex, encoding} -body { encoding convertto -nocomplain -failindex 2 utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} test cmdAH-4.17.1 {Syntax error, -failindex and -nocomplain, encoding} -body { encoding convertfrom -failindex 2 -nocomplain utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} test cmdAH-4.17.2 {Syntax error, -failindex and -nocomplain, encoding} -body { encoding convertto -failindex 2 -nocomplain utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} test cmdAH-4.18.1 {Syntax error, -failindex with no var, no encoding} -body { encoding convertfrom -failindex ABC -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} test cmdAH-4.18.2 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { proc encoding_test {} { encoding convertfrom -failindex ABC @@ -270,12 +270,12 @@ test cmdAH-4.18.2 {Syntax error, -failindex with no var, no encoding (byte compi } -body { # Compile and execute encoding_test -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} -cleanup { +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} -cleanup { rename encoding_test "" } test cmdAH-4.18.3 {Syntax error, -failindex with no var, no encoding} -body { encoding convertto -failindex ABC -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} test cmdAH-4.18.4 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { proc encoding_test {} { encoding convertto -failindex ABC @@ -283,7 +283,7 @@ test cmdAH-4.18.4 {Syntax error, -failindex with no var, no encoding (byte compi } -body { # Compile and execute encoding_test -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} -cleanup { +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} -cleanup { rename encoding_test "" } test cmdAH-4.19.1 {convertrom -failindex with correct data} -body { @@ -320,7 +320,7 @@ test cmdAH-4.20.1 {convertrom -failindex with incomplete utf8} -body { set x [encoding convertfrom -failindex i utf-8 A\xc3] binary scan $x H* y list $y $i -} -returnCodes 0 -result {41c3 -1} +} -returnCodes 0 -result {41 1} test cmdAH-4.20.2 {convertrom -failindex with incomplete utf8 (byte compiled)} -setup { proc encoding_test {} { set x [encoding convertfrom -failindex i utf-8 A\xc3] @@ -330,7 +330,7 @@ test cmdAH-4.20.2 {convertrom -failindex with incomplete utf8 (byte compiled)} - } -body { # Compile and execute encoding_test -} -returnCodes 0 -result {41c3 -1} -cleanup { +} -returnCodes 0 -result {41 1} -cleanup { rename encoding_test "" } test cmdAH-4.21.1 {convertto -failindex with wrong character} -body { diff --git a/tests/encoding.test b/tests/encoding.test index 5fd4e8c..a1d129e 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -681,10 +681,10 @@ test encoding-24.21 {Parse with -nocomplain but without providing encoding} { } 1 test encoding-24.22 {Syntax error, two encodings} -body { encoding convertfrom iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} test encoding-24.23 {Syntax error, two encodings} -body { encoding convertto iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} test encoding-24.24 {Parse invalid utf-8 with -strict} -body { encoding convertfrom -strict utf-8 "\xC0\x80\x00\x00" } -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'} diff --git a/tests/safe.test b/tests/safe.test index e5d4d18..f2c0862 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1473,7 +1473,7 @@ test safe-11.7 {testing safe encoding} -setup { interp eval $i encoding convertfrom } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} test safe-11.7.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1482,7 +1482,7 @@ test safe-11.7.1 {testing safe encoding} -setup { } -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data" +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data" while executing "encoding convertfrom" invoked from within @@ -1495,7 +1495,7 @@ test safe-11.8 {testing safe encoding} -setup { interp eval $i encoding convertto } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} test safe-11.8.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1504,7 +1504,7 @@ test safe-11.8.1 {testing safe encoding} -setup { } -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data" +} -result {wrong # args: should be "encoding convertto ?-nocomplain|-strict|-failindex var? ?encoding? data" while executing "encoding convertto" invoked from within -- cgit v0.12 From 25f683758268f3059f49d51f7ae24c3cf0c1d316 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 14 Jan 2023 22:57:15 +0000 Subject: Same change for "encoding convertto" --- generic/tclCmdAH.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 8f1bf1d..016bd02 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -732,7 +732,7 @@ EncodingConverttoObjCmd( goto encConvToError; } failVarObj = objv[2]; - flags = TCL_ENCODING_STOPONERROR; + flags = TCL_ENCODING_STRICT; objcUnprocessed -= 2; } switch (objcUnprocessed) { -- cgit v0.12 From 81262438a784ae0087c36fabd189c15a2433df33 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sun, 15 Jan 2023 19:26:36 +0000 Subject: Fix issue [8f7fdea2d], string-2.20.1 fails on big endian, and also fix issues in TclStringCmp when checkEq is 1. --- generic/tclCmdMZ.c | 38 ++++++++++++++++++++++++-------------- tests/stringComp.test | 6 +++--- 2 files changed, 27 insertions(+), 17 deletions(-) diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 53e12c5..a97f309 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -2629,7 +2629,7 @@ StringEqualCmd( */ objv += objc-2; - match = TclStringCmp(objv[0], objv[1], 0, nocase, reqlength); + match = TclStringCmp(objv[0], objv[1], 1, nocase, reqlength); Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1)); return TCL_OK; } @@ -2702,8 +2702,8 @@ TclStringCmp( Tcl_Obj *value2Ptr, int checkEq, /* comparison is only for equality */ int nocase, /* comparison is not case sensitive */ - int reqlength) /* requested length; -1 to compare whole - * strings */ + int reqlength) /* requested length in characters; -1 to + * compare whole strings */ { const char *s1, *s2; int empty, length, match, s1len, s2len; @@ -2731,10 +2731,10 @@ TclStringCmp( } else if ((value1Ptr->typePtr == &tclStringType) && (value2Ptr->typePtr == &tclStringType)) { /* - * Do a unicode-specific comparison if both of the args are of String + * Do a Unicode-specific comparison if both of the args are of String * type. If the char length == byte length, we can do a memcmp. In * benchmark testing this proved the most efficient check between the - * unicode and string comparison operations. + * Unicode and string comparison operations. */ if (nocase) { @@ -2748,6 +2748,9 @@ TclStringCmp( && (value1Ptr->bytes != NULL) && (s2len == value2Ptr->length) && (value2Ptr->bytes != NULL)) { + /* each byte represents one character so s1l3n, s2l3n, and + * reqlength are in both bytes and characters + */ s1 = value1Ptr->bytes; s2 = value2Ptr->bytes; memCmpFn = memcmp; @@ -2756,14 +2759,17 @@ TclStringCmp( s2 = (char *) Tcl_GetUnicode(value2Ptr); if ( #if defined(WORDS_BIGENDIAN) && (TCL_UTF_MAX != 4) - 1 + 1 #else - checkEq + checkEq #endif /* WORDS_BIGENDIAN */ - ) { + ) { memCmpFn = memcmp; s1len *= sizeof(Tcl_UniChar); s2len *= sizeof(Tcl_UniChar); + if (reqlength > 0) { + reqlength *= sizeof(Tcl_UniChar); + } } else { memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp; } @@ -2805,7 +2811,7 @@ TclStringCmp( s2 = TclGetStringFromObj(value2Ptr, &s2len); } - if (!nocase && checkEq) { + if (!nocase && checkEq && reqlength < 0) { /* * When we have equal-length we can check only for (in)equality. * We can use memcmp() in all (n)eq cases because we don't need to @@ -2826,24 +2832,28 @@ TclStringCmp( s1len = Tcl_NumUtfChars(s1, s1len); s2len = Tcl_NumUtfChars(s2, s2len); memCmpFn = (memCmpFn_t) - (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); + (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); } } } + /* At this point s1len, s2len, and reqlength should by now have been + * adjusted so that they are all in the units expected by the selected + * comparison function. + */ + length = (s1len < s2len) ? s1len : s2len; if (reqlength > 0 && reqlength < length) { length = reqlength; } else if (reqlength < 0) { /* - * The requested length is negative, so we ignore it by setting it to - * length + 1 so we correct the match var. + * The requested length is negative, so ignore it by setting it to + * length + 1 to correct the match var. */ - reqlength = length + 1; } - if (checkEq && (s1len != s2len)) { + if (checkEq && reqlength < 0 && (s1len != s2len)) { match = 1; /* This will be reversed below. */ } else { /* diff --git a/tests/stringComp.test b/tests/stringComp.test index a17390d..95a738c 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -100,7 +100,7 @@ foreach {tname tbody tresult tcode} { {unicode} {string compare \334 \u00fc} -1 {} {unicode} {string compare \334\334\334\374\374 \334\334\334\334\334} 1 {} {high bit} { - # This test will fail if the underlying comparison + # This test fails if the underlying comparison # is using signed chars instead of unsigned chars. # (like SunOS's default memcmp thus the compat/memcmp.c) string compare "\x80" "@" @@ -156,10 +156,10 @@ foreach {tname tbody tresult tcode} { {-nocase null strings} { string compare -nocase foo "" } 1 {} - {with length, unequal strings} { + {with length, unequal strings, partial first string} { string compare -length 2 abc abde } 0 {} - {with length, unequal strings} { + {with length, unequal strings 2, full first string} { string compare -length 2 ab abde } 0 {} {with NUL character vs. other ASCII} { -- cgit v0.12 From 7faef9ce700c7dc01e1333046e7a69bdb7a45bbf Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 15 Jan 2023 19:45:54 +0000 Subject: Update documentation, matching current implementation --- doc/encoding.n | 13 ++++++------- generic/tclCmdAH.c | 4 ++-- tests/cmdAH.test | 24 ++++++++++++------------ tests/encoding.test | 4 ++-- tests/safe.test | 8 ++++---- 5 files changed, 26 insertions(+), 27 deletions(-) diff --git a/doc/encoding.n b/doc/encoding.n index 78580f2..d4b91e2 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -28,7 +28,7 @@ formats. Performs one of several encoding related operations, depending on \fIoption\fR. The legal \fIoption\fRs are: .TP -\fBencoding convertfrom\fR ?\fB-nocomplain\fR? ?\fB-failindex var\fR? ?\fB-strict\fR? ?\fIencoding\fR? \fIdata\fR +\fBencoding convertfrom\fR ?\fB-nocomplain\fR|\fB-strict\fR|\fB-failindex var\fR? ?\fIencoding\fR? \fIdata\fR . Convert \fIdata\fR to a Unicode string from the specified \fIencoding\fR. The characters in \fIdata\fR are 8 bit binary data. The resulting @@ -48,19 +48,19 @@ in case of a conversion error, the position of the input byte causing the error is returned in the given variable. The return value of the command are the converted characters until the first error position. In case of no error, the value \fI-1\fR is written to the variable. This option -may not be used together with \fB-nocomplain\fR. +may not be used together with \fB-nocomplain\fR or \fB-strict\fR. .PP The option \fB-nocomplain\fR has no effect and is available for compatibility with TCL 9. In TCL 9, the encoding command fails with an error on any encoding issue. This switch restores the TCL8.7 behaviour. .PP The \fB-strict\fR option follows more strict rules in conversion. For the \fButf-8\fR -encoder, it disallows the the sequence \fB\\xC0\\x80\fR and noncharacters (which - +encoder, it disallows invalid byte sequences and surrogates (which - otherwise - are just passed through). .VE "TCL8.7 TIP346, TIP607, TIP601" .RE .TP -\fBencoding convertto\fR ?\fB-nocomplain\fR? ?\fB-failindex var\fR? ?\fB-strict\fR? ?\fIencoding\fR? \fIstring\fR +\fBencoding convertto\fR ?\fB-nocomplain\fR|\fB-strict\fR|\fB-failindex var\fR? ?\fIencoding\fR? \fIstring\fR . Convert \fIstring\fR from Unicode to the specified \fIencoding\fR. The result is a sequence of bytes that represents the converted @@ -81,15 +81,14 @@ in case of a conversion error, the position of the input character causing the e is returned in the given variable. The return value of the command are the converted bytes until the first error position. No error condition is raised. In case of no error, the value \fI-1\fR is written to the variable. This option -may not be used together with \fB-nocomplain\fR. +may not be used together with \fB-nocomplain\fR or \fB-strict\fR. .PP The option \fB-nocomplain\fR has no effect and is available for compatibility with TCL 9. In TCL 9, the encoding command fails with an error on any encoding issue. This switch restores the TCL8.7 behaviour. .PP The \fB-strict\fR option follows more strict rules in conversion. For the \fButf-8\fR -encoder, it disallows the the sequence \fB\\xC0\\x80\fR and noncharacters (which - -otherwise - are just passed through). +encoder, it disallows surrogates (which - otherwise - are just passed through). .VE "TCL8.7 TIP346, TIP607, TIP601" .RE .TP diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index b4084d1..dd0a525 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -610,7 +610,7 @@ EncodingConvertfromObjCmd( } } else { encConvFromError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain|-strict|-failindex var? ?encoding? data"); return TCL_ERROR; } @@ -749,7 +749,7 @@ EncodingConverttoObjCmd( } } else { encConvToError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain|-strict|-failindex var? ?encoding? data"); return TCL_ERROR; } diff --git a/tests/cmdAH.test b/tests/cmdAH.test index cb7e1cf..9b853f5 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -179,7 +179,7 @@ test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { } -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto -} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto foo bar } -result {unknown encoding "foo"} @@ -201,7 +201,7 @@ test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { } -result 8C test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom foo bar } -result {unknown encoding "foo"} @@ -238,10 +238,10 @@ test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup { test cmdAH-4.14.1 {Syntax error, -nocomplain and -failindex, no encoding} -body { encoding convertfrom -nocomplain -failindex 2 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} test cmdAH-4.14.2 {Syntax error, -nocomplain and -failindex, no encoding} -body { encoding convertto -nocomplain -failindex 2 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} test cmdAH-4.15.1 {Syntax error, -failindex and -nocomplain, no encoding} -body { encoding convertfrom -failindex 2 -nocomplain ABC } -returnCodes 1 -result {unknown encoding "-nocomplain"} @@ -250,19 +250,19 @@ test cmdAH-4.15.2 {Syntax error, -failindex and -nocomplain, no encoding} -body } -returnCodes 1 -result {unknown encoding "-nocomplain"} test cmdAH-4.16.1 {Syntax error, -nocomplain and -failindex, encoding} -body { encoding convertfrom -nocomplain -failindex 2 utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} test cmdAH-4.16.2 {Syntax error, -nocomplain and -failindex, encoding} -body { encoding convertto -nocomplain -failindex 2 utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} test cmdAH-4.17.1 {Syntax error, -failindex and -nocomplain, encoding} -body { encoding convertfrom -failindex 2 -nocomplain utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} test cmdAH-4.17.2 {Syntax error, -failindex and -nocomplain, encoding} -body { encoding convertto -failindex 2 -nocomplain utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} test cmdAH-4.18.1 {Syntax error, -failindex with no var, no encoding} -body { encoding convertfrom -failindex ABC -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} test cmdAH-4.18.2 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { proc encoding_test {} { encoding convertfrom -failindex ABC @@ -270,12 +270,12 @@ test cmdAH-4.18.2 {Syntax error, -failindex with no var, no encoding (byte compi } -body { # Compile and execute encoding_test -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} -cleanup { +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} -cleanup { rename encoding_test "" } test cmdAH-4.18.3 {Syntax error, -failindex with no var, no encoding} -body { encoding convertto -failindex ABC -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} test cmdAH-4.18.4 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { proc encoding_test {} { encoding convertto -failindex ABC @@ -283,7 +283,7 @@ test cmdAH-4.18.4 {Syntax error, -failindex with no var, no encoding (byte compi } -body { # Compile and execute encoding_test -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} -cleanup { +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} -cleanup { rename encoding_test "" } test cmdAH-4.19.1 {convertrom -failindex with correct data} -body { diff --git a/tests/encoding.test b/tests/encoding.test index 5fd4e8c..a1d129e 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -681,10 +681,10 @@ test encoding-24.21 {Parse with -nocomplain but without providing encoding} { } 1 test encoding-24.22 {Syntax error, two encodings} -body { encoding convertfrom iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} test encoding-24.23 {Syntax error, two encodings} -body { encoding convertto iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} test encoding-24.24 {Parse invalid utf-8 with -strict} -body { encoding convertfrom -strict utf-8 "\xC0\x80\x00\x00" } -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'} diff --git a/tests/safe.test b/tests/safe.test index e5d4d18..f2c0862 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1473,7 +1473,7 @@ test safe-11.7 {testing safe encoding} -setup { interp eval $i encoding convertfrom } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} test safe-11.7.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1482,7 +1482,7 @@ test safe-11.7.1 {testing safe encoding} -setup { } -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data" +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data" while executing "encoding convertfrom" invoked from within @@ -1495,7 +1495,7 @@ test safe-11.8 {testing safe encoding} -setup { interp eval $i encoding convertto } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} test safe-11.8.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1504,7 +1504,7 @@ test safe-11.8.1 {testing safe encoding} -setup { } -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?-nocomplain? ?-strict? ?-failindex var? ?encoding? data" +} -result {wrong # args: should be "encoding convertto ?-nocomplain|-strict|-failindex var? ?encoding? data" while executing "encoding convertto" invoked from within -- cgit v0.12 From 5021d1c11f0e3287ce96351e20e79552a92e7177 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 16 Jan 2023 13:10:07 +0000 Subject: New flag TCL_ENCODING_HACK_FLAG to control the behaviour. (This is NOT the way to do it, but it's only meant for experimenting) --- generic/tcl.h | 1 + generic/tclEncoding.c | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index f373382..36e1a35 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2145,6 +2145,7 @@ typedef struct Tcl_EncodingType { #define TCL_ENCODING_MODIFIED 0x20 #define TCL_ENCODING_NOCOMPLAIN 0x40 #define TCL_ENCODING_STRICT 0x44 +#define TCL_ENCODING_HACK_FLAG (1<<20) /* * The following definitions are the error codes returned by the conversion diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index cfad548..2c4382d 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2409,7 +2409,7 @@ UtfToUtfProc( */ if (flags & TCL_ENCODING_MODIFIED) { - if (STOPONERROR) { + if ((STOPONERROR) && ((flags & TCL_ENCODING_CHAR_LIMIT) || (flags & TCL_ENCODING_HACK_FLAG))) { result = TCL_CONVERT_MULTIBYTE; break; } @@ -3199,7 +3199,7 @@ TableFromUtfProc( word = fromUnicode[(ch >> 8)][ch & 0xFF]; if ((word == 0) && (ch != 0)) { - if (STOPONERROR) { + if ((STOPONERROR) && (flags & TCL_ENCODING_CHAR_LIMIT)) { result = TCL_CONVERT_UNKNOWN; break; } -- cgit v0.12 From 925f00c5cad128feb5c4e49b7dd31edc205b4746 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 17 Jan 2023 14:15:39 +0000 Subject: Use TCL_ENCODING_HACK_FLAG in TableFromUtfProc too --- generic/tclEncoding.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 2c4382d..3b9ab3e 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -3199,7 +3199,7 @@ TableFromUtfProc( word = fromUnicode[(ch >> 8)][ch & 0xFF]; if ((word == 0) && (ch != 0)) { - if ((STOPONERROR) && (flags & TCL_ENCODING_CHAR_LIMIT)) { + if ((STOPONERROR) && ((flags & TCL_ENCODING_CHAR_LIMIT) || (flags & TCL_ENCODING_HACK_FLAG))) { result = TCL_CONVERT_UNKNOWN; break; } -- cgit v0.12 From 5d50502a2952145d5a6eaa4482ccd79628c1e16f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 18 Jan 2023 13:26:15 +0000 Subject: Forget about TCL_ENCODING_HACK_FLAG, this should be the fix. Testing ... --- generic/tcl.h | 1 - generic/tclEncoding.c | 4 ++-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index 36e1a35..f373382 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2145,7 +2145,6 @@ typedef struct Tcl_EncodingType { #define TCL_ENCODING_MODIFIED 0x20 #define TCL_ENCODING_NOCOMPLAIN 0x40 #define TCL_ENCODING_STRICT 0x44 -#define TCL_ENCODING_HACK_FLAG (1<<20) /* * The following definitions are the error codes returned by the conversion diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 3b9ab3e..ca96057 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2409,7 +2409,7 @@ UtfToUtfProc( */ if (flags & TCL_ENCODING_MODIFIED) { - if ((STOPONERROR) && ((flags & TCL_ENCODING_CHAR_LIMIT) || (flags & TCL_ENCODING_HACK_FLAG))) { + if ((STOPONERROR) && (flags & TCL_ENCODING_CHAR_LIMIT)) { result = TCL_CONVERT_MULTIBYTE; break; } @@ -3199,7 +3199,7 @@ TableFromUtfProc( word = fromUnicode[(ch >> 8)][ch & 0xFF]; if ((word == 0) && (ch != 0)) { - if ((STOPONERROR) && ((flags & TCL_ENCODING_CHAR_LIMIT) || (flags & TCL_ENCODING_HACK_FLAG))) { + if (STOPONERROR) { result = TCL_CONVERT_UNKNOWN; break; } -- cgit v0.12 From 31226696c3e4dd02735044bc1fbf316c0955e65a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 18 Jan 2023 14:10:09 +0000 Subject: Some test-cases need -nocomplainencoding 1, because they use the fallback behavior. --- tests/chanio.test | 6 +++--- tests/io.test | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index 2189cc4..6b45da9 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -252,7 +252,7 @@ test chan-io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} -bod test chan-io-3.4 {WriteChars: loop over stage buffer} -body { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] - chan configure $f -encoding jis0208 -buffersize 16 + chan configure $f -encoding jis0208 -buffersize 16 -nocomplainencoding 1 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] chan close $f @@ -265,7 +265,7 @@ test chan-io-3.5 {WriteChars: saved != 0} -body { # be moved to beginning of next channel buffer to preserve requested # buffersize. set f [open $path(test1) w] - chan configure $f -encoding jis0208 -buffersize 17 + chan configure $f -encoding jis0208 -buffersize 17 -nocomplainencoding 1 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] chan close $f @@ -298,7 +298,7 @@ test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -body { # on flush. The truncated bytes are moved to the beginning of the next # channel buffer. set f [open $path(test1) w] - chan configure $f -encoding jis0208 -buffersize 17 + chan configure $f -encoding jis0208 -buffersize 17 -nocomplainencoding 1 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] chan close $f diff --git a/tests/io.test b/tests/io.test index d10e1e4..d2e687d 100644 --- a/tests/io.test +++ b/tests/io.test @@ -272,7 +272,7 @@ test io-3.4 {WriteChars: loop over stage buffer} -body { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 16 + fconfigure $f -encoding jis0208 -buffersize 16 -nocomplainencoding 1 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -286,7 +286,7 @@ test io-3.5 {WriteChars: saved != 0} -body { # requested buffersize. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 17 + fconfigure $f -encoding jis0208 -buffersize 17 -nocomplainencoding 1 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -319,7 +319,7 @@ test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -body { # of the next channel buffer. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 17 + fconfigure $f -encoding jis0208 -buffersize 17 -nocomplainencoding 1 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f -- cgit v0.12 From 22657ad365387756101eef242c94c8989688955c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 19 Jan 2023 17:01:40 +0000 Subject: New proposal: Allow "-strict" immediately before or after "-failindex var". --- doc/encoding.n | 4 ++-- generic/tclCmdAH.c | 43 +++++++++++++++++++++++++++++++++----- generic/tclEncoding.c | 7 ++++--- generic/tclIO.h | 1 + tests/cmdAH.test | 58 ++++++++++++++++++++++++++++++++++++++++----------- tests/encoding.test | 4 ++-- tests/safe.test | 8 +++---- 7 files changed, 97 insertions(+), 28 deletions(-) diff --git a/doc/encoding.n b/doc/encoding.n index 7eae61a..24ca1c7 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -48,7 +48,7 @@ in case of a conversion error, the position of the input byte causing the error is returned in the given variable. The return value of the command are the converted characters until the first error position. In case of no error, the value \fI-1\fR is written to the variable. This option -may not be used together with \fB-nocomplain\fR, and it already implies \fB-strict\fR. +may not be used together with \fB-nocomplain\fR. .PP The option \fB-nocomplain\fR has no effect and is available for compatibility with TCL 9. In TCL 9, the encoding command fails with an error on any encoding issue. @@ -81,7 +81,7 @@ in case of a conversion error, the position of the input character causing the e is returned in the given variable. The return value of the command are the converted bytes until the first error position. No error condition is raised. In case of no error, the value \fI-1\fR is written to the variable. This option -may not be used together with \fB-nocomplain\fR, and it already implies \fB-strict\fR. +may not be used together with \fB-nocomplain\fR. .PP The option \fB-nocomplain\fR has no effect and is available for compatibility with TCL 9. In TCL 9, the encoding command fails with an error on any encoding issue. diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 016bd02..72cc618 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -12,6 +12,7 @@ */ #include "tclInt.h" +#include "tclIO.h" #ifdef _WIN32 # include "tclWinInt.h" #endif @@ -574,7 +575,7 @@ EncodingConvertfromObjCmd( if (objc == 2) { encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; - } else if (objc > 2 && objc < 6) { + } else if (objc > 2 && objc < 7) { int objcUnprocessed = objc; data = objv[objc - 1]; bytesPtr = Tcl_GetString(objv[1]); @@ -586,6 +587,16 @@ EncodingConvertfromObjCmd( && !strncmp(bytesPtr, "-strict", strlen(bytesPtr))) { flags = TCL_ENCODING_STRICT; objcUnprocessed--; + bytesPtr = Tcl_GetString(objv[2]); + if (bytesPtr[0] == '-' && bytesPtr[1] == 'f' + && !strncmp(bytesPtr, "-failindex", strlen(bytesPtr))) { + /* at least two additional arguments needed */ + if (objc < 6) { + goto encConvFromError; + } + failVarObj = objv[3]; + objcUnprocessed -= 2; + } } else if (bytesPtr[0] == '-' && bytesPtr[1] == 'f' && !strncmp(bytesPtr, "-failindex", strlen(bytesPtr))) { /* at least two additional arguments needed */ @@ -593,8 +604,14 @@ EncodingConvertfromObjCmd( goto encConvFromError; } failVarObj = objv[2]; - flags = TCL_ENCODING_STRICT; + flags = ENCODING_FAILINDEX; objcUnprocessed -= 2; + bytesPtr = Tcl_GetString(objv[3]); + if (bytesPtr[0] == '-' && bytesPtr[1] == 's' + && !strncmp(bytesPtr, "-strict", strlen(bytesPtr))) { + flags = TCL_ENCODING_STRICT; + objcUnprocessed --; + } } switch (objcUnprocessed) { case 3: @@ -610,7 +627,7 @@ EncodingConvertfromObjCmd( } } else { encConvFromError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain|-strict|-failindex var? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"); return TCL_ERROR; } @@ -725,6 +742,16 @@ EncodingConverttoObjCmd( && !strncmp(stringPtr, "-strict", strlen(stringPtr))) { flags = TCL_ENCODING_STRICT; objcUnprocessed--; + stringPtr = Tcl_GetString(objv[2]); + if (stringPtr[0] == '-' && stringPtr[1] == 'f' + && !strncmp(stringPtr, "-failindex", strlen(stringPtr))) { + /* at least two additional arguments needed */ + if (objc < 6) { + goto encConvToError; + } + failVarObj = objv[3]; + objcUnprocessed -= 2; + } } else if (stringPtr[0] == '-' && stringPtr[1] == 'f' && !strncmp(stringPtr, "-failindex", strlen(stringPtr))) { /* at least two additional arguments needed */ @@ -732,8 +759,14 @@ EncodingConverttoObjCmd( goto encConvToError; } failVarObj = objv[2]; - flags = TCL_ENCODING_STRICT; + flags = TCL_ENCODING_STOPONERROR; objcUnprocessed -= 2; + stringPtr = Tcl_GetString(objv[3]); + if (stringPtr[0] == '-' && stringPtr[1] == 's' + && !strncmp(stringPtr, "-strict", strlen(stringPtr))) { + flags = TCL_ENCODING_STRICT; + objcUnprocessed --; + } } switch (objcUnprocessed) { case 3: @@ -749,7 +782,7 @@ EncodingConverttoObjCmd( } } else { encConvToError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain|-strict|-failindex var? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"); return TCL_ERROR; } diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index ca96057..2f7d803 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -10,6 +10,7 @@ */ #include "tclInt.h" +#include "tclIO.h" typedef size_t (LengthProc)(const char *src); @@ -2386,9 +2387,9 @@ UtfToUtfProc( *dst++ = *src++; } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) - && (UCHAR(src[1]) == 0x80) && (!(flags & TCL_ENCODING_MODIFIED) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT))) { + && (UCHAR(src[1]) == 0x80) && (!(flags & TCL_ENCODING_MODIFIED) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) || (flags & ENCODING_FAILINDEX))) { /* - * If in input mode, and -strict is specified: This is an error. + * If in input mode, and -strict or -failindex is specified: This is an error. */ if (flags & TCL_ENCODING_MODIFIED) { result = TCL_CONVERT_SYNTAX; @@ -2413,7 +2414,7 @@ UtfToUtfProc( result = TCL_CONVERT_MULTIBYTE; break; } - if (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)) { + if (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) || (flags & ENCODING_FAILINDEX)) { result = TCL_CONVERT_SYNTAX; break; } diff --git a/generic/tclIO.h b/generic/tclIO.h index fbd01ee..a69e990 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -284,6 +284,7 @@ typedef struct ChannelState { * usable, but it may not be closed * again from within the close * handler. */ +#define ENCODING_FAILINDEX (1<<20) /* Internal flag, fail on Invalid bytes only */ #define CHANNEL_CLOSEDWRITE (1<<21) /* Channel write side has been closed. * No further Tcl-level write IO on * the channel is allowed. */ diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 3533cb6..9d51951 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -179,7 +179,7 @@ test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { } -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto -} -result {wrong # args: should be "encoding convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto foo bar } -result {unknown encoding "foo"} @@ -201,7 +201,7 @@ test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { } -result 8C test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom foo bar } -result {unknown encoding "foo"} @@ -238,10 +238,10 @@ test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup { test cmdAH-4.14.1 {Syntax error, -nocomplain and -failindex, no encoding} -body { encoding convertfrom -nocomplain -failindex 2 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} test cmdAH-4.14.2 {Syntax error, -nocomplain and -failindex, no encoding} -body { encoding convertto -nocomplain -failindex 2 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} test cmdAH-4.15.1 {Syntax error, -failindex and -nocomplain, no encoding} -body { encoding convertfrom -failindex 2 -nocomplain ABC } -returnCodes 1 -result {unknown encoding "-nocomplain"} @@ -250,19 +250,19 @@ test cmdAH-4.15.2 {Syntax error, -failindex and -nocomplain, no encoding} -body } -returnCodes 1 -result {unknown encoding "-nocomplain"} test cmdAH-4.16.1 {Syntax error, -nocomplain and -failindex, encoding} -body { encoding convertfrom -nocomplain -failindex 2 utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} test cmdAH-4.16.2 {Syntax error, -nocomplain and -failindex, encoding} -body { encoding convertto -nocomplain -failindex 2 utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} test cmdAH-4.17.1 {Syntax error, -failindex and -nocomplain, encoding} -body { encoding convertfrom -failindex 2 -nocomplain utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} test cmdAH-4.17.2 {Syntax error, -failindex and -nocomplain, encoding} -body { encoding convertto -failindex 2 -nocomplain utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} test cmdAH-4.18.1 {Syntax error, -failindex with no var, no encoding} -body { encoding convertfrom -failindex ABC -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} test cmdAH-4.18.2 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { proc encoding_test {} { encoding convertfrom -failindex ABC @@ -270,12 +270,12 @@ test cmdAH-4.18.2 {Syntax error, -failindex with no var, no encoding (byte compi } -body { # Compile and execute encoding_test -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} -cleanup { +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} -cleanup { rename encoding_test "" } test cmdAH-4.18.3 {Syntax error, -failindex with no var, no encoding} -body { encoding convertto -failindex ABC -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} test cmdAH-4.18.4 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { proc encoding_test {} { encoding convertto -failindex ABC @@ -283,7 +283,7 @@ test cmdAH-4.18.4 {Syntax error, -failindex with no var, no encoding (byte compi } -body { # Compile and execute encoding_test -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} -cleanup { +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} -cleanup { rename encoding_test "" } test cmdAH-4.19.1 {convertrom -failindex with correct data} -body { @@ -333,6 +333,40 @@ test cmdAH-4.20.2 {convertrom -failindex with incomplete utf8 (byte compiled)} - } -returnCodes 0 -result {41 1} -cleanup { rename encoding_test "" } +test cmdAH-4.20.3 {convertrom -failindex with incomplete utf8} -body { + set x [encoding convertfrom -strict -failindex i utf-8 A\xc3] + binary scan $x H* y + list $y $i +} -returnCodes 0 -result {41 1} +test cmdAH-4.20.4 {convertrom -failindex with incomplete utf8 (byte compiled)} -setup { + proc encoding_test {} { + set x [encoding convertfrom -strict -failindex i utf-8 A\xc3] + binary scan $x H* y + list $y $i + } +} -body { + # Compile and execute + encoding_test +} -returnCodes 0 -result {41 1} -cleanup { + rename encoding_test "" +} +test cmdAH-4.20.5 {convertrom -failindex with incomplete utf8} -body { + set x [encoding convertfrom -failindex i -strict utf-8 A\xc3] + binary scan $x H* y + list $y $i +} -returnCodes 0 -result {41 1} +test cmdAH-4.20.6 {convertrom -failindex with incomplete utf8 (byte compiled)} -setup { + proc encoding_test {} { + set x [encoding convertfrom -failindex i -strict utf-8 A\xc3] + binary scan $x H* y + list $y $i + } +} -body { + # Compile and execute + encoding_test +} -returnCodes 0 -result {41 1} -cleanup { + rename encoding_test "" +} test cmdAH-4.21.1 {convertto -failindex with wrong character} -body { set x [encoding convertto -failindex i iso8859-1 A\u0141] binary scan $x H* y diff --git a/tests/encoding.test b/tests/encoding.test index a1d129e..095672c 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -681,10 +681,10 @@ test encoding-24.21 {Parse with -nocomplain but without providing encoding} { } 1 test encoding-24.22 {Syntax error, two encodings} -body { encoding convertfrom iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} test encoding-24.23 {Syntax error, two encodings} -body { encoding convertto iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} test encoding-24.24 {Parse invalid utf-8 with -strict} -body { encoding convertfrom -strict utf-8 "\xC0\x80\x00\x00" } -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'} diff --git a/tests/safe.test b/tests/safe.test index f2c0862..be1ce57 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1473,7 +1473,7 @@ test safe-11.7 {testing safe encoding} -setup { interp eval $i encoding convertfrom } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} test safe-11.7.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1482,7 +1482,7 @@ test safe-11.7.1 {testing safe encoding} -setup { } -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|-strict|-failindex var? ?encoding? data" +} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data" while executing "encoding convertfrom" invoked from within @@ -1495,7 +1495,7 @@ test safe-11.8 {testing safe encoding} -setup { interp eval $i encoding convertto } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?-nocomplain|-strict|-failindex var? ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} test safe-11.8.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1504,7 +1504,7 @@ test safe-11.8.1 {testing safe encoding} -setup { } -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?-nocomplain|-strict|-failindex var? ?encoding? data" +} -result {wrong # args: should be "encoding convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data" while executing "encoding convertto" invoked from within -- cgit v0.12 From c611835152c63f8995c427ab9684ecf6125ec2f8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 19 Jan 2023 21:36:05 +0000 Subject: Proposed fix for [3e8074aea7]: [interp limit time -seconds] has a y2k38 problem --- generic/tclInterp.c | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 11202ce..613a86a 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -4686,7 +4686,7 @@ ChildTimeLimitCmd( Tcl_Time limitMoment; Tcl_LimitGetTime(childInterp, &limitMoment); - Tcl_SetObjResult(interp, Tcl_NewLongObj(limitMoment.sec)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limitMoment.sec)); } break; } @@ -4744,25 +4744,27 @@ ChildTimeLimitCmd( } limitMoment.usec = ((long) tmp)*1000; break; - case OPT_SEC: + case OPT_SEC: { + Tcl_WideInt sec; secObj = objv[i+1]; (void) Tcl_GetStringFromObj(objv[i+1], &secLen); if (secLen == 0) { break; } - if (TclGetIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[i+1], &sec) != TCL_OK) { return TCL_ERROR; } - if (tmp < 0) { + if (sec < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "seconds must be at least 0", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", NULL); return TCL_ERROR; } - limitMoment.sec = tmp; + limitMoment.sec = sec; break; } + } } if (milliObj != NULL || secObj != NULL) { if (milliObj != NULL) { -- cgit v0.12 From 073e6715d127e9c252cdc1c852445d0f983e8e27 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 20 Jan 2023 16:51:50 +0000 Subject: Better error-message --- generic/tclCmdAH.c | 9 +++++++-- tests/cmdAH.test | 24 ++++++++++++------------ tests/encoding.test | 4 ++-- tests/safe.test | 8 ++++---- 4 files changed, 25 insertions(+), 20 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 72cc618..b52e2fc 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -627,7 +627,9 @@ EncodingConvertfromObjCmd( } } else { encConvFromError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-strict? ?-failindex var? ?encoding? data"); + ((Interp *) interp)->flags |= INTERP_ALTERNATE_WRONG_ARGS; + Tcl_WrongNumArgs(interp, 1, objv, "-nocomplain ?encoding? data"); return TCL_ERROR; } @@ -782,7 +784,10 @@ EncodingConverttoObjCmd( } } else { encConvToError: - Tcl_WrongNumArgs(interp, 1, objv, "?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"); + Tcl_WrongNumArgs(interp, 1, objv, "?-strict? ?-failindex var? ?encoding? data"); + ((Interp *) interp)->flags |= INTERP_ALTERNATE_WRONG_ARGS; + Tcl_WrongNumArgs(interp, 1, objv, "-nocomplain ?encoding? data"); + return TCL_ERROR; } diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 9d51951..d7a3657 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -179,7 +179,7 @@ test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { } -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto -} -result {wrong # args: should be "encoding convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?-strict? ?-failindex var? ?encoding? data" or "encoding convertto -nocomplain ?encoding? data"} test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto foo bar } -result {unknown encoding "foo"} @@ -201,7 +201,7 @@ test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { } -result 8C test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-strict? ?-failindex var? ?encoding? data" or "encoding convertfrom -nocomplain ?encoding? data"} test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertfrom foo bar } -result {unknown encoding "foo"} @@ -238,10 +238,10 @@ test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup { test cmdAH-4.14.1 {Syntax error, -nocomplain and -failindex, no encoding} -body { encoding convertfrom -nocomplain -failindex 2 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-strict? ?-failindex var? ?encoding? data" or "encoding convertfrom -nocomplain ?encoding? data"} test cmdAH-4.14.2 {Syntax error, -nocomplain and -failindex, no encoding} -body { encoding convertto -nocomplain -failindex 2 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-strict? ?-failindex var? ?encoding? data" or "encoding convertto -nocomplain ?encoding? data"} test cmdAH-4.15.1 {Syntax error, -failindex and -nocomplain, no encoding} -body { encoding convertfrom -failindex 2 -nocomplain ABC } -returnCodes 1 -result {unknown encoding "-nocomplain"} @@ -250,19 +250,19 @@ test cmdAH-4.15.2 {Syntax error, -failindex and -nocomplain, no encoding} -body } -returnCodes 1 -result {unknown encoding "-nocomplain"} test cmdAH-4.16.1 {Syntax error, -nocomplain and -failindex, encoding} -body { encoding convertfrom -nocomplain -failindex 2 utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-strict? ?-failindex var? ?encoding? data" or "encoding convertfrom -nocomplain ?encoding? data"} test cmdAH-4.16.2 {Syntax error, -nocomplain and -failindex, encoding} -body { encoding convertto -nocomplain -failindex 2 utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-strict? ?-failindex var? ?encoding? data" or "encoding convertto -nocomplain ?encoding? data"} test cmdAH-4.17.1 {Syntax error, -failindex and -nocomplain, encoding} -body { encoding convertfrom -failindex 2 -nocomplain utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-strict? ?-failindex var? ?encoding? data" or "encoding convertfrom -nocomplain ?encoding? data"} test cmdAH-4.17.2 {Syntax error, -failindex and -nocomplain, encoding} -body { encoding convertto -failindex 2 -nocomplain utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-strict? ?-failindex var? ?encoding? data" or "encoding convertto -nocomplain ?encoding? data"} test cmdAH-4.18.1 {Syntax error, -failindex with no var, no encoding} -body { encoding convertfrom -failindex ABC -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-strict? ?-failindex var? ?encoding? data" or "::tcl::encoding::convertfrom -nocomplain ?encoding? data"} test cmdAH-4.18.2 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { proc encoding_test {} { encoding convertfrom -failindex ABC @@ -270,12 +270,12 @@ test cmdAH-4.18.2 {Syntax error, -failindex with no var, no encoding (byte compi } -body { # Compile and execute encoding_test -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} -cleanup { +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-strict? ?-failindex var? ?encoding? data" or "::tcl::encoding::convertfrom -nocomplain ?encoding? data"} -cleanup { rename encoding_test "" } test cmdAH-4.18.3 {Syntax error, -failindex with no var, no encoding} -body { encoding convertto -failindex ABC -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-strict? ?-failindex var? ?encoding? data" or "::tcl::encoding::convertto -nocomplain ?encoding? data"} test cmdAH-4.18.4 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { proc encoding_test {} { encoding convertto -failindex ABC @@ -283,7 +283,7 @@ test cmdAH-4.18.4 {Syntax error, -failindex with no var, no encoding (byte compi } -body { # Compile and execute encoding_test -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} -cleanup { +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-strict? ?-failindex var? ?encoding? data" or "::tcl::encoding::convertto -nocomplain ?encoding? data"} -cleanup { rename encoding_test "" } test cmdAH-4.19.1 {convertrom -failindex with correct data} -body { diff --git a/tests/encoding.test b/tests/encoding.test index 095672c..61676ea 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -681,10 +681,10 @@ test encoding-24.21 {Parse with -nocomplain but without providing encoding} { } 1 test encoding-24.22 {Syntax error, two encodings} -body { encoding convertfrom iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-strict? ?-failindex var? ?encoding? data" or "::tcl::encoding::convertfrom -nocomplain ?encoding? data"} test encoding-24.23 {Syntax error, two encodings} -body { encoding convertto iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} +} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-strict? ?-failindex var? ?encoding? data" or "::tcl::encoding::convertto -nocomplain ?encoding? data"} test encoding-24.24 {Parse invalid utf-8 with -strict} -body { encoding convertfrom -strict utf-8 "\xC0\x80\x00\x00" } -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'} diff --git a/tests/safe.test b/tests/safe.test index be1ce57..ee81783 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1473,7 +1473,7 @@ test safe-11.7 {testing safe encoding} -setup { interp eval $i encoding convertfrom } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} +} -result {wrong # args: should be "encoding convertfrom ?-strict? ?-failindex var? ?encoding? data" or "encoding convertfrom -nocomplain ?encoding? data"} test safe-11.7.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1482,7 +1482,7 @@ test safe-11.7.1 {testing safe encoding} -setup { } -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data" +} -result {wrong # args: should be "encoding convertfrom ?-strict? ?-failindex var? ?encoding? data" or "encoding convertfrom -nocomplain ?encoding? data" while executing "encoding convertfrom" invoked from within @@ -1495,7 +1495,7 @@ test safe-11.8 {testing safe encoding} -setup { interp eval $i encoding convertto } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data"} +} -result {wrong # args: should be "encoding convertto ?-strict? ?-failindex var? ?encoding? data" or "encoding convertto -nocomplain ?encoding? data"} test safe-11.8.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1504,7 +1504,7 @@ test safe-11.8.1 {testing safe encoding} -setup { } -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ?-nocomplain|?-strict? ?-failindex var?? ?encoding? data" +} -result {wrong # args: should be "encoding convertto ?-strict? ?-failindex var? ?encoding? data" or "encoding convertto -nocomplain ?encoding? data" while executing "encoding convertto" invoked from within -- cgit v0.12 From 792c57a7fb9f7db346f92861d380a32d1c31ea8a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 20 Jan 2023 20:59:22 +0000 Subject: Make documentation conform to implementation in this branch --- doc/encoding.n | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/doc/encoding.n b/doc/encoding.n index 24ca1c7..9577da3 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -28,7 +28,8 @@ formats. Performs one of several encoding related operations, depending on \fIoption\fR. The legal \fIoption\fRs are: .TP -\fBencoding convertfrom\fR ?\fB-nocomplain\fR|\fB-strict\fR|\fB-failindex var\fR? ?\fIencoding\fR? \fIdata\fR +\fBencoding convertfrom\fR ?\fB-strict\fR? ?\fB-failindex var\fR? ?\fIencoding\fR? \fIdata\fR +\fBencoding convertfrom\fR \fB-nocomplain\fR ?\fIencoding\fR? \fIdata\fR . Convert \fIdata\fR to a Unicode string from the specified \fIencoding\fR. The characters in \fIdata\fR are 8 bit binary data. The resulting @@ -56,11 +57,13 @@ This switch restores the TCL8.7 behaviour. .PP The \fB-strict\fR option follows more strict rules in conversion. For the \fButf-8\fR encoder, it disallows invalid byte sequences and surrogates (which - -otherwise - are just passed through). +otherwise - are just passed through). This option may not be used together +with \fB-nocomplain\fR. .VE "TCL8.7 TIP346, TIP607, TIP601" .RE .TP -\fBencoding convertto\fR ?\fB-nocomplain\fR|\fB-strict\fR|\fB-failindex var\fR? ?\fIencoding\fR? \fIstring\fR +\fBencoding convertto\fR ?\fB-strict\fR? ?\fB-failindex var\fR? ?\fIencoding\fR? \fIdata\fR +\fBencoding convertto\fR \fB-nocomplain\fR ?\fIencoding\fR? \fIdata\fR . Convert \fIstring\fR from Unicode to the specified \fIencoding\fR. The result is a sequence of bytes that represents the converted @@ -88,7 +91,8 @@ TCL 9. In TCL 9, the encoding command fails with an error on any encoding issue. This switch restores the TCL8.7 behaviour. .PP The \fB-strict\fR option follows more strict rules in conversion. For the \fButf-8\fR -encoder, it disallows surrogates (which - otherwise - are just passed through). +encoder, it disallows surrogates (which - otherwise - are just passed through). This +option may not be used together with \fB-nocomplain\fR. .VE "TCL8.7 TIP346, TIP607, TIP601" .RE .TP -- cgit v0.12 From 52948a790cfe853df5cdbecc3c5436685b6210ba Mon Sep 17 00:00:00 2001 From: Kevin B Kenny Date: Sun, 22 Jan 2023 01:33:44 +0000 Subject: Bug [e3dcab1d14] fix --- generic/tclStrToD.c | 59 +++++++++++++++++++++++++++-------------------------- tests/expr.test | 37 +++++++++++++++++++++++++++++++++ 2 files changed, 67 insertions(+), 29 deletions(-) diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 557eaa1..972b5fd 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -263,34 +263,35 @@ static const int log2pow5[27] = { }; #define N_LOG2POW5 27 -static const Tcl_WideUInt wuipow5[27] = { - (Tcl_WideUInt) 1, /* 5**0 */ - (Tcl_WideUInt) 5, - (Tcl_WideUInt) 25, - (Tcl_WideUInt) 125, - (Tcl_WideUInt) 625, - (Tcl_WideUInt) 3125, /* 5**5 */ - (Tcl_WideUInt) 3125*5, - (Tcl_WideUInt) 3125*25, - (Tcl_WideUInt) 3125*125, - (Tcl_WideUInt) 3125*625, - (Tcl_WideUInt) 3125*3125, /* 5**10 */ - (Tcl_WideUInt) 3125*3125*5, - (Tcl_WideUInt) 3125*3125*25, - (Tcl_WideUInt) 3125*3125*125, - (Tcl_WideUInt) 3125*3125*625, - (Tcl_WideUInt) 3125*3125*3125, /* 5**15 */ - (Tcl_WideUInt) 3125*3125*3125*5, - (Tcl_WideUInt) 3125*3125*3125*25, - (Tcl_WideUInt) 3125*3125*3125*125, - (Tcl_WideUInt) 3125*3125*3125*625, - (Tcl_WideUInt) 3125*3125*3125*3125, /* 5**20 */ - (Tcl_WideUInt) 3125*3125*3125*3125*5, - (Tcl_WideUInt) 3125*3125*3125*3125*25, - (Tcl_WideUInt) 3125*3125*3125*3125*125, - (Tcl_WideUInt) 3125*3125*3125*3125*625, - (Tcl_WideUInt) 3125*3125*3125*3125*3125, /* 5**25 */ - (Tcl_WideUInt) 3125*3125*3125*3125*3125*5 /* 5**26 */ +static const Tcl_WideUInt wuipow5[28] = { + (Tcl_WideUInt) 1U, /* 5**0 */ + (Tcl_WideUInt) 5U, + (Tcl_WideUInt) 25U, + (Tcl_WideUInt) 125U, + (Tcl_WideUInt) 625U, + (Tcl_WideUInt) 3125U, /* 5**5 */ + (Tcl_WideUInt) 3125U*5U, + (Tcl_WideUInt) 3125U*25U, + (Tcl_WideUInt) 3125U*125U, + (Tcl_WideUInt) 3125U*625U, + (Tcl_WideUInt) 3125U*3125U, /* 5**10 */ + (Tcl_WideUInt) 3125U*3125U*5U, + (Tcl_WideUInt) 3125U*3125U*25U, + (Tcl_WideUInt) 3125U*3125U*125U, + (Tcl_WideUInt) 3125U*3125U*625U, + (Tcl_WideUInt) 3125U*3125U*3125U, /* 5**15 */ + (Tcl_WideUInt) 3125U*3125U*3125U*5U, + (Tcl_WideUInt) 3125U*3125U*3125U*25U, + (Tcl_WideUInt) 3125U*3125U*3125U*125U, + (Tcl_WideUInt) 3125U*3125U*3125U*625U, + (Tcl_WideUInt) 3125U*3125U*3125U*3125U, /* 5**20 */ + (Tcl_WideUInt) 3125U*3125U*3125U*3125U*5U, + (Tcl_WideUInt) 3125U*3125U*3125U*3125U*25U, + (Tcl_WideUInt) 3125U*3125U*3125U*3125U*125U, + (Tcl_WideUInt) 3125U*3125U*3125U*3125U*625U, + (Tcl_WideUInt) 3125U*3125U*3125U*3125U*3125U, /* 5**25 */ + (Tcl_WideUInt) 3125U*3125U*3125U*3125U*3125U*5U, + (Tcl_WideUInt) 3125U*3125U*3125U*3125U*3125U*25U /* 5**27 */ }; /* @@ -4395,7 +4396,7 @@ TclDoubleDigits( ++m2plus; } - if (s5+1 < N_LOG2POW5 && s2+1 + log2pow5[s5+1] <= 64) { + if (s5+1 < N_LOG2POW5 && s2+1 + log2pow5[s5+1] < 64) { /* * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word, * then all our intermediate calculations can be done using exact diff --git a/tests/expr.test b/tests/expr.test index 4fa6821..57c44ed 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -7277,6 +7277,43 @@ test expr-52.1 { ::tcl::unsupported::representation $a]] } {0 0 1 1} +# Bug e3dcab1d14 +proc do-one-test-expr-61 {e p float athreshold} { + # e - power of 2 to test + # p - tcl_precision to test wuth + # float - floating point value 2**-$p + # athreshold - tolerable absolute error (1/2 decimal digit in + # least significant place plus 1/2 least significant bit) + set trouble {} + set ::tcl_precision $p + set xfmt x[expr $float] + set ::tcl_precision 0 + set fmt [string range $xfmt 1 end] + set aerror [expr {abs($fmt - $float)}] + if {$aerror > $athreshold} { + return "Result $fmt is more than $athreshold away from $float" + } else { + return {} + } +} + +proc run-test-expr-61 {} { + for {set e 0} {$e <= 1023} {incr e} { + set pt [expr {floor($e*log(2)/log(10))}] + for {set p 6} {$p <= 17} {incr p} { + set athreshold [expr {0.5*10.0**-($pt+$p) + 2.0**-($e+53)}] + set numer [expr {5**$e}] + set xfloat x[expr {2.**-$e}] + set float [string range $xfloat 1 end] + test expr-61.$p.$e "convert 2**-$e to decimal at precision $p" { + do-one-test-expr-61 $e $p $float $athreshold + } {} + } + } + rename do-one-test-expr-61 {} + rename run-test-expr-61 {} +} +run-test-expr-61 # cleanup -- cgit v0.12 From 119519c4df904cc9914302f68b70897ad33b9db3 Mon Sep 17 00:00:00 2001 From: Kevin B Kenny Date: Sun, 22 Jan 2023 01:37:07 +0000 Subject: Remove unneeded hard-coded array size --- generic/tclStrToD.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 972b5fd..d5578a9 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -263,7 +263,7 @@ static const int log2pow5[27] = { }; #define N_LOG2POW5 27 -static const Tcl_WideUInt wuipow5[28] = { +static const Tcl_WideUInt wuipow5[] = { (Tcl_WideUInt) 1U, /* 5**0 */ (Tcl_WideUInt) 5U, (Tcl_WideUInt) 25U, -- cgit v0.12 From 4ef7c0c4b836759619b399102ea01f01b4a61165 Mon Sep 17 00:00:00 2001 From: Kevin B Kenny Date: Sun, 22 Jan 2023 01:48:02 +0000 Subject: Missed one more off-by-one error, also, tests misnumbered for merge forward. --- generic/tclStrToD.c | 2 +- tests/expr.test | 14 +++++++------- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index d5578a9..c55554c 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -4453,7 +4453,7 @@ TclDoubleDigits( s2 -= b2; b2 = 0; } - if (s5+1 < N_LOG2POW5 && s2+1 + log2pow5[s5+1] <= 64) { + if (s5+1 < N_LOG2POW5 && s2+1 + log2pow5[s5+1] < 64) { /* * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word, * then all our intermediate calculations can be done using exact diff --git a/tests/expr.test b/tests/expr.test index 57c44ed..2434ab4 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -7278,7 +7278,7 @@ test expr-52.1 { } {0 0 1 1} # Bug e3dcab1d14 -proc do-one-test-expr-61 {e p float athreshold} { +proc do-one-test-expr-63 {e p float athreshold} { # e - power of 2 to test # p - tcl_precision to test wuth # float - floating point value 2**-$p @@ -7297,7 +7297,7 @@ proc do-one-test-expr-61 {e p float athreshold} { } } -proc run-test-expr-61 {} { +proc run-test-expr-63 {} { for {set e 0} {$e <= 1023} {incr e} { set pt [expr {floor($e*log(2)/log(10))}] for {set p 6} {$p <= 17} {incr p} { @@ -7305,15 +7305,15 @@ proc run-test-expr-61 {} { set numer [expr {5**$e}] set xfloat x[expr {2.**-$e}] set float [string range $xfloat 1 end] - test expr-61.$p.$e "convert 2**-$e to decimal at precision $p" { - do-one-test-expr-61 $e $p $float $athreshold + test expr-63.$p.$e "convert 2**-$e to decimal at precision $p" { + do-one-test-expr-63 $e $p $float $athreshold } {} } } - rename do-one-test-expr-61 {} - rename run-test-expr-61 {} + rename do-one-test-expr-63 {} + rename run-test-expr-63 {} } -run-test-expr-61 +run-test-expr-63 # cleanup -- cgit v0.12 From 46dcc60e4182a6b1bfae4b7bf93d03430e5e8ce6 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 23 Jan 2023 19:18:39 +0000 Subject: Better error-message for previous commit. Some more code-cleanup, backported from 8.7 --- generic/tclCmdAH.c | 84 ++++++++++----------------- generic/tclInterp.c | 107 +++++++++++++++++----------------- generic/tclNamesp.c | 162 +++++++++++++++++++++++----------------------------- 3 files changed, 153 insertions(+), 200 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index b3269f4..0bf5b8e 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -46,24 +46,12 @@ struct ForeachState { static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode); -static int BadEncodingSubcommand(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int EncodingConvertfromObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int EncodingConverttoObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int EncodingDirsObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int EncodingNamesObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int EncodingSystemObjCmd(ClientData dummy, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc BadEncodingSubcommand; +static Tcl_ObjCmdProc EncodingConvertfromObjCmd; +static Tcl_ObjCmdProc EncodingConverttoObjCmd; +static Tcl_ObjCmdProc EncodingDirsObjCmd; +static Tcl_ObjCmdProc EncodingNamesObjCmd; +static Tcl_ObjCmdProc EncodingSystemObjCmd; static inline int ForeachAssignments(Tcl_Interp *interp, struct ForeachState *statePtr); static inline void ForeachCleanup(Tcl_Interp *interp, @@ -132,7 +120,6 @@ static Tcl_ObjCmdProc PathTypeCmd; *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_BreakObjCmd( ClientData dummy, /* Not used. */ @@ -164,8 +151,6 @@ Tcl_BreakObjCmd( * *---------------------------------------------------------------------- */ - - /* ARGSUSED */ int Tcl_CaseObjCmd( ClientData dummy, /* Not used. */ @@ -300,7 +285,6 @@ Tcl_CaseObjCmd( *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_CatchObjCmd( ClientData dummy, /* Not used. */ @@ -353,8 +337,8 @@ CatchObjCmdCallback( { Interp *iPtr = (Interp *) interp; int objc = PTR2INT(data[0]); - Tcl_Obj *varNamePtr = data[1]; - Tcl_Obj *optionVarNamePtr = data[2]; + Tcl_Obj *varNamePtr = (Tcl_Obj *)data[1]; + Tcl_Obj *optionVarNamePtr = (Tcl_Obj *)data[2]; int rewind = iPtr->execEnvPtr->rewind; /* @@ -406,7 +390,6 @@ CatchObjCmdCallback( *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_CdObjCmd( ClientData dummy, /* Not used. */ @@ -462,7 +445,6 @@ Tcl_CdObjCmd( *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_ConcatObjCmd( ClientData dummy, /* Not used. */ @@ -497,7 +479,6 @@ Tcl_ConcatObjCmd( *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_ContinueObjCmd( ClientData dummy, /* Not used. */ @@ -834,10 +815,11 @@ EncodingDirsObjCmd( */ int -EncodingNamesObjCmd(ClientData dummy, /* Unused */ - Tcl_Interp* interp, /* Tcl interpreter */ - int objc, /* Number of command line args */ - Tcl_Obj* const objv[]) /* Vector of command line args */ +EncodingNamesObjCmd( + ClientData dummy, /* Unused */ + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Number of command line args */ + Tcl_Obj* const objv[]) /* Vector of command line args */ { if (objc > 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); @@ -864,10 +846,11 @@ EncodingNamesObjCmd(ClientData dummy, /* Unused */ */ int -EncodingSystemObjCmd(ClientData dummy, /* Unused */ - Tcl_Interp* interp, /* Tcl interpreter */ - int objc, /* Number of command line args */ - Tcl_Obj* const objv[]) /* Vector of command line args */ +EncodingSystemObjCmd( + ClientData dummy, /* Unused */ + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Number of command line args */ + Tcl_Obj* const objv[]) /* Vector of command line args */ { if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?encoding?"); @@ -899,7 +882,6 @@ EncodingSystemObjCmd(ClientData dummy, /* Unused */ *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_ErrorObjCmd( ClientData dummy, /* Not used. */ @@ -949,7 +931,6 @@ Tcl_ErrorObjCmd( *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int EvalCmdErrMsg( ClientData data[], @@ -1032,7 +1013,6 @@ TclNREvalObjCmd( *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_ExitObjCmd( ClientData dummy, /* Not used. */ @@ -1053,7 +1033,6 @@ Tcl_ExitObjCmd( return TCL_ERROR; } Tcl_Exit(value); - /*NOTREACHED*/ return TCL_OK; /* Better not ever reach this! */ } @@ -1081,7 +1060,6 @@ Tcl_ExitObjCmd( *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_ExprObjCmd( ClientData dummy, /* Not used. */ @@ -1125,8 +1103,8 @@ ExprCallback( Tcl_Interp *interp, int result) { - Tcl_Obj *resultPtr = data[0]; - Tcl_Obj *objPtr = data[1]; + Tcl_Obj *resultPtr = (Tcl_Obj *)data[0]; + Tcl_Obj *objPtr = (Tcl_Obj *)data[1]; if (objPtr != NULL) { Tcl_DecrRefCount(objPtr); @@ -2319,7 +2297,7 @@ FilesystemSeparatorCmd( return TCL_ERROR; } if (objc == 1) { - const char *separator = NULL; /* lint */ + const char *separator = NULL; switch (tclPlatform) { case TCL_PLATFORM_UNIX: @@ -2622,7 +2600,6 @@ GetTypeFromMode( *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_ForObjCmd( ClientData dummy, /* Not used. */ @@ -2670,7 +2647,7 @@ ForSetupCallback( Tcl_Interp *interp, int result) { - ForIterData *iterPtr = data[0]; + ForIterData *iterPtr = (ForIterData *)data[0]; if (result != TCL_OK) { if (result == TCL_ERROR) { @@ -2689,7 +2666,7 @@ TclNRForIterCallback( Tcl_Interp *interp, int result) { - ForIterData *iterPtr = data[0]; + ForIterData *iterPtr = (ForIterData *)data[0]; Tcl_Obj *boolObj; switch (result) { @@ -2725,8 +2702,8 @@ ForCondCallback( int result) { Interp *iPtr = (Interp *) interp; - ForIterData *iterPtr = data[0]; - Tcl_Obj *boolObj = data[1]; + ForIterData *iterPtr = (ForIterData *)data[0]; + Tcl_Obj *boolObj = (Tcl_Obj *)data[1]; int value; if (result != TCL_OK) { @@ -2763,7 +2740,7 @@ ForNextCallback( int result) { Interp *iPtr = (Interp *) interp; - ForIterData *iterPtr = data[0]; + ForIterData *iterPtr = (ForIterData *)data[0]; Tcl_Obj *next = iterPtr->next; if ((result == TCL_OK) || (result == TCL_CONTINUE)) { @@ -2787,7 +2764,7 @@ ForPostNextCallback( Tcl_Interp *interp, int result) { - ForIterData *iterPtr = data[0]; + ForIterData *iterPtr = (ForIterData *)data[0]; if ((result != TCL_BREAK) && (result != TCL_OK)) { if (result == TCL_ERROR) { @@ -2817,7 +2794,6 @@ ForPostNextCallback( *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_ForeachObjCmd( ClientData dummy, /* Not used. */ @@ -2892,7 +2868,7 @@ EachloopCmd( * allocation for better performance. */ - statePtr = TclStackAlloc(interp, + statePtr = (struct ForeachState *)TclStackAlloc(interp, sizeof(struct ForeachState) + 3 * numLists * sizeof(int) + 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *))); memset(statePtr, 0, @@ -2993,7 +2969,7 @@ ForeachLoopStep( Tcl_Interp *interp, int result) { - struct ForeachState *statePtr = data[0]; + struct ForeachState *statePtr = (struct ForeachState *)data[0]; /* * Process the result code from this run of the [foreach] body. Note that @@ -3070,7 +3046,6 @@ ForeachAssignments( for (i=0 ; inumLists ; i++) { for (v=0 ; vvarcList[i] ; v++) { k = statePtr->index[i]++; - if (k < statePtr->argcList[i]) { valuePtr = statePtr->argvList[i][k]; } else { @@ -3135,7 +3110,6 @@ ForeachCleanup( *---------------------------------------------------------------------- */ - /* ARGSUSED */ int Tcl_FormatObjCmd( ClientData dummy, /* Not used. */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 613a86a..2633a18 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -225,15 +225,12 @@ static int AliasList(Tcl_Interp *interp, Tcl_Interp *childInterp); static int AliasObjCmd(ClientData dummy, Tcl_Interp *currentInterp, int objc, Tcl_Obj *const objv[]); -static int AliasNRCmd(ClientData dummy, - Tcl_Interp *currentInterp, int objc, - Tcl_Obj *const objv[]); -static void AliasObjCmdDeleteProc(ClientData clientData); +static Tcl_ObjCmdProc AliasNRCmd; +static Tcl_CmdDeleteProc AliasObjCmdDeleteProc; static Tcl_Interp * GetInterp(Tcl_Interp *interp, Tcl_Obj *pathPtr); static Tcl_Interp * GetInterp2(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static void InterpInfoDeleteProc(ClientData clientData, - Tcl_Interp *interp); +static Tcl_InterpDeleteProc InterpInfoDeleteProc; static int ChildBgerror(Tcl_Interp *interp, Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); @@ -259,7 +256,7 @@ static int ChildMarkTrusted(Tcl_Interp *interp, Tcl_Interp *childInterp); static int ChildObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static void ChildObjCmdDeleteProc(ClientData clientData); +static Tcl_CmdDeleteProc ChildObjCmdDeleteProc; static int ChildRecursionLimit(Tcl_Interp *interp, Tcl_Interp *childInterp, int objc, Tcl_Obj *const objv[]); @@ -309,7 +306,7 @@ TclSetPreInitScript( { const char *prevString = tclPreInitScript; tclPreInitScript = string; - return(prevString); + return prevString; } /* @@ -473,7 +470,7 @@ TclInterpInit( Parent *parentPtr; Child *childPtr; - interpInfoPtr = ckalloc(sizeof(InterpInfo)); + interpInfoPtr = (InterpInfo *)ckalloc(sizeof(InterpInfo)); ((Interp *) interp)->interpInfo = interpInfoPtr; parentPtr = &interpInfoPtr->parent; @@ -589,7 +586,7 @@ InterpInfoDeleteProc( * *---------------------------------------------------------------------- */ - /* ARGSUSED */ + int Tcl_InterpObjCmd( ClientData clientData, /* Unused. */ @@ -618,7 +615,7 @@ NRInterpCmd( "slaves", "share", "target", "transfer", NULL }; - enum option { + enum interpOptionEnum { OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CANCEL, OPT_CHILDREN, OPT_CREATE, OPT_DEBUG, OPT_DELETE, OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, @@ -635,7 +632,7 @@ NRInterpCmd( &index) != TCL_OK) { return TCL_ERROR; } - switch ((enum option) index) { + switch ((enum interpOptionEnum)index) { case OPT_ALIAS: { Tcl_Interp *parentInterp; @@ -688,7 +685,7 @@ NRInterpCmd( static const char *const cancelOptions[] = { "-unwind", "--", NULL }; - enum option { + enum optionCancelEnum { OPT_UNWIND, OPT_LAST }; @@ -703,7 +700,7 @@ NRInterpCmd( return TCL_ERROR; } - switch ((enum option) index) { + switch ((enum optionCancelEnum) index) { case OPT_UNWIND: /* * The evaluation stack in the target interp is to be unwound. @@ -1024,7 +1021,7 @@ NRInterpCmd( TclNewObj(resultPtr); hPtr = Tcl_FirstHashEntry(&iiPtr->parent.childTable, &hashSearch); for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { - string = Tcl_GetHashKey(&iiPtr->parent.childTable, hPtr); + string = (char *)Tcl_GetHashKey(&iiPtr->parent.childTable, hPtr); Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewStringObj(string, -1)); } @@ -1095,7 +1092,7 @@ NRInterpCmd( NULL); return TCL_ERROR; } - aliasPtr = Tcl_GetHashValue(hPtr); + aliasPtr = (Alias *)Tcl_GetHashValue(hPtr); if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "target interpreter for alias \"%s\" in path \"%s\" is " @@ -1178,7 +1175,7 @@ Tcl_CreateAlias( int i; int result; - objv = TclStackAlloc(childInterp, (unsigned) sizeof(Tcl_Obj *) * argc); + objv = (Tcl_Obj **)TclStackAlloc(childInterp, sizeof(Tcl_Obj *) * argc); for (i = 0; i < argc; i++) { objv[i] = Tcl_NewStringObj(argv[i], -1); Tcl_IncrRefCount(objv[i]); @@ -1284,7 +1281,7 @@ Tcl_GetAlias( Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } - aliasPtr = Tcl_GetHashValue(hPtr); + aliasPtr = (Alias *)Tcl_GetHashValue(hPtr); objc = aliasPtr->objc; objv = &aliasPtr->objPtr; @@ -1346,7 +1343,7 @@ Tcl_GetAliasObj( Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL); return TCL_ERROR; } - aliasPtr = Tcl_GetHashValue(hPtr); + aliasPtr = (Alias *)Tcl_GetHashValue(hPtr); objc = aliasPtr->objc; objv = &aliasPtr->objPtr; @@ -1414,7 +1411,7 @@ TclPreventAliasLoop( * chain then we have a loop. */ - aliasPtr = cmdPtr->objClientData; + aliasPtr = (Alias *)cmdPtr->objClientData; nextAliasPtr = aliasPtr; while (1) { Tcl_Obj *cmdNamePtr; @@ -1462,10 +1459,8 @@ TclPreventAliasLoop( if (aliasCmdPtr->objProc != AliasObjCmd) { return TCL_OK; } - nextAliasPtr = aliasCmdPtr->objClientData; + nextAliasPtr = (Alias *)aliasCmdPtr->objClientData; } - - /* NOTREACHED */ } /* @@ -1505,7 +1500,7 @@ AliasCreate( Tcl_Obj **prefv; int isNew, i; - aliasPtr = ckalloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *)); + aliasPtr = (Alias *)ckalloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *)); aliasPtr->token = namePtr; Tcl_IncrRefCount(aliasPtr->token); aliasPtr->targetInterp = parentInterp; @@ -1613,7 +1608,7 @@ AliasCreate( * interp alias {} foo {} zop # Now recreate "foo"... */ - targetPtr = ckalloc(sizeof(Target)); + targetPtr = (Target *)ckalloc(sizeof(Target)); targetPtr->childCmd = aliasPtr->childCmd; targetPtr->childInterp = childInterp; @@ -1674,7 +1669,7 @@ AliasDelete( TclGetString(namePtr), NULL); return TCL_ERROR; } - aliasPtr = Tcl_GetHashValue(hPtr); + aliasPtr = (Alias *)Tcl_GetHashValue(hPtr); Tcl_DeleteCommandFromToken(childInterp, aliasPtr->childCmd); return TCL_OK; } @@ -1719,7 +1714,7 @@ AliasDescribe( if (hPtr == NULL) { return TCL_OK; } - aliasPtr = Tcl_GetHashValue(hPtr); + aliasPtr = (Alias *)Tcl_GetHashValue(hPtr); prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr); Tcl_SetObjResult(interp, prefixPtr); return TCL_OK; @@ -1757,7 +1752,7 @@ AliasList( entryPtr = Tcl_FirstHashEntry(&childPtr->aliasTable, &hashSearch); for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) { - aliasPtr = Tcl_GetHashValue(entryPtr); + aliasPtr = (Alias *)Tcl_GetHashValue(entryPtr); Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->token); } Tcl_SetObjResult(interp, resultPtr); @@ -1793,7 +1788,7 @@ AliasNRCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument vector. */ { - Alias *aliasPtr = clientData; + Alias *aliasPtr = (Alias *)clientData; int prefc, cmdc, i; Tcl_Obj **prefv, **cmdv; Tcl_Obj *listPtr; @@ -1842,7 +1837,7 @@ AliasObjCmd( Tcl_Obj *const objv[]) /* Argument vector. */ { #define ALIAS_CMDV_PREALLOC 10 - Alias *aliasPtr = clientData; + Alias *aliasPtr = (Alias *)clientData; Tcl_Interp *targetInterp = aliasPtr->targetInterp; int result, prefc, cmdc, i; Tcl_Obj **prefv, **cmdv; @@ -1861,7 +1856,7 @@ AliasObjCmd( if (cmdc <= ALIAS_CMDV_PREALLOC) { cmdv = cmdArr; } else { - cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *)); + cmdv = (Tcl_Obj **)TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *)); } memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *)); @@ -1947,7 +1942,7 @@ static void AliasObjCmdDeleteProc( ClientData clientData) /* The alias record for this alias. */ { - Alias *aliasPtr = clientData; + Alias *aliasPtr = (Alias *)clientData; Target *targetPtr; int i; Tcl_Obj **objv; @@ -2123,7 +2118,7 @@ TclSetChildCancelFlags( hPtr = Tcl_FirstHashEntry(&parentPtr->childTable, &hashSearch); for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { - childPtr = Tcl_GetHashValue(hPtr); + childPtr = (Child *)Tcl_GetHashValue(hPtr); iPtr = (Interp *) childPtr->childInterp; if (iPtr == NULL) { @@ -2188,7 +2183,7 @@ Tcl_GetInterpPath( return TCL_ERROR; } Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(interp), - Tcl_NewStringObj(Tcl_GetHashKey(&iiPtr->parent.childTable, + Tcl_NewStringObj((const char *)Tcl_GetHashKey(&iiPtr->parent.childTable, iiPtr->child.childEntryPtr), -1)); return TCL_OK; } @@ -2236,7 +2231,7 @@ GetInterp( searchInterp = NULL; break; } - childPtr = Tcl_GetHashValue(hPtr); + childPtr = (Child *)Tcl_GetHashValue(hPtr); searchInterp = childPtr->childInterp; if (searchInterp == NULL) { break; @@ -2462,7 +2457,7 @@ NRChildCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Interp *childInterp = clientData; + Tcl_Interp *childInterp = (Tcl_Interp *)clientData; int index; static const char *const options[] = { "alias", "aliases", "bgerror", "debug", @@ -2470,7 +2465,7 @@ NRChildCmd( "issafe", "invokehidden", "limit", "marktrusted", "recursionlimit", NULL }; - enum options { + enum childCmdOptionsEnum { OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_DEBUG, OPT_EVAL, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, @@ -2490,7 +2485,7 @@ NRChildCmd( return TCL_ERROR; } - switch ((enum options) index) { + switch ((enum childCmdOptionsEnum) index) { case OPT_ALIAS: if (objc > 2) { if (objc == 3) { @@ -2666,7 +2661,7 @@ ChildObjCmdDeleteProc( ClientData clientData) /* The ChildRecord for the command. */ { Child *childPtr; /* Interim storage for Child record. */ - Tcl_Interp *childInterp = clientData; + Tcl_Interp *childInterp = (Tcl_Interp *)clientData; /* And for a child interp. */ childPtr = &((InterpInfo *) ((Interp *) childInterp)->interpInfo)->child; @@ -2995,7 +2990,7 @@ ChildHidden( Tcl_Interp *interp, /* Interp for data return. */ Tcl_Interp *childInterp) /* Interp whose hidden commands to query. */ { - Tcl_Obj *listObjPtr; /* Local object pointer. */ + Tcl_Obj *listObjPtr; /* Local object pointer. */ Tcl_HashTable *hTblPtr; /* For local searches. */ Tcl_HashEntry *hPtr; /* For local searches. */ Tcl_HashSearch hSearch; /* For local searches. */ @@ -3007,7 +3002,7 @@ ChildHidden( hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { Tcl_ListObjAppendElement(NULL, listObjPtr, - Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1)); + Tcl_NewStringObj((const char *)Tcl_GetHashKey(hTblPtr, hPtr), -1)); } } Tcl_SetObjResult(interp, listObjPtr); @@ -3530,7 +3525,7 @@ Tcl_LimitAddHandler( * Allocate a handler record. */ - handlerPtr = ckalloc(sizeof(LimitHandler)); + handlerPtr = (LimitHandler *)ckalloc(sizeof(LimitHandler)); handlerPtr->flags = 0; handlerPtr->handlerProc = handlerProc; handlerPtr->clientData = clientData; @@ -3987,8 +3982,8 @@ static void TimeLimitCallback( ClientData clientData) { - Tcl_Interp *interp = clientData; - Interp *iPtr = clientData; + Tcl_Interp *interp = (Tcl_Interp *)clientData; + Interp *iPtr = (Interp *)clientData; int code; Tcl_Preserve(interp); @@ -4131,7 +4126,7 @@ static void DeleteScriptLimitCallback( ClientData clientData) { - ScriptLimitCallback *limitCBPtr = clientData; + ScriptLimitCallback *limitCBPtr = (ScriptLimitCallback *)clientData; Tcl_DecrRefCount(limitCBPtr->scriptObj); if (limitCBPtr->entryPtr != NULL) { @@ -4163,7 +4158,7 @@ CallScriptLimitCallback( ClientData clientData, Tcl_Interp *interp) /* Interpreter which failed the limit */ { - ScriptLimitCallback *limitCBPtr = clientData; + ScriptLimitCallback *limitCBPtr = (ScriptLimitCallback *)clientData; int code; if (Tcl_InterpDeleted(limitCBPtr->interp)) { @@ -4231,13 +4226,13 @@ SetScriptLimitCallback( hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, &key, &isNew); if (!isNew) { - limitCBPtr = Tcl_GetHashValue(hashPtr); + limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hashPtr); limitCBPtr->entryPtr = NULL; Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback, limitCBPtr); } - limitCBPtr = ckalloc(sizeof(ScriptLimitCallback)); + limitCBPtr = (ScriptLimitCallback *)ckalloc(sizeof(ScriptLimitCallback)); limitCBPtr->interp = interp; limitCBPtr->scriptObj = scriptObj; limitCBPtr->entryPtr = hashPtr; @@ -4426,7 +4421,7 @@ ChildCommandLimitCmd( key.type = TCL_LIMIT_COMMANDS; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { - limitCBPtr = Tcl_GetHashValue(hPtr); + limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), limitCBPtr->scriptObj); @@ -4468,7 +4463,7 @@ ChildCommandLimitCmd( key.type = TCL_LIMIT_COMMANDS; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { - limitCBPtr = Tcl_GetHashValue(hPtr); + limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { Tcl_SetObjResult(interp, limitCBPtr->scriptObj); } @@ -4502,7 +4497,7 @@ ChildCommandLimitCmd( switch ((enum Options) index) { case OPT_CMD: scriptObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen); + (void) Tcl_GetStringFromObj(scriptObj, &scriptLen); break; case OPT_GRAN: granObj = objv[i+1]; @@ -4614,7 +4609,7 @@ ChildTimeLimitCmd( key.type = TCL_LIMIT_TIME; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { - limitCBPtr = Tcl_GetHashValue(hPtr); + limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[0], -1), limitCBPtr->scriptObj); @@ -4662,7 +4657,7 @@ ChildTimeLimitCmd( key.type = TCL_LIMIT_TIME; hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key); if (hPtr != NULL) { - limitCBPtr = Tcl_GetHashValue(hPtr); + limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hPtr); if (limitCBPtr != NULL && limitCBPtr->scriptObj != NULL) { Tcl_SetObjResult(interp, limitCBPtr->scriptObj); } @@ -4754,9 +4749,15 @@ ChildTimeLimitCmd( if (TclGetWideIntFromObj(interp, objv[i+1], &sec) != TCL_OK) { return TCL_ERROR; } + if (sec > LONG_MAX) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "seconds must be between 0 and %ld", LONG_MAX)); + goto badValue; + } if (sec < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "seconds must be at least 0", -1)); + badValue: Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", NULL); return TCL_ERROR; diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index eccca78..7290bd1 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -31,7 +31,7 @@ * limited to a single interpreter. */ -typedef struct ThreadSpecificData { +typedef struct { long numNsCreated; /* Count of the number of namespaces created * within the thread. This value is used as a * unique id for each namespace. Cannot be @@ -89,51 +89,30 @@ static char * EstablishErrorInfoTraces(ClientData clientData, static void FreeNsNameInternalRep(Tcl_Obj *objPtr); static int GetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); -static int InvokeImportedCmd(ClientData clientData, - Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int InvokeImportedNRCmd(ClientData clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); -static int NamespaceChildrenCmd(ClientData dummy, - Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); -static int NamespaceCodeCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int NamespaceCurrentCmd(ClientData dummy, - Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); -static int NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int NRNamespaceEvalCmd(ClientData dummy, - Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); -static int NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int NamespaceForgetCmd(ClientData dummy,Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc InvokeImportedCmd; +static Tcl_ObjCmdProc NamespaceChildrenCmd; +static Tcl_ObjCmdProc NamespaceCodeCmd; +static Tcl_ObjCmdProc NamespaceCurrentCmd; +static Tcl_ObjCmdProc NamespaceDeleteCmd; +static Tcl_ObjCmdProc NamespaceEvalCmd; +static Tcl_ObjCmdProc NRNamespaceEvalCmd; +static Tcl_ObjCmdProc NamespaceExistsCmd; +static Tcl_ObjCmdProc NamespaceExportCmd; +static Tcl_ObjCmdProc NamespaceForgetCmd; static void NamespaceFree(Namespace *nsPtr); -static int NamespaceImportCmd(ClientData dummy,Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int NamespaceInscopeCmd(ClientData dummy, - Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); -static int NRNamespaceInscopeCmd(ClientData dummy, - Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); -static int NamespaceOriginCmd(ClientData dummy,Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int NamespaceParentCmd(ClientData dummy,Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int NamespacePathCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int NamespaceQualifiersCmd(ClientData dummy, - Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); -static int NamespaceTailCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int NamespaceUpvarCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int NamespaceUnknownCmd(ClientData dummy, - Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); -static int NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc NamespaceImportCmd; +static Tcl_ObjCmdProc NamespaceInscopeCmd; +static Tcl_ObjCmdProc NRNamespaceInscopeCmd; +static Tcl_ObjCmdProc NamespaceOriginCmd; +static Tcl_ObjCmdProc NamespaceParentCmd; +static Tcl_ObjCmdProc NamespacePathCmd; +static Tcl_ObjCmdProc NamespaceQualifiersCmd; +static Tcl_ObjCmdProc NamespaceTailCmd; +static Tcl_ObjCmdProc NamespaceUpvarCmd; +static Tcl_ObjCmdProc NamespaceUnknownCmd; +static Tcl_ObjCmdProc NamespaceWhichCmd; static int SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UnlinkNsPath(Namespace *nsPtr); @@ -320,7 +299,6 @@ Tcl_PushCallFrame( if (nsPtr->flags & NS_DEAD) { Tcl_Panic("Trying to push call frame for dead namespace"); - /*NOTREACHED*/ } } @@ -465,7 +443,7 @@ TclPushStackFrame( * treated as references to namespace * variables. */ { - *framePtrPtr = TclStackAlloc(interp, sizeof(CallFrame)); + *framePtrPtr = (Tcl_CallFrame *)TclStackAlloc(interp, sizeof(CallFrame)); return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr, isProcCallFrame); } @@ -770,9 +748,9 @@ Tcl_CreateNamespace( */ doCreate: - nsPtr = ckalloc(sizeof(Namespace)); + nsPtr = (Namespace *)ckalloc(sizeof(Namespace)); nameLen = strlen(simpleName) + 1; - nsPtr->name = ckalloc(nameLen); + nsPtr->name = (char *)ckalloc(nameLen); memcpy(nsPtr->name, simpleName, nameLen); nsPtr->fullName = NULL; /* Set below. */ nsPtr->clientData = clientData; @@ -860,7 +838,7 @@ Tcl_CreateNamespace( name = Tcl_DStringValue(namePtr); nameLen = Tcl_DStringLength(namePtr); - nsPtr->fullName = ckalloc(nameLen + 1); + nsPtr->fullName = (char *)ckalloc(nameLen + 1); memcpy(nsPtr->fullName, name, nameLen + 1); Tcl_DStringFree(&buffer1); @@ -952,7 +930,7 @@ Tcl_DeleteNamespace( for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); entryPtr != NULL;) { - cmdPtr = Tcl_GetHashValue(entryPtr); + cmdPtr = (Command *)Tcl_GetHashValue(entryPtr); if (cmdPtr->nreProc == TclNRInterpCoroutine) { Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, (Tcl_Command) cmdPtr); @@ -1131,14 +1109,14 @@ TclTeardownNamespace( while (nsPtr->cmdTable.numEntries > 0) { int length = nsPtr->cmdTable.numEntries; - Command **cmds = TclStackAlloc((Tcl_Interp *) iPtr, + Command **cmds = (Command **)TclStackAlloc((Tcl_Interp *) iPtr, sizeof(Command *) * length); i = 0; for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { - cmds[i] = Tcl_GetHashValue(entryPtr); + cmds[i] = (Command *)Tcl_GetHashValue(entryPtr); cmds[i]->refCount++; i++; } @@ -1445,7 +1423,7 @@ Tcl_Export( if (neededElems > nsPtr->maxExportPatterns) { nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ? 2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS; - nsPtr->exportArrayPtr = ckrealloc(nsPtr->exportArrayPtr, + nsPtr->exportArrayPtr = (char **)ckrealloc(nsPtr->exportArrayPtr, sizeof(char *) * nsPtr->maxExportPatterns); } @@ -1454,7 +1432,7 @@ Tcl_Export( */ len = strlen(pattern); - patternCpy = ckalloc(len + 1); + patternCpy = (char *)ckalloc(len + 1); memcpy(patternCpy, pattern, len + 1); nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; @@ -1665,7 +1643,7 @@ Tcl_Import( } for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search); (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { - char *cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr); + char *cmdName = (char *)Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr); if (Tcl_StringMatch(cmdName, simplePattern) && DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr, @@ -1752,13 +1730,13 @@ DoImport( * namespace would create a cycle of imported command references. */ - cmdPtr = Tcl_GetHashValue(hPtr); + cmdPtr = (Command *)Tcl_GetHashValue(hPtr); if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) { - Command *overwrite = Tcl_GetHashValue(found); + Command *overwrite = (Command *)Tcl_GetHashValue(found); Command *linkCmd = cmdPtr; while (linkCmd->deleteProc == DeleteImportedCmd) { - dataPtr = linkCmd->objClientData; + dataPtr = (ImportedCmdData *)linkCmd->objClientData; linkCmd = dataPtr->realCmdPtr; if (overwrite == linkCmd) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1772,7 +1750,7 @@ DoImport( } } - dataPtr = ckalloc(sizeof(ImportedCmdData)); + dataPtr = (ImportedCmdData *)ckalloc(sizeof(ImportedCmdData)); importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), InvokeImportedCmd, InvokeImportedNRCmd, dataPtr, DeleteImportedCmd); @@ -1786,15 +1764,15 @@ DoImport( * and add it to the import ref list in the "real" command. */ - refPtr = ckalloc(sizeof(ImportRef)); + refPtr = (ImportRef *)ckalloc(sizeof(ImportRef)); refPtr->importedCmdPtr = (Command *) importedCmd; refPtr->nextPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = refPtr; } else { - Command *overwrite = Tcl_GetHashValue(found); + Command *overwrite = (Command *)Tcl_GetHashValue(found); if (overwrite->deleteProc == DeleteImportedCmd) { - ImportedCmdData *dataPtr = overwrite->objClientData; + ImportedCmdData *dataPtr = (ImportedCmdData *)overwrite->objClientData; if (dataPtr->realCmdPtr == Tcl_GetHashValue(hPtr)) { /* @@ -1888,7 +1866,7 @@ Tcl_ForgetImport( if (TclMatchIsTrivial(simplePattern)) { hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); if (hPtr != NULL) { - Command *cmdPtr = Tcl_GetHashValue(hPtr); + Command *cmdPtr = (Command *)Tcl_GetHashValue(hPtr); if (cmdPtr && (cmdPtr->deleteProc == DeleteImportedCmd)) { Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); @@ -1898,12 +1876,12 @@ Tcl_ForgetImport( } for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { - Command *cmdPtr = Tcl_GetHashValue(hPtr); + Command *cmdPtr = (Command *)Tcl_GetHashValue(hPtr); if (cmdPtr->deleteProc != DeleteImportedCmd) { continue; } - cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr); + cmdName = (char *)Tcl_GetHashKey(&nsPtr->cmdTable, hPtr); if (Tcl_StringMatch(cmdName, simplePattern)) { Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); } @@ -1918,7 +1896,7 @@ Tcl_ForgetImport( for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { Tcl_CmdInfo info; - Tcl_Command token = Tcl_GetHashValue(hPtr); + Tcl_Command token = (Tcl_Command)Tcl_GetHashValue(hPtr); Tcl_Command origin = TclGetOriginalCommand(token); if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) { @@ -1931,7 +1909,7 @@ Tcl_ForgetImport( */ Command *cmdPtr = (Command *) token; - ImportedCmdData *dataPtr = cmdPtr->objClientData; + ImportedCmdData *dataPtr = (ImportedCmdData *)cmdPtr->objClientData; Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr; if (firstToken == origin) { @@ -1986,7 +1964,7 @@ TclGetOriginalCommand( } while (cmdPtr->deleteProc == DeleteImportedCmd) { - dataPtr = cmdPtr->objClientData; + dataPtr = (ImportedCmdData *)cmdPtr->objClientData; cmdPtr = dataPtr->realCmdPtr; } return (Tcl_Command) cmdPtr; @@ -2019,7 +1997,7 @@ InvokeImportedNRCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - ImportedCmdData *dataPtr = clientData; + ImportedCmdData *dataPtr = (ImportedCmdData *)clientData; Command *realCmdPtr = dataPtr->realCmdPtr; TclSkipTailcall(interp); @@ -2064,7 +2042,7 @@ DeleteImportedCmd( ClientData clientData) /* Points to the imported command's * ImportedCmdData structure. */ { - ImportedCmdData *dataPtr = clientData; + ImportedCmdData *dataPtr = (ImportedCmdData *)clientData; Command *realCmdPtr = dataPtr->realCmdPtr; Command *selfPtr = dataPtr->selfPtr; ImportRef *refPtr, *prevPtr; @@ -2340,7 +2318,7 @@ TclGetNamespaceForQualName( } #endif if (entryPtr != NULL) { - nsPtr = Tcl_GetHashValue(entryPtr); + nsPtr = (Namespace *)Tcl_GetHashValue(entryPtr); } else if (flags & TCL_CREATE_NS_IF_UNKNOWN) { Tcl_CallFrame *framePtr; @@ -2375,7 +2353,7 @@ TclGetNamespaceForQualName( } #endif if (entryPtr != NULL) { - altNsPtr = Tcl_GetHashValue(entryPtr); + altNsPtr = (Namespace *)Tcl_GetHashValue(entryPtr); } else { altNsPtr = NULL; } @@ -2625,7 +2603,7 @@ Tcl_FindCommand( || !(realNsPtr->flags & NS_DYING)) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { - cmdPtr = Tcl_GetHashValue(entryPtr); + cmdPtr = (Command *)Tcl_GetHashValue(entryPtr); } } } @@ -2646,7 +2624,7 @@ Tcl_FindCommand( && !(realNsPtr->flags & NS_DYING)) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { - cmdPtr = Tcl_GetHashValue(entryPtr); + cmdPtr = (Command *)Tcl_GetHashValue(entryPtr); } } } @@ -2664,7 +2642,7 @@ Tcl_FindCommand( && !(realNsPtr->flags & NS_DYING)) { entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); if (entryPtr != NULL) { - cmdPtr = Tcl_GetHashValue(entryPtr); + cmdPtr = (Command *)Tcl_GetHashValue(entryPtr); } } } @@ -2686,7 +2664,7 @@ Tcl_FindCommand( entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable, simpleName); if (entryPtr != NULL) { - cmdPtr = Tcl_GetHashValue(entryPtr); + cmdPtr = (Command *)Tcl_GetHashValue(entryPtr); } } } @@ -2750,7 +2728,7 @@ TclResetShadowedCmdRefs( int found, i; int trailFront = -1; int trailSize = 5; /* Formerly NUM_TRAIL_ELEMS. */ - Namespace **trailPtr = TclStackAlloc(interp, + Namespace **trailPtr = (Namespace **)TclStackAlloc(interp, trailSize * sizeof(Namespace *)); /* @@ -2770,7 +2748,7 @@ TclResetShadowedCmdRefs( * cmdName. */ - cmdName = Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr); + cmdName = (char *)Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr); for (nsPtr=newCmdPtr->nsPtr ; (nsPtr!=NULL) && (nsPtr!=globalNsPtr) ; nsPtr=nsPtr->parentPtr) { /* @@ -2799,7 +2777,7 @@ TclResetShadowedCmdRefs( } #endif if (hPtr != NULL) { - shadowNsPtr = Tcl_GetHashValue(hPtr); + shadowNsPtr = (Namespace *)Tcl_GetHashValue(hPtr); } else { found = 0; break; @@ -2840,7 +2818,7 @@ TclResetShadowedCmdRefs( if (trailFront == trailSize) { int newSize = 2 * trailSize; - trailPtr = TclStackRealloc(interp, trailPtr, + trailPtr = (Namespace **)TclStackRealloc(interp, trailPtr, newSize * sizeof(Namespace *)); trailSize = newSize; } @@ -3065,7 +3043,7 @@ NamespaceChildrenCmd( entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search); #endif while (entryPtr != NULL) { - childNsPtr = Tcl_GetHashValue(entryPtr); + childNsPtr = (Namespace *)Tcl_GetHashValue(entryPtr); if ((pattern == NULL) || Tcl_StringMatch(childNsPtr->fullName, pattern)) { elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1); @@ -3428,13 +3406,13 @@ NsEval_Callback( Tcl_Interp *interp, int result) { - Tcl_Namespace *namespacePtr = data[0]; + Tcl_Namespace *namespacePtr = (Tcl_Namespace *)data[0]; if (result == TCL_ERROR) { int length = strlen(namespacePtr->fullName); int limit = 200; int overflow = (length > limit); - char *cmd = data[1]; + char *cmd = (char *)data[1]; Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (in namespace %s \"%.*s%s\" script line %d)", @@ -3550,7 +3528,7 @@ NamespaceExportCmd( Tcl_Obj *listPtr; TclNewObj(listPtr); - (void) Tcl_AppendExportList(interp, NULL, listPtr); + (void)Tcl_AppendExportList(interp, NULL, listPtr); Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -3716,11 +3694,11 @@ NamespaceImportCmd( TclNewObj(listPtr); for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - Command *cmdPtr = Tcl_GetHashValue(hPtr); + Command *cmdPtr = (Command *)Tcl_GetHashValue(hPtr); if (cmdPtr->deleteProc == DeleteImportedCmd) { Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj( - Tcl_GetHashKey(&nsPtr->cmdTable, hPtr) ,-1)); + (char *)Tcl_GetHashKey(&nsPtr->cmdTable, hPtr) ,-1)); } } Tcl_SetObjResult(interp, listPtr); @@ -4048,7 +4026,7 @@ NamespacePathCmd( goto badNamespace; } if (nsObjc != 0) { - namespaceList = TclStackAlloc(interp, + namespaceList = (Tcl_Namespace **)TclStackAlloc(interp, sizeof(Tcl_Namespace *) * nsObjc); for (i=0 ; iinternalRep.twoPtrValue.ptr1; + ResolvedNsName *resNamePtr = (ResolvedNsName *)objPtr->internalRep.twoPtrValue.ptr1; /* * Decrement the reference count of the namespace. If there are no more @@ -4812,12 +4790,12 @@ SetNsNameFromAny( } nsPtr->refCount++; - resNamePtr = ckalloc(sizeof(ResolvedNsName)); + resNamePtr = (ResolvedNsName *)ckalloc(sizeof(ResolvedNsName)); resNamePtr->nsPtr = nsPtr; if ((name[0] == ':') && (name[1] == ':')) { resNamePtr->refNsPtr = NULL; } else { - resNamePtr->refNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + resNamePtr->refNsPtr = (Namespace *)Tcl_GetCurrentNamespace(interp); } resNamePtr->refCount = 1; TclFreeIntRep(objPtr); @@ -4874,7 +4852,7 @@ TclGetNamespaceChildTable( return &nPtr->childTable; #else if (nPtr->childTablePtr == NULL) { - nPtr->childTablePtr = ckalloc(sizeof(Tcl_HashTable)); + nPtr->childTablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(nPtr->childTablePtr, TCL_STRING_KEYS); } return nPtr->childTablePtr; @@ -4963,7 +4941,7 @@ TclLogCommandInfo( } else { Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); - VarTrace *tracePtr = Tcl_GetHashValue(hPtr); + VarTrace *tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr); if (tracePtr->traceProc != EstablishErrorInfoTraces) { /* -- cgit v0.12 From ca4e244cca3e93fb8689fe1cef85954da16ff989 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Wed, 25 Jan 2023 02:52:24 +0000 Subject: Test TableFromUtfProc() with strict handling of encoding errors. --- generic/tclEncoding.c | 2 +- tests/encoding.test | 8 ++++++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index d10d9ca..5ba7763 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -3199,7 +3199,7 @@ TableFromUtfProc( word = fromUnicode[(ch >> 8)][ch & 0xFF]; if ((word == 0) && (ch != 0)) { - if ((STOPONERROR) && (flags & TCL_ENCODING_CHAR_LIMIT)) { + if ((STOPONERROR)) { result = TCL_CONVERT_UNKNOWN; break; } diff --git a/tests/encoding.test b/tests/encoding.test index a1d129e..d9382e4 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -513,8 +513,11 @@ test encoding-17.10 {Utf32ToUtfProc} -body { encoding convertfrom -nocomplain utf-32 "\xFF\xFF\xFF\xFF" } -result \uFFFD -test encoding-18.1 {TableToUtfProc} { -} {} + +test encoding-18.1 {TableToUtfProc error on invalid input with -strict} -body { + list [catch {encoding convertto -strict jis0208 \\} res] $res +} -result {1 {unexpected character at index 0: 'U+00005C'}} + test encoding-19.1 {TableFromUtfProc} { } {} @@ -915,6 +918,7 @@ test encoding-29.0 {get encoding nul terminator lengths} -constraints { [testencoding nullength ksc5601] } -result {1 2 4 2 2} + # cleanup namespace delete ::tcl::test::encoding ::tcltest::cleanupTests -- cgit v0.12 From d271c9f407a60528785465284451c752639b1128 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Thu, 26 Jan 2023 23:55:30 +0000 Subject: Fix for [ee08ed090b0a5408], sporadic segmentation fault in coroutine.test/coroutine-7.4. --- generic/tclBasic.c | 1 + 1 file changed, 1 insertion(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 80dc416..bea5996 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -10520,6 +10520,7 @@ TclNRCoroutineObjCmd( corPtr->running.lineLABCPtr = corPtr->lineLABCPtr; corPtr->stackLevel = NULL; corPtr->auxNumLevels = 0; + corPtr->yieldPtr = NULL; /* * Create the coro's execEnv, switch to it to push the exit and coro -- cgit v0.12 From 8ea5f2cfcee413e2281a0434827d999f43743f6c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 27 Jan 2023 08:17:34 +0000 Subject: Update fcopy documentation regarding -size argument --- doc/fcopy.n | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/doc/fcopy.n b/doc/fcopy.n index d39c803..57f9968 100644 --- a/doc/fcopy.n +++ b/doc/fcopy.n @@ -26,8 +26,9 @@ network sockets. The \fBfcopy\fR command transfers data from \fIinchan\fR until end of file or \fIsize\fR bytes or characters have been -transferred; \fIsize\fR is in bytes if the two channels are using the -same encoding, and is in characters otherwise. +transferred; \fIsize\fR is in bytes if the input channel is in binary mode, +or if the two channels are using the same encoding and -strict is not specified. +Otherwise, size is in characters. If no \fB\-size\fR argument is given, then the copy goes until end of file. All the data read from \fIinchan\fR is copied to \fIoutchan\fR. -- cgit v0.12 From 06de3a9ba1e4397a226e168a72c9da63c2a6f30a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 27 Jan 2023 14:23:08 +0000 Subject: new testcase encoding-18.1. Testcase cleanup --- tests/encoding.test | 151 ++++++++++++++++++++++++++-------------------------- 1 file changed, 76 insertions(+), 75 deletions(-) diff --git a/tests/encoding.test b/tests/encoding.test index aaba01e..f558e01 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -3,7 +3,7 @@ # No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -65,12 +65,12 @@ test encoding-1.2 {Tcl_GetEncoding: existing encoding} {testencoding} { return $x } {{fromutf }} test encoding-1.3 {Tcl_GetEncoding: load encoding} { - list [encoding convertto jis0208 \u4e4e] \ + list [encoding convertto jis0208 \u4E4E] \ [encoding convertfrom jis0208 8C] -} "8C \u4e4e" +} "8C \u4E4E" test encoding-2.1 {Tcl_FreeEncoding: refcount == 0} { - encoding convertto jis0208 \u4e4e + encoding convertto jis0208 \u4E4E } {8C} test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup { set system [encoding system] @@ -78,15 +78,15 @@ test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup { } -constraints {testencoding} -body { encoding system shiftjis ;# incr ref count encoding dirs [list [pwd]] - set x [encoding convertto shiftjis \u4e4e] ;# old one found + set x [encoding convertto shiftjis \u4E4E] ;# old one found encoding system iso8859-1 llength shiftjis ;# Shimmer away any cache of Tcl_Encoding - lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg + lappend x [catch {encoding convertto shiftjis \u4E4E} msg] $msg } -cleanup { encoding system iso8859-1 encoding dirs $path encoding system $system -} -result "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}" +} -result "\x8C\xC1 1 {unknown encoding \"shiftjis\"}" test encoding-3.1 {Tcl_GetEncodingName, NULL} -setup { set old [encoding system] @@ -138,7 +138,7 @@ test encoding-5.1 {Tcl_SetSystemEncoding} -setup { set old [encoding system] } -body { encoding system jis0208 - encoding convertto \u4e4e + encoding convertto \u4E4E } -cleanup { encoding system iso8859-1 encoding system $old @@ -170,7 +170,7 @@ test encoding-6.2 {Tcl_CreateEncoding: replace encoding} {testencoding} { test encoding-7.1 {Tcl_ExternalToUtfDString: small buffer} { encoding convertfrom jis0208 8c8c8c8c -} "\u543e\u543e\u543e\u543e" +} "\u543E\u543E\u543E\u543E" test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} { set a 8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C8C append a $a @@ -179,12 +179,12 @@ test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} { append a $a set x [encoding convertfrom jis0208 $a] list [string length $x] [string index $x 0] -} "512 \u4e4e" +} "512 \u4E4E" test encoding-8.1 {Tcl_ExternalToUtf} { set f [open [file join [temporaryDirectory] dummy] w] fconfigure $f -translation binary -encoding iso8859-1 - puts -nonewline $f "ab\x8c\xc1g" + puts -nonewline $f "ab\x8C\xC1g" close $f set f [open [file join [temporaryDirectory] dummy] r] fconfigure $f -translation binary -encoding shiftjis @@ -192,13 +192,13 @@ test encoding-8.1 {Tcl_ExternalToUtf} { close $f file delete [file join [temporaryDirectory] dummy] return $x -} "ab\u4e4eg" +} "ab\u4E4Eg" test encoding-9.1 {Tcl_UtfToExternalDString: small buffer} { - encoding convertto jis0208 "\u543e\u543e\u543e\u543e" + encoding convertto jis0208 "\u543E\u543E\u543E\u543E" } {8c8c8c8c} test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} { - set a \u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e + set a \u4E4E\u4E4E\u4E4E\u4E4E\u4E4E\u4E4E\u4E4E\u4E4E append a $a append a $a append a $a @@ -212,7 +212,7 @@ test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} { test encoding-10.1 {Tcl_UtfToExternal} { set f [open [file join [temporaryDirectory] dummy] w] fconfigure $f -translation binary -encoding shiftjis - puts -nonewline $f "ab\u4e4eg" + puts -nonewline $f "ab\u4E4Eg" close $f set f [open [file join [temporaryDirectory] dummy] r] fconfigure $f -translation binary -encoding iso8859-1 @@ -220,7 +220,7 @@ test encoding-10.1 {Tcl_UtfToExternal} { close $f file delete [file join [temporaryDirectory] dummy] return $x -} "ab\x8c\xc1g" +} "ab\x8C\xC1g" proc viewable {str} { set res "" @@ -228,7 +228,7 @@ proc viewable {str} { if {[string is print $c] && [string is ascii $c]} { append res $c } else { - append res "\\u[format %4.4x [scan $c %c]]" + append res "\\u[format %4.4X [scan $c %c]]" } } return "$str ($res)" @@ -240,26 +240,26 @@ test encoding-11.1 {LoadEncodingFile: unknown encoding} {testencoding} { encoding system iso8859-1 encoding dirs {} llength jis0208 ;# Shimmer any cached Tcl_Encoding in shared literal - set x [list [catch {encoding convertto jis0208 \u4e4e} msg] $msg] + set x [list [catch {encoding convertto jis0208 \u4E4E} msg] $msg] encoding dirs $path encoding system $system - lappend x [encoding convertto jis0208 \u4e4e] + lappend x [encoding convertto jis0208 \u4E4E] } {1 {unknown encoding "jis0208"} 8C} test encoding-11.2 {LoadEncodingFile: single-byte} { - encoding convertfrom jis0201 \xa1 -} "\uff61" + encoding convertfrom jis0201 \xA1 +} \uFF61 test encoding-11.3 {LoadEncodingFile: double-byte} { encoding convertfrom jis0208 8C -} "\u4e4e" +} \u4E4E test encoding-11.4 {LoadEncodingFile: multi-byte} { - encoding convertfrom shiftjis \x8c\xc1 -} "\u4e4e" + encoding convertfrom shiftjis \x8C\xC1 +} \u4E4E test encoding-11.5 {LoadEncodingFile: escape file} { - viewable [encoding convertto iso2022 \u4e4e] -} [viewable "\x1b\$B8C\x1b(B"] + viewable [encoding convertto iso2022 \u4E4E] +} [viewable "\x1B\$B8C\x1B(B"] test encoding-11.5.1 {LoadEncodingFile: escape file} { - viewable [encoding convertto iso2022-jp \u4e4e] -} [viewable "\x1b\$B8C\x1b(B"] + viewable [encoding convertto iso2022-jp \u4E4E] +} [viewable "\x1B\$B8C\x1B(B"] test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} -setup { set system [encoding system] set path [encoding dirs] @@ -273,7 +273,7 @@ test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} fconfigure $f -translation binary puts $f "abcdefghijklmnop" close $f - encoding convertto splat \u4e4e + encoding convertto splat \u4E4E } -returnCodes error -cleanup { file delete [file join [temporaryDirectory] tmp encoding splat.enc] removeDirectory [file join tmp encoding] @@ -289,45 +289,45 @@ test encoding-12.1 {LoadTableEncoding: normal encoding} { set x [encoding convertto iso8859-3 \u0120] append x [encoding convertto iso8859-3 \xD5] append x [encoding convertfrom iso8859-3 \xD5] -} "\xd5?\u120" +} \xD5?\u0120 test encoding-12.2 {LoadTableEncoding: single-byte encoding} { set x [encoding convertto iso8859-3 ab\u0120g] append x [encoding convertfrom iso8859-3 ab\xD5g] -} "ab\xd5gab\u120g" +} ab\xD5gab\u0120g test encoding-12.3 {LoadTableEncoding: multi-byte encoding} { set x [encoding convertto shiftjis ab\u4E4Eg] - append x [encoding convertfrom shiftjis ab\x8c\xc1g] -} "ab\x8c\xc1gab\u4e4eg" + append x [encoding convertfrom shiftjis ab\x8C\xC1g] +} ab\x8C\xC1gab\u4E4Eg test encoding-12.4 {LoadTableEncoding: double-byte encoding} { - set x [encoding convertto jis0208 \u4e4e\u3b1] + set x [encoding convertto jis0208 \u4E4E\u03B1] append x [encoding convertfrom jis0208 8C&A] -} "8C&A\u4e4e\u3b1" +} 8C&A\u4E4E\u03B1 test encoding-12.5 {LoadTableEncoding: symbol encoding} { - set x [encoding convertto symbol \u3b3] - append x [encoding convertto symbol \u67] - append x [encoding convertfrom symbol \x67] -} "\x67\x67\u3b3" + set x [encoding convertto symbol \u03B3] + append x [encoding convertto symbol g] + append x [encoding convertfrom symbol g] +} gg\u03B3 test encoding-12.6 {LoadTableEncoding: overflow in char value} ucs2 { encoding convertto iso8859-3 \U010000 -} "?" +} ? test encoding-13.1 {LoadEscapeTable} { - viewable [set x [encoding convertto iso2022 ab\u4e4e\u68d9g]] -} [viewable "ab\x1b\$B8C\x1b\$\(DD%\x1b(Bg"] + viewable [set x [encoding convertto iso2022 ab\u4E4E\u68D9g]] +} [viewable "ab\x1B\$B8C\x1B\$\(DD%\x1B(Bg"] test encoding-14.1 {BinaryProc} { encoding convertto identity \x12\x34\x56\xff\x69 } "\x12\x34\x56\xc3\xbf\x69" test encoding-15.1 {UtfToUtfProc} { - encoding convertto utf-8 \xa3 -} "\xc2\xa3" + encoding convertto utf-8 \xA3 +} "\xC2\xA3" test encoding-15.2 {UtfToUtfProc null character output} testbytestring { - binary scan [testbytestring [encoding convertto utf-8 \u0000]] H* z + binary scan [testbytestring [encoding convertto utf-8 \x00]] H* z set z } 00 test encoding-15.3 {UtfToUtfProc null character input} teststringbytes { - set y [encoding convertfrom utf-8 [encoding convertto utf-8 \u0000]] + set y [encoding convertfrom utf-8 [encoding convertto utf-8 \x00]] binary scan [teststringbytes $y] H* z set z } c080 @@ -407,18 +407,18 @@ test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} { list [string length $x] $y } "4 \xF0\xA0\xA1\xC2" -test encoding-16.1 {UnicodeToUtfProc} { +test encoding-16.1 {UnicodeToUtfProc} -body { set val [encoding convertfrom unicode NN] - list $val [format %x [scan $val %c]] -} "\u4e4e 4e4e" + list $val [format %X [scan $val %c]] +} -result "\u4E4E 4E4E" test encoding-16.2 {UnicodeToUtfProc} -constraints fullutf -body { set val [encoding convertfrom unicode "\xD8\xD8\xDC\xDC"] list $val [format %x [scan $val %c]] } -result "\U460DC 460dc" test encoding-16.3 {UnicodeToUtfProc} -body { set val [encoding convertfrom unicode "\xDC\xDC"] - list $val [format %x [scan $val %c]] -} -result "\uDCDC dcdc" + list $val [format %X [scan $val %c]] +} -result "\uDCDC DCDC" test encoding-17.1 {UtfToUnicodeProc} -constraints fullutf -body { encoding convertto unicode "\U460DC" @@ -430,8 +430,9 @@ test encoding-17.3 {UtfToUnicodeProc} -body { encoding convertto unicode "\uD8D8" } -result "\xD8\xD8" -test encoding-18.1 {TableToUtfProc} { -} {} +test encoding-18.1 {TableToUtfProc on invalid input} -body { + list [catch {encoding convertto jis0208 \\} res] $res +} -result {0 !)} test encoding-19.1 {TableFromUtfProc} { } {} @@ -445,11 +446,11 @@ test encoding-21.1 {EscapeToUtfProc} { test encoding-22.1 {EscapeFromUtfProc} { } {} -set iso2022encData "\u001b\$B;d\$I\$b\$G\$O!\"%A%C%W\$49XF~;~\$K\$4EPO?\$\$\$?\$@\$\$\$?\$4=;=j\$r%-%c%C%7%e%\"%&%H\$N:]\$N\u001b(B -\u001b\$B>.@Z.@Z> 8) | 0x80}] [expr {($code & 0xff) | 0x80}] + [expr {($code >> 8) | 0x80}] [expr {($code & 0xFF) | 0x80}] } proc gen-jisx0208-iso2022-jp {code} { binary format a3cca3 \ - "\x1b\$B" [expr {$code >> 8}] [expr {$code & 0xff}] "\x1b(B" + "\x1B\$B" [expr {$code >> 8}] [expr {$code & 0xFF}] "\x1B(B" } proc gen-jisx0208-cp932 {code} { set c1 [expr {($code >> 8) | 0x80}] set c2 [expr {($code & 0xff)| 0x80}] if {$c1 % 2} { - set c1 [expr {($c1 >> 1) + ($c1 < 0xdf ? 0x31 : 0x71)}] - incr c2 [expr {- (0x60 + ($c2 < 0xe0))}] + set c1 [expr {($c1 >> 1) + ($c1 < 0xDF ? 0x31 : 0x71)}] + incr c2 [expr {- (0x60 + ($c2 < 0xE0))}] } else { - set c1 [expr {($c1 >> 1) + ($c1 < 0xdf ? 0x30 : 0x70)}] + set c1 [expr {($c1 >> 1) + ($c1 < 0xDF ? 0x30 : 0x70)}] incr c2 -2 } binary format cc $c1 $c2 -- cgit v0.12 From 7f87f0f8ea86cf01682eb02e4fa8c313dc6ef4ef Mon Sep 17 00:00:00 2001 From: pooryorick Date: Fri, 27 Jan 2023 19:15:09 +0000 Subject: Add some comments and tidy code. --- generic/tclBasic.c | 3 ++- generic/tclExecute.c | 2 +- generic/tclNamesp.c | 2 ++ 3 files changed, 5 insertions(+), 2 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index bea5996..cdaf6fe 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -9716,6 +9716,7 @@ TclNRYieldToObjCmd( */ iPtr->execEnvPtr = corPtr->callerEEPtr; + /* Not calling Tcl_IncrRefCount(listPtr) here because listPtr is private */ TclSetTailcall(interp, listPtr); corPtr->yieldPtr = listPtr; iPtr->execEnvPtr = corPtr->eePtr; @@ -9918,8 +9919,8 @@ TclNRCoroutineActivateCallback( if (corPtr->yieldPtr) { for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) { if (runPtr->data[1] == corPtr->yieldPtr) { + Tcl_DecrRefCount(runPtr->data[1]); runPtr->data[1] = NULL; - Tcl_DecrRefCount(corPtr->yieldPtr); corPtr->yieldPtr = NULL; break; } diff --git a/generic/tclExecute.c b/generic/tclExecute.c index ec144a2..7ee5471 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -2503,8 +2503,8 @@ TEBCresume( * 'yieldParameter'). */ - Tcl_IncrRefCount(valuePtr); iPtr->execEnvPtr = corPtr->callerEEPtr; + Tcl_IncrRefCount(valuePtr); TclSetTailcall(interp, valuePtr); corPtr->yieldPtr = valuePtr; iPtr->execEnvPtr = corPtr->eePtr; diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 6269bbe..5a2979e 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -417,6 +417,8 @@ Tcl_PopCallFrame( framePtr->nsPtr = NULL; if (framePtr->tailcallPtr) { + /* Reusing the existing reference count from framePtr->tailcallPtr, so + * no need to Tcl_IncrRefCount(framePtr->tailcallPtr)*/ TclSetTailcall(interp, framePtr->tailcallPtr); } } -- cgit v0.12 From 468b1a434681f98ea64d399abce7ddd8c605617d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 28 Jan 2023 18:50:32 +0000 Subject: Fix "format %c 0x10000041", should give the same answer as in Tcl 8.6 (Handling of TCL_COMBINE flag should not be visible at script level) --- generic/tclStringObj.c | 3 +++ tests/format.test | 3 +++ 2 files changed, 6 insertions(+) diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index a041d4c..e1376f4 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -2130,6 +2130,9 @@ Tcl_AppendFormatToObj( if (TclGetIntFromObj(interp, segment, &code) != TCL_OK) { goto error; } + if ((unsigned)code > 0x10FFFF) { + code = 0xFFFD; + } length = Tcl_UniCharToUtf(code, buf); #if TCL_UTF_MAX < 4 if ((code >= 0xD800) && (length < 3)) { diff --git a/tests/format.test b/tests/format.test index c47774a..8cabbf1 100644 --- a/tests/format.test +++ b/tests/format.test @@ -402,6 +402,9 @@ test format-8.26 {Undocumented formats} -body { test format-8.27 {Undocumented formats} -constraints pointerIs64bit -body { format "%p %#llx" [expr {2**33}] [expr {2**33}] } -result {0x200000000 0x200000000} +test format-8.28 {Internal use of TCL_COMBINE flag should not be visiable at script level} { + format %c 0x10000041 +} \uFFFD test format-9.1 {long result} { set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} -- cgit v0.12 From 5b86b255d41b6a0948597ccc8b7499efde42c4d7 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 28 Jan 2023 20:50:36 +0000 Subject: Another situation where TCL_COMBINE handling gives a strange result (utf-32 encoder) --- generic/tclEncoding.c | 10 ++++++++-- tests/encoding.test | 4 ++++ 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index e548663..46508b7 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2505,8 +2505,14 @@ Utf32ToUtfProc( } else { ch = (src[0] & 0xFF) << 24 | (src[1] & 0xFF) << 16 | (src[2] & 0xFF) << 8 | (src[3] & 0xFF); } - if ((unsigned)ch > 0x10FFFF || (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) - && ((ch & ~0x7FF) == 0xD800))) { + if ((unsigned)ch > 0x10FFFF) { + if (STOPONERROR) { + result = TCL_CONVERT_SYNTAX; + break; + } + ch = 0xFFFD; + } else if (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) + && ((ch & ~0x7FF) == 0xD800)) { if (STOPONERROR) { result = TCL_CONVERT_SYNTAX; break; diff --git a/tests/encoding.test b/tests/encoding.test index a6c8a80..1971360 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -482,6 +482,10 @@ test encoding-16.7 {Utf32ToUtfProc} -body { set val [encoding convertfrom utf-32be \0\0NN] list $val [format %x [scan $val %c]] } -result "乎 4e4e" +test encoding-16.8 {Utf32ToUtfProc} -body { + set val [encoding convertfrom -nocomplain utf-32 \x41\x00\x00\x41] + list $val [format %x [scan $val %c]] +} -result "\uFFFD fffd" test encoding-17.1 {UtfToUtf16Proc} -body { encoding convertto utf-16 "\U460DC" -- cgit v0.12 From 4d235ca93a0588d63b0b2a0d1cdceb594a1a3a32 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 30 Jan 2023 11:22:28 +0000 Subject: Make Tcl_UniCharToUtf() a little easier to read. --- generic/tclUtf.c | 48 ++++++++++++++++++++++++++---------------------- 1 file changed, 26 insertions(+), 22 deletions(-) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 92bcf4f..ee0724c 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -231,8 +231,8 @@ Tcl_UniCharToUtf( } if (ch >= 0) { if (ch <= 0x7FF) { - buf[1] = (char) ((ch | 0x80) & 0xBF); - buf[0] = (char) ((ch >> 6) | 0xC0); + buf[1] = (char) (0x80 | (0x3F & ch)); + buf[0] = (char) (0xC0 | (ch >> 6)); return 2; } if (ch <= 0xFFFF) { @@ -243,10 +243,11 @@ Tcl_UniCharToUtf( ((ch & 0xF800) == 0xD800)) { if (ch & 0x0400) { /* Low surrogate */ - if (((buf[0] & 0xC0) == 0x80) && ((buf[1] & 0xCF) == 0)) { + if ( (0x80 == (0xC0 & buf[0])) + && (0 == (0xCF & buf[1]))) { /* Previous Tcl_UniChar was a high surrogate, so combine */ - buf[2] = (char) ((ch & 0x3F) | 0x80); - buf[1] |= (char) (((ch >> 6) & 0x0F) | 0x80); + buf[2] = (char) (0x80 | (0x3F & ch)); + buf[1] |= (char) (0x80 | (0x0F & (ch >> 6))); return 3; } /* Previous Tcl_UniChar was not a high surrogate, so just output */ @@ -255,38 +256,41 @@ Tcl_UniCharToUtf( ch += 0x40; /* Fill buffer with specific 3-byte (invalid) byte combination, so following low surrogate can recognize it and combine */ - buf[2] = (char) ((ch << 4) & 0x30); - buf[1] = (char) (((ch >> 2) & 0x3F) | 0x80); - buf[0] = (char) (((ch >> 8) & 0x07) | 0xF0); + buf[2] = (char) ( 0x03 & ch); + buf[1] = (char) (0x80 | (0x3F & (ch >> 2))); + buf[0] = (char) (0xF0 | (0x07 & (ch >> 8))); return 1; } } goto three; } if (ch <= 0x10FFFF) { - buf[3] = (char) ((ch | 0x80) & 0xBF); - buf[2] = (char) (((ch >> 6) | 0x80) & 0xBF); - buf[1] = (char) (((ch >> 12) | 0x80) & 0xBF); - buf[0] = (char) ((ch >> 18) | 0xF0); + buf[3] = (char) (0x80 | (0x3F & ch)); + buf[2] = (char) (0xBF & (0x80 | (ch >> 6))); + buf[1] = (char) (0xBF & (0x80 | (ch >> 12))); + buf[0] = (char) (0xF0 | (ch >> 18)); return 4; } } else if (ch == -1) { - if (((buf[0] & 0xC0) == 0x80) && ((buf[1] & 0xCF) == 0) - && ((buf[-1] & 0xF8) == 0xF0)) { - ch = 0xD7C0 + ((buf[-1] & 0x07) << 8) + ((buf[0] & 0x3F) << 2) - + ((buf[1] & 0x30) >> 4); - buf[1] = (char) ((ch | 0x80) & 0xBF); - buf[0] = (char) (((ch >> 6) | 0x80) & 0xBF); - buf[-1] = (char) ((ch >> 12) | 0xE0); + if ( (0x80 == (0xC0 & buf[0])) + && (0 == (0xCF & buf[1])) + && (0xF0 == (0xF8 & buf[-1]))) { + ch = 0xD7C0 + + ((0x07 & buf[-1]) << 8) + + ((0x3F & buf[0]) << 2) + + ((0x30 & buf[1]) >> 4); + buf[1] = (char) (0xBF & (0x80 | ch)); + buf[0] = (char) (0xBF & (0x80 | (ch >> 6))); + buf[-1] = (char) (0xE0 | (ch >> 12)); return 2; } } ch = 0xFFFD; three: - buf[2] = (char) ((ch | 0x80) & 0xBF); - buf[1] = (char) (((ch >> 6) | 0x80) & 0xBF); - buf[0] = (char) ((ch >> 12) | 0xE0); + buf[2] = (char) (0x80 | (0x3F & ch)); + buf[1] = (char) (0x80 | (0x3F & (ch >> 6))); + buf[0] = (char) (0xE0 | (ch >> 12)); return 3; } -- cgit v0.12 From 8c0f76a7de2b22a611f26c3a08a434b5b85ce261 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Mon, 30 Jan 2023 11:59:41 +0000 Subject: A few more readability changes to Tcl_UniCharToUtf() jn: Please, don't do that here. Tcl_UniCharToUtf() is shared between 8.6, 8.7 and 9.0. So if you want to make it easier to read, it should be done on all 3 branches. I know you only care about "trunk", but it makes maintenance on 8.6/8.7/9.0 harder than it already is. I don't want to spend time on reviewing such kind of changes, and no-one else is doing it. Thanks for understanding (I hope)! --- generic/tclUtf.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index ee0724c..ab27f1b 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -266,8 +266,8 @@ Tcl_UniCharToUtf( } if (ch <= 0x10FFFF) { buf[3] = (char) (0x80 | (0x3F & ch)); - buf[2] = (char) (0xBF & (0x80 | (ch >> 6))); - buf[1] = (char) (0xBF & (0x80 | (ch >> 12))); + buf[2] = (char) (0x80 | (0x3F & (ch >> 6))); + buf[1] = (char) (0x80 | (0x3F & (ch >> 12))); buf[0] = (char) (0xF0 | (ch >> 18)); return 4; } @@ -279,8 +279,8 @@ Tcl_UniCharToUtf( + ((0x07 & buf[-1]) << 8) + ((0x3F & buf[0]) << 2) + ((0x30 & buf[1]) >> 4); - buf[1] = (char) (0xBF & (0x80 | ch)); - buf[0] = (char) (0xBF & (0x80 | (ch >> 6))); + buf[1] = (char) (0x80 | (0x3F & ch)); + buf[0] = (char) (0x80 | (0x3F & (ch >> 6))); buf[-1] = (char) (0xE0 | (ch >> 12)); return 2; } -- cgit v0.12 From d3dae9eba4c8d979d72feddfded60eb08835543d Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 30 Jan 2023 15:37:41 +0000 Subject: silence compiler warning --- generic/tclBasic.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index cdaf6fe..a31bfb6 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -9919,7 +9919,7 @@ TclNRCoroutineActivateCallback( if (corPtr->yieldPtr) { for (runPtr = TOP_CB(interp); runPtr; runPtr = runPtr->nextPtr) { if (runPtr->data[1] == corPtr->yieldPtr) { - Tcl_DecrRefCount(runPtr->data[1]); + Tcl_DecrRefCount((Tcl_Obj *)runPtr->data[1]); runPtr->data[1] = NULL; corPtr->yieldPtr = NULL; break; -- cgit v0.12 From 64e3a23bfdcfbe7b66872c58d095aa6e1868f95e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 31 Jan 2023 07:49:16 +0000 Subject: SetFlag -> GotFlag (since SetFlag always returns 1, this is nonsence in an if() statement). Also add test-case, showing that it was actually wrong, in behavior too. --- generic/tclIO.c | 2 +- tests/ioCmd.test | 10 ++++++++++ 2 files changed, 11 insertions(+), 1 deletion(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 47040d5..fed469c 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8354,7 +8354,7 @@ Tcl_SetChannelOption( #ifdef TCL_NO_DEPRECATED ResetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); #else - if (SetFlag(statePtr, CHANNEL_ENCODING_STRICT)) { + if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT) != CHANNEL_ENCODING_STRICT) { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -nocomplainencoding: only true allowed", diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 73f0e1c..1a72f70 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -376,6 +376,16 @@ test iocmd-8.21 {fconfigure command / -nocomplainencoding 0 error} -constraints } -body { fconfigure $console -nocomplainencoding 0 } -returnCodes error -result "bad value for -nocomplainencoding: only true allowed" +test iocmd-8.22 {fconfigure command / -nocomplainencoding 0, no error if -strictencoding already defined} -setup { + set console stdin + set oldmode [fconfigure $console -strictencoding] +} -body { + fconfigure $console -strictencoding 1 + fconfigure $console -nocomplainencoding 0 + fconfigure $console -nocomplainencoding +} -cleanup { + fconfigure $console -strictencoding $oldmode +} -result 0 test iocmd-9.1 {eof command} { -- cgit v0.12 From 596e33bb9ec8c0083b2d6234c84afc293e525d24 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 31 Jan 2023 17:30:59 +0000 Subject: Remove incorrect comment. See: [https://www.magicsplat.com/tcl9/tcl9unicode.html#surrogates-as-literals]. Thanks, Ashok, for noticing this! --- doc/Tcl.n | 6 ------ 1 file changed, 6 deletions(-) diff --git a/doc/Tcl.n b/doc/Tcl.n index 0f46f73..8e0b342 100644 --- a/doc/Tcl.n +++ b/doc/Tcl.n @@ -221,12 +221,6 @@ twenty-one-bit hexadecimal value for the Unicode character that will be inserted, in the range U+000000\(enU+10FFFF. The parser will stop just before this range overflows, or when the maximum of eight digits is reached. The upper bits of the Unicode character will be 0. -.RS -.PP -The range U+00D800\(enU+00DFFF is reserved for surrogates, which -are illegal on their own. Therefore, such sequences will result in -the replacement character U+FFFD. Surrogate pairs should be -encoded as single \e\fBU\fIhhhhhhhh\fR character. .RE .PP Backslash substitution is not performed on words enclosed in braces, -- cgit v0.12 From 078a694834be8669ba6f79def0adbb61afacc0e2 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Tue, 31 Jan 2023 22:15:02 +0000 Subject: Fix error introduced in [3e5e37f83b058f3d] for Tcl_UniCharToUtf, and add test. --- generic/tclUtf.c | 2 +- tests/encoding.test | 24 ++++++++++++++++++++++++ 2 files changed, 25 insertions(+), 1 deletion(-) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index ab27f1b..bef32f0 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -256,7 +256,7 @@ Tcl_UniCharToUtf( ch += 0x40; /* Fill buffer with specific 3-byte (invalid) byte combination, so following low surrogate can recognize it and combine */ - buf[2] = (char) ( 0x03 & ch); + buf[2] = (char) ((ch << 4) & 0x30); buf[1] = (char) (0x80 | (0x3F & (ch >> 2))); buf[0] = (char) (0xF0 | (0x07 & (ch >> 8))); return 1; diff --git a/tests/encoding.test b/tests/encoding.test index 1971360..8351c91 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -487,6 +487,30 @@ test encoding-16.8 {Utf32ToUtfProc} -body { list $val [format %x [scan $val %c]] } -result "\uFFFD fffd" +test encoding-16.8 { + Utf16ToUtfProc, Tcl_UniCharToUtf, surrogate pairs in utf-16 +} -body { + apply [list {} { + for {set i 0xD800} {$i < 0xDBFF} {incr i} { + for {set j 0xDC00} {$j < 0xDFFF} {incr j} { + set string [binary format S2 [list $i $j]] + set status [catch { + set decoded [encoding convertfrom utf-16be $string] + set encoded [encoding convertto utf-16be $decoded] + }] + if {$status || ( $encoded ne $string )} { + return [list [format %x $i] [format %x $j]] + } + } + } + return done + } [namespace current]] +} -result done + + + + + test encoding-17.1 {UtfToUtf16Proc} -body { encoding convertto utf-16 "\U460DC" } -result "\xD8\xD8\xDC\xDC" -- cgit v0.12 From 5866ef6d2acf4db24499c820df08a8feb88ea865 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 1 Feb 2023 07:29:48 +0000 Subject: (Cherry-pick) Make Tcl_UniCharToUtf more readable. --- generic/tclEncoding.c | 6 +++--- generic/tclUtf.c | 57 +++++++++++++++++++++++++++------------------------ 2 files changed, 33 insertions(+), 30 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index fe2b55b..dfa7907 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2244,9 +2244,9 @@ UtfExtToUtfIntProc( * * UtfToUtfProc -- * - * Convert from UTF-8 to UTF-8. 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. + * Converts from UTF-8 to UTF-8. Note that the 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. * * Results: * Returns TCL_OK if conversion was successful. diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 8931b39..e4d0fc8 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -206,12 +206,11 @@ Invalid( * * Tcl_UniCharToUtf -- * - * Store the given Tcl_UniChar as a sequence of UTF-8 bytes in the + * Stores the given Tcl_UniChar as a sequence of UTF-8 bytes in the * provided buffer. Equivalent to Plan 9 runetochar(). * * Results: - * The return values is the number of bytes in the buffer that were - * consumed. + * Returns the number of bytes stored into the buffer. * * Side effects: * None. @@ -234,8 +233,8 @@ Tcl_UniCharToUtf( } if (ch >= 0) { if (ch <= 0x7FF) { - buf[1] = (char) ((ch | 0x80) & 0xBF); - buf[0] = (char) ((ch >> 6) | 0xC0); + buf[1] = (char) (0x80 | (0x3F & ch)); + buf[0] = (char) (0xC0 | (ch >> 6)); return 2; } if (ch <= 0xFFFF) { @@ -243,10 +242,11 @@ Tcl_UniCharToUtf( if ((ch & 0xF800) == 0xD800) { if (ch & 0x0400) { /* Low surrogate */ - if (((buf[0] & 0xC0) == 0x80) && ((buf[1] & 0xCF) == 0)) { + if ( (0x80 == (0xC0 & buf[0])) + && (0 == (0xCF & buf[1]))) { /* Previous Tcl_UniChar was a high surrogate, so combine */ - buf[2] = (char) ((ch & 0x3F) | 0x80); - buf[1] |= (char) (((ch >> 6) & 0x0F) | 0x80); + buf[2] = (char) (0x80 | (0x3F & ch)); + buf[1] |= (char) (0x80 | (0x0F & (ch >> 6))); return 3; } /* Previous Tcl_UniChar was not a high surrogate, so just output */ @@ -256,8 +256,8 @@ Tcl_UniCharToUtf( /* Fill buffer with specific 3-byte (invalid) byte combination, so following low surrogate can recognize it and combine */ buf[2] = (char) ((ch << 4) & 0x30); - buf[1] = (char) (((ch >> 2) & 0x3F) | 0x80); - buf[0] = (char) (((ch >> 8) & 0x07) | 0xF0); + buf[1] = (char) (0x80 | (0x3F & (ch >> 2))); + buf[0] = (char) (0xF0 | (0x07 & (ch >> 8))); return 1; } } @@ -267,20 +267,23 @@ Tcl_UniCharToUtf( #if TCL_UTF_MAX > 3 if (ch <= 0x10FFFF) { - buf[3] = (char) ((ch | 0x80) & 0xBF); - buf[2] = (char) (((ch >> 6) | 0x80) & 0xBF); - buf[1] = (char) (((ch >> 12) | 0x80) & 0xBF); - buf[0] = (char) ((ch >> 18) | 0xF0); + buf[3] = (char) (0x80 | (0x3F & ch)); + buf[2] = (char) (0x80 | (0x3F & (ch >> 6))); + buf[1] = (char) (0x80 | (0x3F & (ch >> 12))); + buf[0] = (char) (0xF0 | (ch >> 18)); return 4; } } else if (ch == -1) { - if (((buf[0] & 0xC0) == 0x80) && ((buf[1] & 0xCF) == 0) - && ((buf[-1] & 0xF8) == 0xF0)) { - ch = 0xD7C0 + ((buf[-1] & 0x07) << 8) + ((buf[0] & 0x3F) << 2) - + ((buf[1] & 0x30) >> 4); - buf[1] = (char) ((ch | 0x80) & 0xBF); - buf[0] = (char) (((ch >> 6) | 0x80) & 0xBF); - buf[-1] = (char) ((ch >> 12) | 0xE0); + if ( (0x80 == (0xC0 & buf[0])) + && (0 == (0xCF & buf[1])) + && (0xF0 == (0xF8 & buf[-1]))) { + ch = 0xD7C0 + + ((0x07 & buf[-1]) << 8) + + ((0x3F & buf[0]) << 2) + + ((0x30 & buf[1]) >> 4); + buf[1] = (char) (0x80 | (0x3F & ch)); + buf[0] = (char) (0x80 | (0x3F & (ch >> 6))); + buf[-1] = (char) (0xE0 | (ch >> 12)); return 2; } #endif @@ -288,9 +291,9 @@ Tcl_UniCharToUtf( ch = 0xFFFD; three: - buf[2] = (char) ((ch | 0x80) & 0xBF); - buf[1] = (char) (((ch >> 6) | 0x80) & 0xBF); - buf[0] = (char) ((ch >> 12) | 0xE0); + buf[2] = (char) (0x80 | (0x3F & ch)); + buf[1] = (char) (0x80 | (0x3F & (ch >> 6))); + buf[0] = (char) (0xE0 | (ch >> 12)); return 3; } @@ -2386,7 +2389,7 @@ TclUniCharMatch( * * TclUtfToUCS4 -- * - * Extract the 4-byte codepoint from the leading bytes of the + * Extracts the 4-byte codepoint from the leading bytes of the * Modified UTF-8 string "src". This is a utility routine to * contain the surrogate gymnastics in one place. * @@ -2398,8 +2401,8 @@ TclUniCharMatch( * enough bytes remain in the string. * * Results: - * *usc4Ptr is filled with the UCS4 code point, and the return value is - * the number of bytes from the UTF-8 string that were consumed. + * Fills *usc4Ptr with the UCS4 code point and returns the number of bytes + * consumed from the source string. * * Side effects: * None. -- cgit v0.12 From 3eaad4bbc95c9cb3eaaf79872646d4fa7f6d8c6e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 1 Feb 2023 08:10:12 +0000 Subject: (cherry-pick) Make Tcl_UniCharToUtf more readable and add test to exercise surrogate handling. (test-case was still missing, which cannot be used in Tcl 8.6) --- generic/tclUtf.c | 14 ++++++-------- tests/encoding.test | 24 ++++++++++++++++++++++++ 2 files changed, 30 insertions(+), 8 deletions(-) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index db2be84..cb8bb3e 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -185,17 +185,15 @@ Invalid( * Stores the given Tcl_UniChar as a sequence of UTF-8 bytes in the * provided buffer. Equivalent to Plan 9 runetochar(). * - * Special handling of Surrogate pairs is handled as follows: - * When this function is called for ch being a high surrogate, - * the first byte of the 4-byte UTF-8 sequence is produced and - * the function returns 1. Calling the function again with a - * low surrogate, the remaining 3 bytes of the 4-byte UTF-8 - * sequence is produced, and the function returns 3. The buffer - * is used to remember the high surrogate between the two calls. + * Surrogate pairs are handled as follows: When ch is a high surrogate, + * the first byte of the 4-byte UTF-8 sequence is stored in the buffer and + * the function returns 1. If the function is called again with a low + * surrogate and the same buffer, the remaining 3 bytes of the 4-byte + * UTF-8 sequence are produced. * * If no low surrogate follows the high surrogate (which is actually * illegal), this can be handled reasonably by calling Tcl_UniCharToUtf - * again with ch = -1. This will produce a 3-byte UTF-8 sequence + * again with ch = -1. This produces a 3-byte UTF-8 sequence * representing the high surrogate. * * Results: diff --git a/tests/encoding.test b/tests/encoding.test index 10a37f8..ae6c78a 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -482,6 +482,30 @@ test encoding-16.7 {Utf32ToUtfProc} -body { list $val [format %x [scan $val %c]] } -result "乎 4e4e" +test encoding-16.8 { + Utf16ToUtfProc, Tcl_UniCharToUtf, surrogate pairs in utf-16 +} -body { + apply [list {} { + for {set i 0xD800} {$i < 0xDBFF} {incr i} { + for {set j 0xDC00} {$j < 0xDFFF} {incr j} { + set string [binary format S2 [list $i $j]] + set status [catch { + set decoded [encoding convertfrom utf-16be $string] + set encoded [encoding convertto utf-16be $decoded] + }] + if {$status || ( $encoded ne $string )} { + return [list [format %x $i] [format %x $j]] + } + } + } + return done + } [namespace current]] +} -result done + + + + + test encoding-17.1 {UtfToUtf16Proc} -body { encoding convertto utf-16 "\U460DC" } -result "\xD8\xD8\xDC\xDC" -- cgit v0.12 From b9c893dbc940d680560b5cc10b414c702d845004 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 1 Feb 2023 21:01:51 +0000 Subject: Renumber testscase, sync with Tcl 9.0 --- tests/encoding.test | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/tests/encoding.test b/tests/encoding.test index ae6c78a..05d9918 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -481,8 +481,12 @@ test encoding-16.7 {Utf32ToUtfProc} -body { set val [encoding convertfrom utf-32be \0\0NN] list $val [format %x [scan $val %c]] } -result "乎 4e4e" +test encoding-16.8 {Utf32ToUtfProc} -body { + set val [encoding convertfrom -nocomplain utf-32 \x41\x00\x00\x41] + list $val [format %x [scan $val %c]] +} -result "\uFFFD fffd" -test encoding-16.8 { +test encoding-16.9 { Utf16ToUtfProc, Tcl_UniCharToUtf, surrogate pairs in utf-16 } -body { apply [list {} { @@ -930,7 +934,9 @@ test encoding-27.2 {encoding dirs basic behavior} -returnCodes error -body { test encoding-28.0 {all encodings load} -body { set string hello foreach name [encoding names] { - incr count + if {$name ne "unicode"} { + incr count + } encoding convertto -nocomplain $name $string # discard the cached internal representation of Tcl_Encoding @@ -938,7 +944,7 @@ test encoding-28.0 {all encodings load} -body { llength $name } return $count -} -result [expr {[info exists ::tcl_precision] ? 92 : 91}] +} -result 91 runtests -- cgit v0.12 From de0a637d7c24faa768c266bacda17bf6ac48171d Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 2 Feb 2023 07:12:34 +0000 Subject: Fix documentation on "encoding" command --- doc/encoding.n | 28 +++++++++++++--------------- 1 file changed, 13 insertions(+), 15 deletions(-) diff --git a/doc/encoding.n b/doc/encoding.n index 9577da3..4ad2824 100644 --- a/doc/encoding.n +++ b/doc/encoding.n @@ -39,9 +39,9 @@ system encoding is used. .VS "TCL8.7 TIP346, TIP607, TIP601" .PP .RS -The command does not fail on encoding errors. Instead, any not convertable bytes -(like incomplete UTF-8 sequences, see example below) are put as byte values into -the output stream. +The command does not fail on encoding errors (unless \fB-strict\fR is specified). +Instead, any not convertable bytes (like incomplete UTF-8 sequences, see example +below) are put as byte values into the output stream. .PP If the option \fB-failindex\fR with a variable name is given, the error reporting is changed in the following manner: @@ -51,9 +51,8 @@ converted characters until the first error position. In case of no error, the value \fI-1\fR is written to the variable. This option may not be used together with \fB-nocomplain\fR. .PP -The option \fB-nocomplain\fR has no effect and is available for compatibility with -TCL 9. In TCL 9, the encoding command fails with an error on any encoding issue. -This switch restores the TCL8.7 behaviour. +The option \fB-nocomplain\fR has no effect, but assures to get the same result +in Tcl 9. .PP The \fB-strict\fR option follows more strict rules in conversion. For the \fButf-8\fR encoder, it disallows invalid byte sequences and surrogates (which - @@ -74,9 +73,9 @@ specified, the current system encoding is used. .VS "TCL8.7 TIP346, TIP607, TIP601" .PP .RS -The command does not fail on encoding errors. Instead, the replacement character -\fB?\fR is output for any not representable character (like the dot \fB\\U2022\fR -in \fBiso-8859-1\fR encoding, see example below). +The command does not fail on encoding errors (unless \fB-strict\fR is specified). +Instead, the replacement character \fB?\fR is output for any not representable +character (like the dot \fB\\U2022\fR in \fBiso-8859-1\fR encoding, see example below). .PP If the option \fB-failindex\fR with a variable name is given, the error reporting is changed in the following manner: @@ -86,9 +85,8 @@ converted bytes until the first error position. No error condition is raised. In case of no error, the value \fI-1\fR is written to the variable. This option may not be used together with \fB-nocomplain\fR. .PP -The option \fB-nocomplain\fR has no effect and is available for compatibility with -TCL 9. In TCL 9, the encoding command fails with an error on any encoding issue. -This switch restores the TCL8.7 behaviour. +The option \fB-nocomplain\fR has no effect, but assures to get the same result +in Tcl 9. .PP The \fB-strict\fR option follows more strict rules in conversion. For the \fButf-8\fR encoder, it disallows surrogates (which - otherwise - are just passed through). This @@ -157,7 +155,7 @@ Example 4: detect the error location while transforming to ISO8859-1 (ISO-Latin 1): .PP .CS -% set s [\fBencoding convertto\fR -failindex i utf-8 "A\eu0141"] +% set s [\fBencoding convertto\fR -failindex i iso8859-1 "A\eu0141"] A % set i 1 @@ -166,11 +164,11 @@ A Example 5: replace a not representable character by the replacement character: .PP .CS -% set s [\fBencoding convertto\fR -nocomplain utf-8 "A\eu0141"] +% set s [\fBencoding convertto\fR -nocomplain iso8859-1 "A\eu0141"] A? .CE The option \fB-nocomplain\fR has no effect, but assures to get the same result -with TCL9. +in Tcl 9. .VE "TCL8.7 TIP346, TIP607, TIP601" .PP .SH "SEE ALSO" -- cgit v0.12 From 637e7224c9b4c5bde7709455dc262bdf476f9b4d Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 2 Feb 2023 11:52:31 +0000 Subject: Replace encoding -strict etc. with -profile --- generic/tclCmdAH.c | 325 +++++++++++++++++++++++++++++--------------------- generic/tclEncoding.c | 34 ++++++ generic/tclInt.h | 20 ++++ tests/encoding.test | 132 ++++++++++---------- 4 files changed, 310 insertions(+), 201 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 4f743cc..818159d 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -527,6 +527,137 @@ TclInitEncodingCmd( } /* + *------------------------------------------------------------------------ + * + * EncodingConvertParseOptions -- + * + * Common routine for parsing arguments passed to encoding convertfrom + * and encoding convertto. + * + * Results: + * TCL_OK or TCL_ERROR. + * + * Side effects: + * On success, + * - *encPtr is set to the encoding. Must be freed with Tcl_FreeEncoding + * if non-NULL + * - *dataObjPtr is set to the Tcl_Obj containing the data to encode or + * decode + * - *flagsPtr is set to encoding error handling flags + * - *failVarPtr is set to -failindex option value or NULL + * On error, all of the above are uninitialized. + * + *------------------------------------------------------------------------ + */ +static int +EncodingConvertParseOptions ( + Tcl_Interp *interp, /* For error messages. May be NULL */ + int objc, /* Number of arguments */ + Tcl_Obj *const objv[], /* Argument objects as passed to command. */ + int isEncoder, /* 1 -> convertto, 0 -> convertfrom */ + Tcl_Encoding *encPtr, /* Where to store the encoding */ + Tcl_Obj **dataObjPtr, /* Where to store ptr to Tcl_Obj containing data */ + int *flagsPtr, /* Bit mask of encoding option flags */ + Tcl_Obj **failVarPtr /* Where to store -failindex option value */ +) +{ + static const char *const options[] = {"-profile", "-failindex", NULL}; + enum convertfromOptions { PROFILE, FAILINDEX } optIndex; + enum TclEncodingProfile profile; + Tcl_Encoding encoding; + Tcl_Obj *dataObj; + Tcl_Obj *failVarObj; +#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) + int flags = TCL_ENCODING_STOPONERROR; +#else + int flags = TCL_ENCODING_NOCOMPLAIN; +#endif + + /* + * Possible combinations: + * 1) data -> objc = 2 + * 2) ?options? encoding data -> objc >= 3 + * It is intentional that specifying option forces encoding to be + * specified. Less prone to user error. This should have always been + * the case even in 8.6 imho where there were no options (ie (1) + * should never have been allowed) + */ + + if (objc == 1) { +numArgsError: /* ONLY jump here if nothing needs to be freed!!! */ + Tcl_WrongNumArgs( + interp, + 1, + objv, + "??-profile profile? ?-failindex var? ?encoding?? data"); + return TCL_ERROR; + } + + failVarObj = NULL; + if (objc == 2) { + encoding = Tcl_GetEncoding(interp, NULL); + dataObj = objv[1]; + } else { + int argIndex; + for (argIndex = 1; argIndex < (objc-2); ++argIndex) { + if (Tcl_GetIndexFromObj( + interp, objv[argIndex], options, "option", 0, &optIndex) + != TCL_OK) { + return TCL_ERROR; + } + if (++argIndex == (objc - 2)) { + goto numArgsError; + } + switch (optIndex) { + case PROFILE: + if (TclEncodingProfileParseName( + interp, objv[argIndex], &profile) + != TCL_OK) { + return TCL_ERROR; + } + switch (profile) { + case TCL_ENCODING_PROFILE_TCL8: + flags = TCL_ENCODING_NOCOMPLAIN; + break; + case TCL_ENCODING_PROFILE_STRICT: + flags = TCL_ENCODING_STRICT; + break; + case TCL_ENCODING_PROFILE_DEFAULT: /* FALLTHRU */ + default: + break; + } + break; + case FAILINDEX: + failVarObj = objv[argIndex]; + break; + } + } + /* Get encoding after opts so no need to free it on option error */ + if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) + != TCL_OK) { + return TCL_ERROR; + } + dataObj = objv[objc - 1]; + } + + /* -failindex forces checking*/ + if (failVarObj != NULL && flags == TCL_ENCODING_NOCOMPLAIN) { + /* + * Historical, but I really don't like this mixing of defines + * from two different bit mask domains - ENCODING_FAILINDEX + */ + flags = isEncoder ? TCL_ENCODING_STOPONERROR : ENCODING_FAILINDEX; + } + + *encPtr = encoding; + *dataObjPtr = dataObj; + *flagsPtr = flags; + *failVarPtr = failVarObj; + + return TCL_OK; +} + +/* *---------------------------------------------------------------------- * * EncodingConvertfromObjCmd -- @@ -559,78 +690,73 @@ EncodingConvertfromObjCmd( #endif int result; Tcl_Obj *failVarObj = NULL; + static const char *const options[] = {"-profile", "-failindex", NULL}; + enum convertfromOptions { PROFILE, FAILINDEX } optIndex; + enum TclEncodingProfile profile; + /* - * Decode parameters: * Possible combinations: * 1) data -> objc = 2 - * 2) encoding data -> objc = 3 - * 3) -nocomplain data -> objc = 3 - * 4) -nocomplain encoding data -> objc = 4 - * 5) -strict data -> objc = 3 - * 6) -strict encoding data -> objc = 4 - * 7) -failindex val data -> objc = 4 - * 8) -failindex val encoding data -> objc = 5 + * 2) ?options? encoding data -> objc >= 3 + * It is intentional that specifying option forces encoding to be + * specified. Less prone to user error. This should have always been + * the case even in 8.6 imho where there were no options (ie (1) + * should never have been allowed) */ - if (objc == 2) { + if (objc == 1) { +numArgsError: /* ONLY jump here if nothing needs to be freed!!! */ + Tcl_WrongNumArgs( + interp, + 1, + objv, + "??-profile profile? ?-failindex var? ?encoding?? data"); + return TCL_ERROR; + } + else if (objc == 2) { encoding = Tcl_GetEncoding(interp, NULL); data = objv[1]; - } else if (objc > 2 && objc < 7) { - int objcUnprocessed = objc; - data = objv[objc - 1]; - bytesPtr = Tcl_GetString(objv[1]); - if (bytesPtr[0] == '-' && bytesPtr[1] == 'n' - && !strncmp(bytesPtr, "-nocomplain", strlen(bytesPtr))) { - flags = TCL_ENCODING_NOCOMPLAIN; - objcUnprocessed--; - } else if (bytesPtr[0] == '-' && bytesPtr[1] == 's' - && !strncmp(bytesPtr, "-strict", strlen(bytesPtr))) { - flags = TCL_ENCODING_STRICT; - objcUnprocessed--; - bytesPtr = Tcl_GetString(objv[2]); - if (bytesPtr[0] == '-' && bytesPtr[1] == 'f' - && !strncmp(bytesPtr, "-failindex", strlen(bytesPtr))) { - /* at least two additional arguments needed */ - if (objc < 6) { - goto encConvFromError; - } - failVarObj = objv[3]; - objcUnprocessed -= 2; - } - } else if (bytesPtr[0] == '-' && bytesPtr[1] == 'f' - && !strncmp(bytesPtr, "-failindex", strlen(bytesPtr))) { - /* at least two additional arguments needed */ - if (objc < 4) { - goto encConvFromError; + } else { + int argIndex; + for (argIndex = 1; argIndex < (objc-2); ++argIndex) { + if (Tcl_GetIndexFromObj( + interp, objv[argIndex], options, "option", 0, &optIndex) + != TCL_OK) { + return TCL_ERROR; } - failVarObj = objv[2]; - flags = ENCODING_FAILINDEX; - objcUnprocessed -= 2; - bytesPtr = Tcl_GetString(objv[3]); - if (bytesPtr[0] == '-' && bytesPtr[1] == 's' - && !strncmp(bytesPtr, "-strict", strlen(bytesPtr))) { - flags = TCL_ENCODING_STRICT; - objcUnprocessed --; - } - } - switch (objcUnprocessed) { - case 3: - if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { + if (++argIndex == (objc - 2)) { + goto numArgsError; + } + switch (optIndex) { + case PROFILE: + if (TclEncodingProfileParseName( + interp, objv[argIndex], &profile) + != TCL_OK) { return TCL_ERROR; } + switch (profile) { + case TCL_ENCODING_PROFILE_TCL8: + flags = TCL_ENCODING_NOCOMPLAIN; + break; + case TCL_ENCODING_PROFILE_STRICT: + flags = TCL_ENCODING_STRICT; + break; + case TCL_ENCODING_PROFILE_DEFAULT: /* FALLTHRU */ + default: + break; + } break; - case 2: - encoding = Tcl_GetEncoding(interp, NULL); + case FAILINDEX: + failVarObj = objv[argIndex]; break; - default: - goto encConvFromError; + } } - } else { - encConvFromError: - Tcl_WrongNumArgs(interp, 1, objv, "?-strict? ?-failindex var? ?encoding? data"); - ((Interp *) interp)->flags |= INTERP_ALTERNATE_WRONG_ARGS; - Tcl_WrongNumArgs(interp, 1, objv, "-nocomplain ?encoding? data"); - return TCL_ERROR; + /* Get encoding after opts so no need to free it on option error */ + if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) + != TCL_OK) { + return TCL_ERROR; + } + data = objv[objc - 1]; } /* @@ -711,83 +837,12 @@ EncodingConverttoObjCmd( int length; /* Length of the string being converted */ const char *stringPtr; /* Pointer to the first byte of the string */ int result; -#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) - int flags = TCL_ENCODING_STOPONERROR; -#else - int flags = TCL_ENCODING_NOCOMPLAIN; -#endif - Tcl_Obj *failVarObj = NULL; - - /* - * Decode parameters: - * Possible combinations: - * 1) data -> objc = 2 - * 2) encoding data -> objc = 3 - * 3) -nocomplain data -> objc = 3 - * 4) -nocomplain encoding data -> objc = 4 - * 5) -failindex val data -> objc = 4 - * 6) -failindex val encoding data -> objc = 5 - */ - - if (objc == 2) { - encoding = Tcl_GetEncoding(interp, NULL); - data = objv[1]; - } else if (objc > 2 && objc < 7) { - int objcUnprocessed = objc; - data = objv[objc - 1]; - stringPtr = Tcl_GetString(objv[1]); - if (stringPtr[0] == '-' && stringPtr[1] == 'n' - && !strncmp(stringPtr, "-nocomplain", strlen(stringPtr))) { - flags = TCL_ENCODING_NOCOMPLAIN; - objcUnprocessed--; - } else if (stringPtr[0] == '-' && stringPtr[1] == 's' - && !strncmp(stringPtr, "-strict", strlen(stringPtr))) { - flags = TCL_ENCODING_STRICT; - objcUnprocessed--; - stringPtr = Tcl_GetString(objv[2]); - if (stringPtr[0] == '-' && stringPtr[1] == 'f' - && !strncmp(stringPtr, "-failindex", strlen(stringPtr))) { - /* at least two additional arguments needed */ - if (objc < 6) { - goto encConvToError; - } - failVarObj = objv[3]; - objcUnprocessed -= 2; - } - } else if (stringPtr[0] == '-' && stringPtr[1] == 'f' - && !strncmp(stringPtr, "-failindex", strlen(stringPtr))) { - /* at least two additional arguments needed */ - if (objc < 4) { - goto encConvToError; - } - failVarObj = objv[2]; - flags = TCL_ENCODING_STOPONERROR; - objcUnprocessed -= 2; - stringPtr = Tcl_GetString(objv[3]); - if (stringPtr[0] == '-' && stringPtr[1] == 's' - && !strncmp(stringPtr, "-strict", strlen(stringPtr))) { - flags = TCL_ENCODING_STRICT; - objcUnprocessed --; - } - } - switch (objcUnprocessed) { - case 3: - if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { - return TCL_ERROR; - } - break; - case 2: - encoding = Tcl_GetEncoding(interp, NULL); - break; - default: - goto encConvToError; - } - } else { - encConvToError: - Tcl_WrongNumArgs(interp, 1, objv, "?-strict? ?-failindex var? ?encoding? data"); - ((Interp *) interp)->flags |= INTERP_ALTERNATE_WRONG_ARGS; - Tcl_WrongNumArgs(interp, 1, objv, "-nocomplain ?encoding? data"); + int flags; + Tcl_Obj *failVarObj; + if (EncodingConvertParseOptions( + interp, objc, objv, 1, &encoding, &data, &flags, &failVarObj) + != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 288b07c..bdd091f 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -4085,6 +4085,40 @@ InitializeEncodingSearchPath( } /* + *------------------------------------------------------------------------ + * + * TclEncodingProfileParseName -- + * + * Maps an encoding profile name to its enum value. + * + * Results: + * TCL_OK on success or TCL_ERROR on failure. + * + * Side effects: + * Returns the profile enum value in *profilePtr + * + *------------------------------------------------------------------------ + */ +int +TclEncodingProfileParseName( + Tcl_Interp *interp, /* For error messages. May be NULL */ + Tcl_Obj *profileName, /* Name of profile */ + enum TclEncodingProfile *profilePtr) /* Output */ +{ + /* NOTE: Order must match enum TclEncodingProfile !!! */ + static const char *const profileNames[] = {"", "tcl8", "strict"}; + int idx; + + if (Tcl_GetIndexFromObj( + interp, profileName, profileNames, "profile", 0, &idx) + != TCL_OK) { + return TCL_ERROR; + } + *profilePtr = (enum TclEncodingProfile)idx; + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclInt.h b/generic/tclInt.h index 31c7fcb..db8ee9f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2879,7 +2879,25 @@ MODULE_SCOPE int tclFindExecutableSearchDone; MODULE_SCOPE char *tclMemDumpFileName; MODULE_SCOPE TclPlatformType tclPlatform; +/* + * Declarations related to internal encoding functions. + */ + +/* + * Enum for encoding profiles that control encoding treatment of + * invalid bytes. NOTE: Order must match that of encodingProfileNames in + * TclEncodingProfileParseName() !!! + */ +enum TclEncodingProfile { + TCL_ENCODING_PROFILE_DEFAULT, + TCL_ENCODING_PROFILE_TCL8, + TCL_ENCODING_PROFILE_STRICT, +}; MODULE_SCOPE Tcl_Encoding tclIdentityEncoding; +MODULE_SCOPE int +TclEncodingProfileParseName(Tcl_Interp *interp, + Tcl_Obj *profileName, + enum TclEncodingProfile *profilePtr); /* * TIP #233 (Virtualized Time) @@ -4787,6 +4805,8 @@ MODULE_SCOPE Tcl_LibraryInitProc TclThread_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; + + /* *---------------------------------------------------------------- * Macro used by the Tcl core to check whether a pattern has any characters diff --git a/tests/encoding.test b/tests/encoding.test index ae6c78a..813cd84 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -299,7 +299,7 @@ test encoding-11.11 {encoding: extended Unicode UTF-32} { test encoding-12.1 {LoadTableEncoding: normal encoding} { set x [encoding convertto iso8859-3 Ġ] - append x [encoding convertto -nocomplain iso8859-3 Õ] + append x [encoding convertto -profile tcl8 iso8859-3 Õ] append x [encoding convertfrom iso8859-3 Õ] } "Õ?Ġ" test encoding-12.2 {LoadTableEncoding: single-byte encoding} { @@ -348,67 +348,67 @@ test encoding-15.5 {UtfToUtfProc emoji character input} { } "4 😂" test encoding-15.6 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uDE02\uD83D - set y [encoding convertto -nocomplain utf-8 \uDE02\uD83D\uDE02\uD83D] + set y [encoding convertto -profile tcl8 utf-8 \uDE02\uD83D\uDE02\uD83D] binary scan $y H* z list [string length $y] $z } {10 edb882f09f9882eda0bd} test encoding-15.7 {UtfToUtfProc emoji character output} { set x \uDE02\uD83D\uD83D - set y [encoding convertto -nocomplain utf-8 \uDE02\uD83D\uD83D] + set y [encoding convertto -profile tcl8 utf-8 \uDE02\uD83D\uD83D] binary scan $y H* z list [string length $x] [string length $y] $z } {3 9 edb882eda0bdeda0bd} test encoding-15.8 {UtfToUtfProc emoji character output} { set x \uDE02\uD83Dé - set y [encoding convertto -nocomplain utf-8 \uDE02\uD83Dé] + set y [encoding convertto -profile tcl8 utf-8 \uDE02\uD83Dé] binary scan $y H* z list [string length $x] [string length $y] $z } {3 8 edb882eda0bdc3a9} test encoding-15.9 {UtfToUtfProc emoji character output} { set x \uDE02\uD83DX - set y [encoding convertto -nocomplain utf-8 \uDE02\uD83DX] + set y [encoding convertto -profile tcl8 utf-8 \uDE02\uD83DX] binary scan $y H* z list [string length $x] [string length $y] $z } {3 7 edb882eda0bd58} test encoding-15.10 {UtfToUtfProc high surrogate character output} { set x \uDE02é - set y [encoding convertto -nocomplain utf-8 \uDE02é] + set y [encoding convertto -profile tcl8 utf-8 \uDE02é] binary scan $y H* z list [string length $x] [string length $y] $z } {2 5 edb882c3a9} test encoding-15.11 {UtfToUtfProc low surrogate character output} { set x \uDA02é - set y [encoding convertto -nocomplain utf-8 \uDA02é] + set y [encoding convertto -profile tcl8 utf-8 \uDA02é] binary scan $y H* z list [string length $x] [string length $y] $z } {2 5 eda882c3a9} test encoding-15.12 {UtfToUtfProc high surrogate character output} { set x \uDE02Y - set y [encoding convertto -nocomplain utf-8 \uDE02Y] + set y [encoding convertto -profile tcl8 utf-8 \uDE02Y] binary scan $y H* z list [string length $x] [string length $y] $z } {2 4 edb88259} test encoding-15.13 {UtfToUtfProc low surrogate character output} { set x \uDA02Y - set y [encoding convertto -nocomplain utf-8 \uDA02Y] + set y [encoding convertto -profile tcl8 utf-8 \uDA02Y] binary scan $y H* z list [string length $x] [string length $y] $z } {2 4 eda88259} test encoding-15.14 {UtfToUtfProc high surrogate character output} { set x \uDE02 - set y [encoding convertto -nocomplain utf-8 \uDE02] + set y [encoding convertto -profile tcl8 utf-8 \uDE02] binary scan $y H* z list [string length $x] [string length $y] $z } {1 3 edb882} test encoding-15.15 {UtfToUtfProc low surrogate character output} { set x \uDA02 - set y [encoding convertto -nocomplain utf-8 \uDA02] + set y [encoding convertto -profile tcl8 utf-8 \uDA02] binary scan $y H* z list [string length $x] [string length $y] $z } {1 3 eda882} test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} { set x \xF0\xA0\xA1\xC2 - set y [encoding convertfrom -nocomplain utf-8 \xF0\xA0\xA1\xC2] + set y [encoding convertfrom -profile tcl8 utf-8 \xF0\xA0\xA1\xC2] list [string length $x] $y } "4 \xF0\xA0\xA1\xC2" test encoding-15.17 {UtfToUtfProc emoji character output} { @@ -513,10 +513,10 @@ test encoding-17.2 {UtfToUcs2Proc} -body { encoding convertfrom utf-16 [encoding convertto ucs-2 "\U460DC"] } -result "\uFFFD" test encoding-17.3 {UtfToUtf16Proc} -body { - encoding convertto -nocomplain utf-16be "\uDCDC" + encoding convertto -profile tcl8 utf-16be "\uDCDC" } -result "\xDC\xDC" test encoding-17.4 {UtfToUtf16Proc} -body { - encoding convertto -nocomplain utf-16le "\uD8D8" + encoding convertto -profile tcl8 utf-16le "\uD8D8" } -result "\xD8\xD8" test encoding-17.5 {UtfToUtf16Proc} -body { encoding convertto utf-32le "\U460DC" @@ -525,35 +525,35 @@ test encoding-17.6 {UtfToUtf16Proc} -body { encoding convertto utf-32be "\U460DC" } -result "\x00\x04\x60\xDC" test encoding-17.7 {UtfToUtf16Proc} -body { - encoding convertto -strict utf-16be "\uDCDC" + encoding convertto -profile strict utf-16be "\uDCDC" } -returnCodes error -result {unexpected character at index 0: 'U+00DCDC'} test encoding-17.8 {UtfToUtf16Proc} -body { - encoding convertto -strict utf-16le "\uD8D8" + encoding convertto -profile strict utf-16le "\uD8D8" } -returnCodes error -result {unexpected character at index 0: 'U+00D8D8'} test encoding-17.9 {Utf32ToUtfProc} -body { - encoding convertfrom -strict utf-32 "\xFF\xFF\xFF\xFF" + encoding convertfrom -profile strict utf-32 "\xFF\xFF\xFF\xFF" } -returnCodes error -result {unexpected byte sequence starting at index 0: '\xFF'} test encoding-17.10 {Utf32ToUtfProc} -body { - encoding convertfrom -nocomplain utf-32 "\xFF\xFF\xFF\xFF" + encoding convertfrom -profile tcl8 utf-32 "\xFF\xFF\xFF\xFF" } -result \uFFFD test encoding-18.1 {TableToUtfProc on invalid input} -constraints deprecated -body { list [catch {encoding convertto jis0208 \\} res] $res } -result {0 !)} -test encoding-18.2 {TableToUtfProc on invalid input with -strict} -body { - list [catch {encoding convertto -strict jis0208 \\} res] $res +test encoding-18.2 {TableToUtfProc on invalid input with -profile strict} -body { + list [catch {encoding convertto -profile strict jis0208 \\} res] $res } -result {1 {unexpected character at index 0: 'U+00005C'}} -test encoding-18.3 {TableToUtfProc on invalid input with -strict -failindex} -body { - list [catch {encoding convertto -strict -failindex pos jis0208 \\} res] $res $pos +test encoding-18.3 {TableToUtfProc on invalid input with -profile strict -failindex} -body { + list [catch {encoding convertto -profile strict -failindex pos jis0208 \\} res] $res $pos } -result {0 {} 0} -test encoding-18.4 {TableToUtfProc on invalid input with -failindex -strict} -body { - list [catch {encoding convertto -failindex pos -strict jis0208 \\} res] $res $pos +test encoding-18.4 {TableToUtfProc on invalid input with -failindex -profile strict} -body { + list [catch {encoding convertto -failindex pos -profile strict jis0208 \\} res] $res $pos } -result {0 {} 0} test encoding-18.5 {TableToUtfProc on invalid input with -failindex} -body { list [catch {encoding convertto -failindex pos jis0208 \\} res] $res $pos } -result {0 {} 0} -test encoding-18.6 {TableToUtfProc on invalid input with -nocomplain} -body { - list [catch {encoding convertto -nocomplain jis0208 \\} res] $res +test encoding-18.6 {TableToUtfProc on invalid input with -profile tcl8} -body { + list [catch {encoding convertto -profile tcl8 jis0208 \\} res] $res } -result {0 !)} test encoding-19.1 {TableFromUtfProc} { @@ -669,25 +669,25 @@ test encoding-24.4 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC0\x80"] } 1 test encoding-24.5 {Parse valid or invalid utf-8} { - string length [encoding convertfrom -nocomplain utf-8 "\xC0\x81"] + string length [encoding convertfrom -profile tcl8 utf-8 "\xC0\x81"] } 2 test encoding-24.6 {Parse valid or invalid utf-8} { - string length [encoding convertfrom -nocomplain utf-8 "\xC1\xBF"] + string length [encoding convertfrom -profile tcl8 utf-8 "\xC1\xBF"] } 2 test encoding-24.7 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xC2\x80"] } 1 test encoding-24.8 {Parse valid or invalid utf-8} { - string length [encoding convertfrom -nocomplain utf-8 "\xE0\x80\x80"] + string length [encoding convertfrom -profile tcl8 utf-8 "\xE0\x80\x80"] } 3 test encoding-24.9 {Parse valid or invalid utf-8} { - string length [encoding convertfrom -nocomplain utf-8 "\xE0\x9F\xBF"] + string length [encoding convertfrom -profile tcl8 utf-8 "\xE0\x9F\xBF"] } 3 test encoding-24.10 {Parse valid or invalid utf-8} { string length [encoding convertfrom utf-8 "\xE0\xA0\x80"] } 1 test encoding-24.11 {Parse valid or invalid utf-8} { - string length [encoding convertfrom -nocomplain utf-8 "\xEF\xBF\xBF"] + string length [encoding convertfrom -profile tcl8 utf-8 "\xEF\xBF\xBF"] } 1 test encoding-24.12 {Parse valid or invalid utf-8} -constraints deprecated -body { encoding convertfrom utf-8 "\xC0\x81" @@ -713,68 +713,68 @@ test encoding-24.18 {Parse valid or invalid utf-8} -constraints testbytestring - test encoding-24.19 {Parse valid or invalid utf-8} -constraints deprecated -body { encoding convertto utf-8 "ZX\uD800" } -result ZX\xED\xA0\x80 -test encoding-24.20 {Parse with -nocomplain but without providing encoding} { - string length [encoding convertfrom -nocomplain "\x20"] -} 1 -test encoding-24.21 {Parse with -nocomplain but without providing encoding} { - string length [encoding convertto -nocomplain "\x20"] -} 1 +test encoding-24.20 {Parse with -profile tcl8 but without providing encoding} -body { + encoding convertfrom -profile tcl8 "\x20" +} -result {wrong # args: should be "::tcl::encoding::convertfrom ??-profile profile? ?-failindex var? ?encoding?? data"} -returnCodes error +test encoding-24.21 {Parse with -profile tcl8 but without providing encoding} -body { + string length [encoding convertto -profile tcl8 "\x20"] +} -result {::tcl::encoding::convertto ??-profile profile? ?-failindex var? ?encoding?? data} -returnCodes error test encoding-24.22 {Syntax error, two encodings} -body { encoding convertfrom iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-strict? ?-failindex var? ?encoding? data" or "::tcl::encoding::convertfrom -nocomplain ?encoding? data"} +} -returnCodes 1 -result {::tcl::encoding::convertto ??-profile profile? ?-failindex var? ?encoding?? data} test encoding-24.23 {Syntax error, two encodings} -body { encoding convertto iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-strict? ?-failindex var? ?encoding? data" or "::tcl::encoding::convertto -nocomplain ?encoding? data"} -test encoding-24.24 {Parse invalid utf-8 with -strict} -body { - encoding convertfrom -strict utf-8 "\xC0\x80\x00\x00" +} -returnCodes 1 -result {::tcl::encoding::convertto ??-profile profile? ?-failindex var? ?encoding?? data} +test encoding-24.24 {Parse invalid utf-8 with -profile strict} -body { + encoding convertfrom -profile strict utf-8 "\xC0\x80\x00\x00" } -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'} -test encoding-24.25 {Parse invalid utf-8 with -strict} -body { - encoding convertfrom -strict utf-8 "\x40\x80\x00\x00" +test encoding-24.25 {Parse invalid utf-8 with -profile strict} -body { + encoding convertfrom -profile strict utf-8 "\x40\x80\x00\x00" } -returnCodes 1 -result {unexpected byte sequence starting at index 1: '\x80'} -test encoding-24.26 {Parse valid utf-8 with -strict} -body { - encoding convertfrom -strict utf-8 "\xF1\x80\x80\x80" +test encoding-24.26 {Parse valid utf-8 with -profile strict} -body { + encoding convertfrom -profile strict utf-8 "\xF1\x80\x80\x80" } -result \U40000 -test encoding-24.27 {Parse invalid utf-8 with -strict} -body { - encoding convertfrom -strict utf-8 "\xF0\x80\x80\x80" +test encoding-24.27 {Parse invalid utf-8 with -profile strict} -body { + encoding convertfrom -profile strict utf-8 "\xF0\x80\x80\x80" } -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xF0'} -test encoding-24.28 {Parse invalid utf-8 with -strict} -body { - encoding convertfrom -strict utf-8 "\xFF\x00\x00" +test encoding-24.28 {Parse invalid utf-8 with -profile strict} -body { + encoding convertfrom -profile strict utf-8 "\xFF\x00\x00" } -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xFF'} test encoding-24.29 {Parse invalid utf-8} -body { encoding convertfrom utf-8 \xEF\xBF\xBF } -result \uFFFF -test encoding-24.30 {Parse noncharacter with -strict} -body { - encoding convertfrom -strict utf-8 \xEF\xBF\xBF +test encoding-24.30 {Parse noncharacter with -profile strict} -body { + encoding convertfrom -profile strict utf-8 \xEF\xBF\xBF } -result \uFFFF -test encoding-24.31 {Parse invalid utf-8 with -nocomplain} -body { - encoding convertfrom -nocomplain utf-8 \xEF\xBF\xBF +test encoding-24.31 {Parse invalid utf-8 with -profile tcl8} -body { + encoding convertfrom -profile tcl8 utf-8 \xEF\xBF\xBF } -result \uFFFF test encoding-24.32 {Try to generate invalid utf-8} -body { encoding convertto utf-8 \uFFFF } -result \xEF\xBF\xBF -test encoding-24.33 {Try to generate noncharacter with -strict} -body { - encoding convertto -strict utf-8 \uFFFF +test encoding-24.33 {Try to generate noncharacter with -profile strict} -body { + encoding convertto -profile strict utf-8 \uFFFF } -result \xEF\xBF\xBF -test encoding-24.34 {Try to generate invalid utf-8 with -nocomplain} -body { - encoding convertto -nocomplain utf-8 \uFFFF +test encoding-24.34 {Try to generate invalid utf-8 with -profile tcl8} -body { + encoding convertto -profile tcl8 utf-8 \uFFFF } -result \xEF\xBF\xBF test encoding-24.35 {Parse invalid utf-8} -constraints deprecated -body { encoding convertfrom utf-8 \xED\xA0\x80 } -result \uD800 -test encoding-24.36 {Parse invalid utf-8 with -strict} -body { - encoding convertfrom -strict utf-8 \xED\xA0\x80 +test encoding-24.36 {Parse invalid utf-8 with -profile strict} -body { + encoding convertfrom -profile strict utf-8 \xED\xA0\x80 } -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xED'} -test encoding-24.37 {Parse invalid utf-8 with -nocomplain} -body { - encoding convertfrom -nocomplain utf-8 \xED\xA0\x80 +test encoding-24.37 {Parse invalid utf-8 with -profile tcl8} -body { + encoding convertfrom -profile tcl8 utf-8 \xED\xA0\x80 } -result \uD800 test encoding-24.38 {Try to generate invalid utf-8} -constraints deprecated -body { encoding convertto utf-8 \uD800 } -result \xED\xA0\x80 -test encoding-24.39 {Try to generate invalid utf-8 with -strict} -body { - encoding convertto -strict utf-8 \uD800 +test encoding-24.39 {Try to generate invalid utf-8 with -profile strict} -body { + encoding convertto -profile strict utf-8 \uD800 } -returnCodes 1 -result {unexpected character at index 0: 'U+00D800'} -test encoding-24.40 {Try to generate invalid utf-8 with -nocomplain} -body { - encoding convertto -nocomplain utf-8 \uD800 +test encoding-24.40 {Try to generate invalid utf-8 with -profile tcl8} -body { + encoding convertto -profile tcl8 utf-8 \uD800 } -result \xED\xA0\x80 file delete [file join [temporaryDirectory] iso2022.txt] @@ -931,7 +931,7 @@ test encoding-28.0 {all encodings load} -body { set string hello foreach name [encoding names] { incr count - encoding convertto -nocomplain $name $string + encoding convertto -profile tcl8 $name $string # discard the cached internal representation of Tcl_Encoding # Unfortunately, without this, encoding 2-1 fails. -- cgit v0.12 From 26e89b4b3c03b100a2a461c034c1930a23a4273b Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 2 Feb 2023 12:23:37 +0000 Subject: Use common option parsing for ConvertfromObjCmd. Fix test error messages. --- generic/tclCmdAH.c | 76 ++++------------------------------------------------- tests/encoding.test | 6 ++--- 2 files changed, 8 insertions(+), 74 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 818159d..67f76a6 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -683,81 +683,15 @@ EncodingConvertfromObjCmd( Tcl_Encoding encoding; /* Encoding to use */ int length; /* Length of the byte array being converted */ const char *bytesPtr; /* Pointer to the first byte of the array */ -#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) - int flags = TCL_ENCODING_STOPONERROR; -#else - int flags = TCL_ENCODING_NOCOMPLAIN; -#endif + int flags; int result; - Tcl_Obj *failVarObj = NULL; - static const char *const options[] = {"-profile", "-failindex", NULL}; - enum convertfromOptions { PROFILE, FAILINDEX } optIndex; - enum TclEncodingProfile profile; - - /* - * Possible combinations: - * 1) data -> objc = 2 - * 2) ?options? encoding data -> objc >= 3 - * It is intentional that specifying option forces encoding to be - * specified. Less prone to user error. This should have always been - * the case even in 8.6 imho where there were no options (ie (1) - * should never have been allowed) - */ + Tcl_Obj *failVarObj; - if (objc == 1) { -numArgsError: /* ONLY jump here if nothing needs to be freed!!! */ - Tcl_WrongNumArgs( - interp, - 1, - objv, - "??-profile profile? ?-failindex var? ?encoding?? data"); + if (EncodingConvertParseOptions( + interp, objc, objv, 1, &encoding, &data, &flags, &failVarObj) + != TCL_OK) { return TCL_ERROR; } - else if (objc == 2) { - encoding = Tcl_GetEncoding(interp, NULL); - data = objv[1]; - } else { - int argIndex; - for (argIndex = 1; argIndex < (objc-2); ++argIndex) { - if (Tcl_GetIndexFromObj( - interp, objv[argIndex], options, "option", 0, &optIndex) - != TCL_OK) { - return TCL_ERROR; - } - if (++argIndex == (objc - 2)) { - goto numArgsError; - } - switch (optIndex) { - case PROFILE: - if (TclEncodingProfileParseName( - interp, objv[argIndex], &profile) - != TCL_OK) { - return TCL_ERROR; - } - switch (profile) { - case TCL_ENCODING_PROFILE_TCL8: - flags = TCL_ENCODING_NOCOMPLAIN; - break; - case TCL_ENCODING_PROFILE_STRICT: - flags = TCL_ENCODING_STRICT; - break; - case TCL_ENCODING_PROFILE_DEFAULT: /* FALLTHRU */ - default: - break; - } - break; - case FAILINDEX: - failVarObj = objv[argIndex]; - break; - } - } - /* Get encoding after opts so no need to free it on option error */ - if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) - != TCL_OK) { - return TCL_ERROR; - } - data = objv[objc - 1]; - } /* * Convert the string into a byte array in 'ds' diff --git a/tests/encoding.test b/tests/encoding.test index 813cd84..e4a2acb 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -718,13 +718,13 @@ test encoding-24.20 {Parse with -profile tcl8 but without providing encoding} -b } -result {wrong # args: should be "::tcl::encoding::convertfrom ??-profile profile? ?-failindex var? ?encoding?? data"} -returnCodes error test encoding-24.21 {Parse with -profile tcl8 but without providing encoding} -body { string length [encoding convertto -profile tcl8 "\x20"] -} -result {::tcl::encoding::convertto ??-profile profile? ?-failindex var? ?encoding?? data} -returnCodes error +} -result {wrong # args: should be "::tcl::encoding::convertto ??-profile profile? ?-failindex var? ?encoding?? data"} -returnCodes error test encoding-24.22 {Syntax error, two encodings} -body { encoding convertfrom iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {::tcl::encoding::convertto ??-profile profile? ?-failindex var? ?encoding?? data} +} -result {bad option "iso8859-1": must be -profile or -failindex} -returnCodes error test encoding-24.23 {Syntax error, two encodings} -body { encoding convertto iso8859-1 utf-8 "ZX\uD800" -} -returnCodes 1 -result {::tcl::encoding::convertto ??-profile profile? ?-failindex var? ?encoding?? data} +} -result {bad option "iso8859-1": must be -profile or -failindex} -returnCodes error test encoding-24.24 {Parse invalid utf-8 with -profile strict} -body { encoding convertfrom -profile strict utf-8 "\xC0\x80\x00\x00" } -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'} -- cgit v0.12 From e31133e3b0149b9bc29c9c6f06e76ccc6994df7e Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 2 Feb 2023 15:37:21 +0000 Subject: Change encoding error options to fconfigure to encoding profiles --- generic/tclCmdAH.c | 2 +- generic/tclEncoding.c | 23 +++++++++++------ generic/tclIO.c | 69 ++++++++++++++++----------------------------------- generic/tclInt.h | 2 +- 4 files changed, 39 insertions(+), 57 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 67f76a6..9165fda 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -611,7 +611,7 @@ numArgsError: /* ONLY jump here if nothing needs to be freed!!! */ switch (optIndex) { case PROFILE: if (TclEncodingProfileParseName( - interp, objv[argIndex], &profile) + interp, Tcl_GetString(objv[argIndex]), &profile) != TCL_OK) { return TCL_ERROR; } diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index bdd091f..55ace3c 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -4102,20 +4102,29 @@ InitializeEncodingSearchPath( int TclEncodingProfileParseName( Tcl_Interp *interp, /* For error messages. May be NULL */ - Tcl_Obj *profileName, /* Name of profile */ + const char *profileName, /* Name of profile */ enum TclEncodingProfile *profilePtr) /* Output */ { /* NOTE: Order must match enum TclEncodingProfile !!! */ static const char *const profileNames[] = {"", "tcl8", "strict"}; int idx; - if (Tcl_GetIndexFromObj( - interp, profileName, profileNames, "profile", 0, &idx) - != TCL_OK) { - return TCL_ERROR; + for (idx = 0; idx < sizeof(profileNames) / sizeof(profileNames[0]); ++idx) { + if (!strcmp(profileName, profileNames[idx])) { + *profilePtr = (enum TclEncodingProfile)idx; + return TCL_OK; + } } - *profilePtr = (enum TclEncodingProfile)idx; - return TCL_OK; + if (interp) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf( + "bad profile \"%s\". Must be \"\", \"tcl8\" or \"strict\".", + profileName)); + Tcl_SetErrorCode( + interp, "TCL", "ENCODING", "PROFILE", profileName, NULL); + } + return TCL_ERROR; } /* diff --git a/generic/tclIO.c b/generic/tclIO.c index fed469c..47740ef 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -7862,7 +7862,7 @@ Tcl_BadChannelOption( { if (interp != NULL) { const char *genericopt = - "blocking buffering buffersize encoding eofchar nocomplainencoding strictencoding translation"; + "blocking buffering buffersize encoding encodingprofile eofchar translation"; const char **argv; int argc, i; Tcl_DString ds; @@ -8060,27 +8060,17 @@ Tcl_GetChannelOption( return TCL_OK; } } - if (len == 0 || HaveOpt(1, "-nocomplainencoding")) { + if (len == 0 || HaveOpt(1, "-encodingprofile")) { if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-nocomplainencoding"); + Tcl_DStringAppendElement(dsPtr, "-encodingprofile"); } -#ifdef TCL_NO_DEPRECATED - Tcl_DStringAppendElement(dsPtr, - (flags & CHANNEL_ENCODING_NOCOMPLAIN) ? "1" : "0"); -#else - Tcl_DStringAppendElement(dsPtr, - (flags & CHANNEL_ENCODING_STRICT) ? "0" : "1"); -#endif - if (len > 0) { - return TCL_OK; - } - } - if (len == 0 || HaveOpt(1, "-strictencoding")) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-strictencoding"); + if (flags & CHANNEL_ENCODING_STRICT) { + Tcl_DStringAppendElement(dsPtr, "strict"); + } else if (flags & CHANNEL_ENCODING_NOCOMPLAIN) { + Tcl_DStringAppendElement(dsPtr, "tcl8"); + } else { + Tcl_DStringAppendElement(dsPtr, ""); } - Tcl_DStringAppendElement(dsPtr, - (flags & CHANNEL_ENCODING_STRICT) ? "1" : "0"); if (len > 0) { return TCL_OK; } @@ -8341,42 +8331,25 @@ Tcl_SetChannelOption( ResetFlag(statePtr, CHANNEL_EOF|CHANNEL_STICKY_EOF|CHANNEL_BLOCKED); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; return TCL_OK; - } else if (HaveOpt(1, "-nocomplainencoding")) { - int newMode; - - if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { + } else if (HaveOpt(1, "-encodingprofile")) { + enum TclEncodingProfile profile; + if (TclEncodingProfileParseName(interp, newValue, &profile) != TCL_OK) { return TCL_ERROR; } - if (newMode) { + switch (profile) { + case TCL_ENCODING_PROFILE_TCL8: ResetFlag(statePtr, CHANNEL_ENCODING_STRICT); SetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); - } else { -#ifdef TCL_NO_DEPRECATED - ResetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); -#else - if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT) != CHANNEL_ENCODING_STRICT) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad value for -nocomplainencoding: only true allowed", - TCL_INDEX_NONE)); - } - return TCL_ERROR; - } -#endif - } - ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA|CHANNEL_ENCODING_ERROR); - return TCL_OK; - } else if (HaveOpt(1, "-strictencoding")) { - int newMode; - - if (Tcl_GetBoolean(interp, newValue, &newMode) == TCL_ERROR) { - return TCL_ERROR; - } - if (newMode) { + break; + case TCL_ENCODING_PROFILE_STRICT: ResetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); SetFlag(statePtr, CHANNEL_ENCODING_STRICT); - } else { + break; + case TCL_ENCODING_PROFILE_DEFAULT: /* FALLTHRU */ + default: + ResetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); ResetFlag(statePtr, CHANNEL_ENCODING_STRICT); + break; } ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA|CHANNEL_ENCODING_ERROR); return TCL_OK; diff --git a/generic/tclInt.h b/generic/tclInt.h index db8ee9f..82728d3 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2896,7 +2896,7 @@ enum TclEncodingProfile { MODULE_SCOPE Tcl_Encoding tclIdentityEncoding; MODULE_SCOPE int TclEncodingProfileParseName(Tcl_Interp *interp, - Tcl_Obj *profileName, + const char *profileName, enum TclEncodingProfile *profilePtr); /* -- cgit v0.12 From 100d8ce724b2ed4d9f15a045bc2e48119b53465f Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 2 Feb 2023 16:43:12 +0000 Subject: Update tests to use -encodingprofile --- generic/tclIO.c | 30 +++++++++++++++--------------- tests/chanio.test | 6 +++--- tests/io.test | 44 ++++++++++++++++++++++---------------------- tests/ioCmd.test | 26 ++++++++++++++------------ tests/winConsole.test | 14 +++++++------- tests/zlib.test | 4 ++-- 6 files changed, 63 insertions(+), 61 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 47740ef..b76234b 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8017,6 +8017,21 @@ Tcl_GetChannelOption( return TCL_OK; } } + if (len == 0 || HaveOpt(1, "-encodingprofile")) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-encodingprofile"); + } + if (flags & CHANNEL_ENCODING_STRICT) { + Tcl_DStringAppendElement(dsPtr, "strict"); + } else if (flags & CHANNEL_ENCODING_NOCOMPLAIN) { + Tcl_DStringAppendElement(dsPtr, "tcl8"); + } else { + Tcl_DStringAppendElement(dsPtr, ""); + } + if (len > 0) { + return TCL_OK; + } + } if (len == 0 || HaveOpt(2, "-eofchar")) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-eofchar"); @@ -8060,21 +8075,6 @@ Tcl_GetChannelOption( return TCL_OK; } } - if (len == 0 || HaveOpt(1, "-encodingprofile")) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-encodingprofile"); - } - if (flags & CHANNEL_ENCODING_STRICT) { - Tcl_DStringAppendElement(dsPtr, "strict"); - } else if (flags & CHANNEL_ENCODING_NOCOMPLAIN) { - Tcl_DStringAppendElement(dsPtr, "tcl8"); - } else { - Tcl_DStringAppendElement(dsPtr, ""); - } - if (len > 0) { - return TCL_OK; - } - } if (len == 0 || HaveOpt(1, "-translation")) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-translation"); diff --git a/tests/chanio.test b/tests/chanio.test index fb94051..7c9857d 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -252,7 +252,7 @@ test chan-io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} -bod test chan-io-3.4 {WriteChars: loop over stage buffer} -body { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] - chan configure $f -encoding jis0208 -buffersize 16 -nocomplainencoding 1 + chan configure $f -encoding jis0208 -buffersize 16 -profile tcl8 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] chan close $f @@ -265,7 +265,7 @@ test chan-io-3.5 {WriteChars: saved != 0} -body { # be moved to beginning of next channel buffer to preserve requested # buffersize. set f [open $path(test1) w] - chan configure $f -encoding jis0208 -buffersize 17 -nocomplainencoding 1 + chan configure $f -encoding jis0208 -buffersize 17 -profile tcl8 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] chan close $f @@ -298,7 +298,7 @@ test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -body { # on flush. The truncated bytes are moved to the beginning of the next # channel buffer. set f [open $path(test1) w] - chan configure $f -encoding jis0208 -buffersize 17 -nocomplainencoding 1 + chan configure $f -encoding jis0208 -buffersize 17 -profile tcl8 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] chan close $f diff --git a/tests/io.test b/tests/io.test index 2708906..efc6374 100644 --- a/tests/io.test +++ b/tests/io.test @@ -272,7 +272,7 @@ test io-3.4 {WriteChars: loop over stage buffer} -body { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 16 -nocomplainencoding 1 + fconfigure $f -encoding jis0208 -buffersize 16 -encodingprofile tcl8 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -286,7 +286,7 @@ test io-3.5 {WriteChars: saved != 0} -body { # requested buffersize. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 17 -nocomplainencoding 1 + fconfigure $f -encoding jis0208 -buffersize 17 -encodingprofile tcl8 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -319,7 +319,7 @@ test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} -body { # of the next channel buffer. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 17 -nocomplainencoding 1 + fconfigure $f -encoding jis0208 -buffersize 17 -encodingprofile tcl8 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -8964,7 +8964,7 @@ test io-75.1 {multibyte encoding error read results in raw bytes} -setup { puts -nonewline $f A\xC0\x40 flush $f seek $f 0 - fconfigure $f -encoding utf-8 -nocomplainencoding 1 -buffering none + fconfigure $f -encoding utf-8 -encodingprofile tcl8 -buffering none } -body { set d [read $f] binary scan $d H* hd @@ -8974,10 +8974,10 @@ test io-75.1 {multibyte encoding error read results in raw bytes} -setup { removeFile io-75.1 } -result 41c040 -test io-75.2 {unrepresentable character write passes and is replaced by ? (-nocomplainencoding 1)} -setup { +test io-75.2 {unrepresentable character write passes and is replaced by ? (-encodingprofile tcl8)} -setup { set fn [makeFile {} io-75.2] set f [open $fn w+] - fconfigure $f -encoding iso8859-1 -nocomplainencoding 1 + fconfigure $f -encoding iso8859-1 -encodingprofile tcl8 } -body { puts -nonewline $f A\u2022 flush $f @@ -8991,14 +8991,14 @@ test io-75.2 {unrepresentable character write passes and is replaced by ? (-noco # Incomplete sequence test. # This error may IMHO only be detected with the close. # But the read already returns the incomplete sequence. -test io-75.3 {incomplete multibyte encoding read is ignored (-nocomplainencoding 1)} -setup { +test io-75.3 {incomplete multibyte encoding read is ignored (-encodingprofile tcl8)} -setup { set fn [makeFile {} io-75.3] set f [open $fn w+] fconfigure $f -encoding binary puts -nonewline $f "A\xC0" flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -nocomplainencoding 1 + fconfigure $f -encoding utf-8 -buffering none -encodingprofile tcl8 } -body { set d [read $f] close $f @@ -9010,7 +9010,7 @@ test io-75.3 {incomplete multibyte encoding read is ignored (-nocomplainencoding # As utf-8 has a special treatment in multi-byte decoding, also test another # one. -test io-75.4 {shiftjis encoding error read results in raw bytes (-nocomplainencoding 1)} -setup { +test io-75.4 {shiftjis encoding error read results in raw bytes (-encodingprofile tcl8)} -setup { set fn [makeFile {} io-75.4] set f [open $fn w+] fconfigure $f -encoding binary @@ -9019,7 +9019,7 @@ test io-75.4 {shiftjis encoding error read results in raw bytes (-nocomplainenco puts -nonewline $f A\x81\xFFA flush $f seek $f 0 - fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf -nocomplainencoding 1 + fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf -encodingprofile tcl8 } -body { set d [read $f] binary scan $d H* hd @@ -9029,14 +9029,14 @@ test io-75.4 {shiftjis encoding error read results in raw bytes (-nocomplainenco removeFile io-75.4 } -result 4181ff41 -test io-75.5 {invalid utf-8 encoding read is ignored (-nocomplainencoding 1)} -setup { +test io-75.5 {invalid utf-8 encoding read is ignored (-encodingprofile tcl8)} -setup { set fn [makeFile {} io-75.5] set f [open $fn w+] fconfigure $f -encoding binary puts -nonewline $f A\x81 flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -nocomplainencoding 1 + fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -encodingprofile tcl8 } -body { set d [read $f] close $f @@ -9046,7 +9046,7 @@ test io-75.5 {invalid utf-8 encoding read is ignored (-nocomplainencoding 1)} -s removeFile io-75.5 } -result 4181 -test io-75.6 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} -setup { +test io-75.6 {invalid utf-8 encoding read is not ignored (-encodingprofile strict)} -setup { set fn [makeFile {} io-75.6] set f [open $fn w+] fconfigure $f -encoding binary @@ -9054,7 +9054,7 @@ test io-75.6 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} -s puts -nonewline $f A\x81 flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -strictencoding 1 + fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -encodingprofile strict } -body { set d [read $f] binary scan $d H* hd @@ -9065,7 +9065,7 @@ test io-75.6 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} -s removeFile io-75.6 } -match glob -result {41 1 {error reading "*": illegal byte sequence}} -test io-75.7 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { +test io-75.7 {invalid utf-8 encoding eof handling (-encodingprofile strict)} -setup { set fn [makeFile {} io-75.7] set f [open $fn w+] fconfigure $f -encoding binary @@ -9073,7 +9073,7 @@ test io-75.7 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { puts -nonewline $f A\xA1\x1A flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -strictencoding 1 + fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -encodingprofile strict } -body { set d [read $f] binary scan $d H* hd @@ -9088,7 +9088,7 @@ test io-75.7 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { removeFile io-75.7 } -match glob -result {41 0 1 {error reading "*": illegal byte sequence} ¡} -test io-75.8 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { +test io-75.8 {invalid utf-8 encoding eof handling (-encodingprofile strict)} -setup { set fn [makeFile {} io-75.8] set f [open $fn w+] fconfigure $f -encoding binary @@ -9096,7 +9096,7 @@ test io-75.8 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { puts -nonewline $f A\x1A\x81 flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -strictencoding 1 + fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -encodingprofile strict } -body { set d [read $f] binary scan $d H* hd @@ -9111,7 +9111,7 @@ test io-75.8 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { test io-75.9 {unrepresentable character write passes and is replaced by ?} -setup { set fn [makeFile {} io-75.9] set f [open $fn w+] - fconfigure $f -encoding iso8859-1 -strictencoding 1 + fconfigure $f -encoding iso8859-1 -encodingprofile strict } -body { catch {puts -nonewline $f "A\u2022"} msg flush $f @@ -9155,7 +9155,7 @@ test io-75.11 {shiftjis encoding error read results in raw bytes} -setup { puts -nonewline $f A\x81\xFFA flush $f seek $f 0 - fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf -strictencoding 1 + fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf -encodingprofile strict } -body { set d [read $f] binary scan $d H* hd @@ -9182,7 +9182,7 @@ test io-75.12 {invalid utf-8 encoding read is ignored} -setup { } -cleanup { removeFile io-75.12 } -result 4181 -test io-75.13 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} -setup { +test io-75.13 {invalid utf-8 encoding read is not ignored (-encodingprofile strict)} -setup { set fn [makeFile {} io-75.13] set f [open $fn w+] fconfigure $f -encoding binary @@ -9190,7 +9190,7 @@ test io-75.13 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} - puts -nonewline $f "A\x81" flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -strictencoding 1 + fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -encodingprofile strict } -body { set d [read $f] binary scan $d H* hd diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 1a72f70..8c9d870 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -207,7 +207,7 @@ test iocmd-7.5 {close command} -setup { proc expectedOpts {got extra} { set basicOpts { - -blocking -buffering -buffersize -encoding -eofchar -nocomplainencoding -strictencoding -translation + -blocking -buffering -buffersize -encoding -encodingprofile -eofchar -translation } set opts [list {*}$basicOpts {*}$extra] lset opts end [string cat "or " [lindex $opts end]] @@ -240,33 +240,33 @@ test iocmd-8.7 {fconfigure command} -setup { file delete $path(test1) } -body { set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} -encoding utf-16 -nocomplainencoding 1 + fconfigure $f1 -translation lf -eofchar {} -encoding utf-16 -encodingprofile tcl8 fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -nocomplainencoding 1 -strictencoding 0 -translation lf} +} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -encodingprofile tcl8 -eofchar {} -translation lf} test iocmd-8.8 {fconfigure command} -setup { file delete $path(test1) set x {} } -body { set f1 [open $path(test1) w] fconfigure $f1 -translation lf -buffering line -buffersize 3030 \ - -eofchar {} -encoding utf-16 -nocomplainencoding 1 + -eofchar {} -encoding utf-16 -encodingprofile tcl8 lappend x [fconfigure $f1 -buffering] lappend x [fconfigure $f1] } -cleanup { catch {close $f1} -} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -nocomplainencoding 1 -strictencoding 0 -translation lf}} +} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -encodingprofile tcl8 -eofchar {} -translation lf}} test iocmd-8.9 {fconfigure command} -setup { file delete $path(test1) } -body { set f1 [open $path(test1) w] fconfigure $f1 -translation binary -buffering none -buffersize 4040 \ - -eofchar {} -encoding binary -nocomplainencoding 1 + -eofchar {} -encoding binary -encodingprofile tcl8 fconfigure $f1 } -cleanup { catch {close $f1} -} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -nocomplainencoding 1 -strictencoding 0 -translation lf} +} -result {-blocking 1 -buffering none -buffersize 4040 -encoding binary -encodingprofile tcl8 -eofchar {} -translation lf} test iocmd-8.10 {fconfigure command} -returnCodes error -body { fconfigure a b } -result {can not find channel named "a"} @@ -369,7 +369,7 @@ test iocmd-8.20 {fconfigure command / win console channel} -constraints {nonPort # TODO: Test parsing of serial channel options (nonPortable, since requires an # open channel to work with). test iocmd-8.21 {fconfigure command / -nocomplainencoding 0 error} -constraints { - deprecated + deprecated obsolete } -setup { # I don't know how else to open the console, but this is non-portable set console stdin @@ -378,7 +378,9 @@ test iocmd-8.21 {fconfigure command / -nocomplainencoding 0 error} -constraints } -returnCodes error -result "bad value for -nocomplainencoding: only true allowed" test iocmd-8.22 {fconfigure command / -nocomplainencoding 0, no error if -strictencoding already defined} -setup { set console stdin - set oldmode [fconfigure $console -strictencoding] + set oldprofile [fconfigure $console -encodingprofile] +} -constraints { + obsolete } -body { fconfigure $console -strictencoding 1 fconfigure $console -nocomplainencoding 0 @@ -1381,7 +1383,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { close $c rename foo {} set res -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -nocomplainencoding * -strictencoding 0 -translation {auto *}}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -encodingprofile * -eofchar {{} {}} -translation {auto *}}} test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} @@ -1390,7 +1392,7 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -nocomplainencoding * -strictencoding 0 -translation {auto *}}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -encodingprofile * -eofchar {{} {}} -translation {auto *}}} test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { set res {} proc foo {args} { @@ -1402,7 +1404,7 @@ test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { close $c rename foo {} set res -} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -nocomplainencoding * -strictencoding 0 -translation {auto *} -bar foo -snarf x}} +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -encodingprofile * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}} test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { set res {} proc foo {args} { diff --git a/tests/winConsole.test b/tests/winConsole.test index b04f3e9..62dfbf3 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -198,7 +198,7 @@ test console-fconfigure-get-1.0 { Console get stdin configuration } -constraints {win interactive} -body { lsort [dict keys [fconfigure stdin]] -} -result {-blocking -buffering -buffersize -encoding -eofchar -inputmode -translation} +} -result {-blocking -buffering -buffersize -encoding -encodingprofile -eofchar -inputmode -translation} set testnum 0 foreach {opt result} { @@ -224,7 +224,7 @@ test console-fconfigure-get-1.[incr testnum] { fconfigure -winsize } -constraints {win interactive} -body { fconfigure stdin -winsize -} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -nocomplainencoding, -strictencoding, -translation, or -inputmode} -returnCodes error +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -encodingprofile, -eofchar, -translation, or -inputmode} -returnCodes error ## fconfigure get stdout/stderr foreach chan {stdout stderr} major {2 3} { @@ -232,7 +232,7 @@ foreach chan {stdout stderr} major {2 3} { win interactive } -body { lsort [dict keys [fconfigure $chan]] - } -result {-blocking -buffering -buffersize -encoding -eofchar -translation -winsize} + } -result {-blocking -buffering -buffersize -encoding -encodingprofile -eofchar -translation -winsize} set testnum 0 foreach {opt result} { -blocking 1 @@ -260,7 +260,7 @@ foreach chan {stdout stderr} major {2 3} { fconfigure -inputmode } -constraints {win interactive} -body { fconfigure $chan -inputmode - } -result {bad option "-inputmode": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -nocomplainencoding, -strictencoding, -translation, or -winsize} -returnCodes error + } -result {bad option "-inputmode": should be one of -blocking, -buffering, -buffersize, -encoding, -encodingprofile, -eofchar, -translation, or -winsize} -returnCodes error } @@ -330,7 +330,7 @@ test console-fconfigure-set-1.3 { fconfigure stdin -winsize } -constraints {win interactive} -body { fconfigure stdin -winsize {10 30} -} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -nocomplainencoding, -strictencoding, -translation, or -inputmode} -returnCodes error +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -encodingprofile, -eofchar, -translation, or -inputmode} -returnCodes error ## fconfigure set stdout,stderr @@ -338,13 +338,13 @@ test console-fconfigure-set-2.0 { fconfigure stdout -winsize } -constraints {win interactive} -body { fconfigure stdout -winsize {10 30} -} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -nocomplainencoding, -strictencoding, or -translation} -returnCodes error +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -encodingprofile, -eofchar, or -translation} -returnCodes error test console-fconfigure-set-3.0 { fconfigure stderr -winsize } -constraints {win interactive} -body { fconfigure stderr -winsize {10 30} -} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -nocomplainencoding, -strictencoding, or -translation} -returnCodes error +} -result {bad option "-winsize": should be one of -blocking, -buffering, -buffersize, -encoding, -encodingprofile, -eofchar, or -translation} -returnCodes error # Multiple threads diff --git a/tests/zlib.test b/tests/zlib.test index ebbdd50..272a663 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -292,7 +292,7 @@ test zlib-8.6 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -strictencoding 0 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -strictencoding 0 -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -strictencoding 0 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -encodingprofile {} -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -encodingprofile {} -eofchar {} -translation lf -checksum 1 -dictionary {}} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -encodingprofile {} -eofchar {} -translation lf}} test zlib-8.7 {transformation and fconfigure} -setup { set file [makeFile {} test.gz] set fd [open $file wb] @@ -302,7 +302,7 @@ test zlib-8.7 {transformation and fconfigure} -setup { } -cleanup { catch {close $fd} removeFile $file -} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -strictencoding 0 -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -strictencoding 0 -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -eofchar {} -nocomplainencoding 1 -strictencoding 0 -translation lf}} +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding binary -encodingprofile {} -eofchar {} -translation lf} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -encodingprofile {} -eofchar {} -translation lf -checksum 0} {-blocking 1 -buffering full -buffersize 4096 -encoding binary -encodingprofile {} -eofchar {} -translation lf}} # Input is headers from fetching SPDY draft # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" -- cgit v0.12 From 52fc9a970c0239d9f74fd6313920572315e757a7 Mon Sep 17 00:00:00 2001 From: pooryorick Date: Thu, 2 Feb 2023 22:51:26 +0000 Subject: Fix for [b8f575aa2398b0e4] and [154ed7ce564a7b4c], double-[read]/[gets] problem. Partial-read functionality commented out. --- generic/tclIOCmd.c | 6 +- tests/io.test | 450 ++++++++++++++++++++++++++++++++++------------------- 2 files changed, 297 insertions(+), 159 deletions(-) diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 2eeb04c..5b47b08 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -331,14 +331,16 @@ Tcl_GetsObjCmd( "error reading \"%s\": %s", TclGetString(chanObjPtr), Tcl_PosixError(interp))); } + /* resultDictPtr = Tcl_NewDictObj(); Tcl_DictObjPut(NULL, resultDictPtr, Tcl_NewStringObj("read", -1) , linePtr); returnOptsPtr = Tcl_NewDictObj(); Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-result", -1) , resultDictPtr); - code = TCL_ERROR; Tcl_SetReturnOptions(interp, returnOptsPtr); + */ + code = TCL_ERROR; goto done; } lineLen = TCL_INDEX_NONE; @@ -476,6 +478,7 @@ Tcl_ReadObjCmd( "error reading \"%s\": %s", TclGetString(chanObjPtr), Tcl_PosixError(interp))); } + /* resultDictPtr = Tcl_NewDictObj(); Tcl_DictObjPut(NULL, resultDictPtr, Tcl_NewStringObj("read", -1) , resultPtr); @@ -485,6 +488,7 @@ Tcl_ReadObjCmd( TclChannelRelease(chan); Tcl_DecrRefCount(resultPtr); Tcl_SetReturnOptions(interp, returnOptsPtr); + */ return TCL_ERROR; } diff --git a/tests/io.test b/tests/io.test index 3f00561..5bf5f10 100644 --- a/tests/io.test +++ b/tests/io.test @@ -1560,19 +1560,29 @@ apply [list {} { set f [open $path(test1)] fconfigure $f -encoding utf-8 @strict@ -buffersize 10 set status [catch {read $f} cres copts] - set in [dict get $copts -result] - lappend res $in + #set in [dict get $copts -result] + #lappend res $in lappend res $status $cres set status [catch {read $f} cres copts] - set in [dict get $copts -result] - lappend res $in + #set in [dict get $copts -result] + #lappend res $in lappend res $status $cres set res } -cleanup { catch {close $f} - } -match glob -result {{read aaaaaaaaa} 1\ + } -match glob\ + } + + #append template {\ + # -result {{read aaaaaaaaa} 1\ + # {error reading "*": illegal byte sequence}\ + # {read {}} 1 {error reading "*": illegal byte sequence}} + #} + + append template {\ + -result {1\ {error reading "*": illegal byte sequence}\ - {read {}} 1 {error reading "*": illegal byte sequence}} + 1 {error reading "*": illegal byte sequence}} } # strict encoding may be the default in Tcl 9, but in 8 it is not @@ -9070,48 +9080,83 @@ test io-75.5 {invalid utf-8 encoding read is ignored (-nocomplainencoding 1)} -s removeFile io-75.5 } -result 4181 -test io-75.6 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} -setup { - set fn [makeFile {} io-75.6] - set f [open $fn w+] - fconfigure $f -encoding binary - # \x81 is invalid in utf-8 - puts -nonewline $f A\x81 - flush $f - seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -strictencoding 1 -} -body { - set status [catch {read $f} cres copts] - set d [dict get $copts -result read] - binary scan $d H* hd - lappend hd $status $cres -} -cleanup { - close $f - removeFile io-75.6 -} -match glob -result {41 1 {error reading "*": illegal byte sequence}} -test io-75.7 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { - set fn [makeFile {} io-75.7] - set f [open $fn w+] - fconfigure $f -encoding binary - # \xA1 is invalid in utf-8. -eofchar is not detected, because it comes later. - puts -nonewline $f A\xA1\x1A - flush $f - seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -strictencoding 1 -} -body { - set status [catch {read $f} cres copts] - set d [dict get $copts -result read] - binary scan $d H* hd - lappend hd [eof $f] - lappend hd $status - lappend hd $cres - fconfigure $f -encoding iso8859-1 - lappend hd [read $f];# We changed encoding, so now we can read the \xA1 - close $f - set hd -} -cleanup { - removeFile io-75.7 -} -match glob -result {41 0 1 {error reading "*": illegal byte sequence} ¡} +apply [list {} { + + + set test { + test io-75.6 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} -setup { + set hd {} + set fn [makeFile {} io-75.6] + set f [open $fn w+] + fconfigure $f -encoding binary + # \x81 is invalid in utf-8 + puts -nonewline $f A\x81 + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -strictencoding 1 + } -body { + set status [catch {read $f} cres copts] + #set d [dict get $copts -result read] + #binary scan $d H* hd + lappend hd $status $cres + } -cleanup { + close $f + removeFile io-75.6 + } -match glob\ + } + + #append test {\ + # -result {41 1 {error reading "*": illegal byte sequence}} + #} + + append test {\ + -result {1 {error reading "*": illegal byte sequence}} + } + + uplevel 1 $test + + set test { + test io-75.7 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { + set hd {} + set fn [makeFile {} io-75.7] + set f [open $fn w+] + fconfigure $f -encoding binary + # \xA1 is invalid in utf-8. -eofchar is not detected, because it comes later. + puts -nonewline $f A\xA1\x1A + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -strictencoding 1 + } -body { + set status [catch {read $f} cres copts] + #set d [dict get $copts -result read] + #binary scan $d H* hd + lappend hd [eof $f] + lappend hd $status + lappend hd $cres + fconfigure $f -encoding iso8859-1 + lappend hd [read $f];# We changed encoding, so now we can read the \xA1 + close $f + set hd + } -cleanup { + removeFile io-75.7 + } -match glob\ + } + + #append test {\ + # -result {41 0 1 {error reading "*": illegal byte sequence} ¡} + #} + + append test {\ + -result {0 1 {error reading "*": illegal byte sequence} ¡} + } + + uplevel 1 $test + + +} [namespace current]] + + test io-75.8.incomplete { incomplete uft-8 char after eof char is not an error (-strictencoding 1) @@ -9198,76 +9243,124 @@ test io-75.10 {incomplete multibyte encoding read is ignored} -setup { } -result 41c0 -test io-75.10_strict {incomplete multibyte encoding read is an error} -setup { - set res {} - set fn [makeFile {} io-75.10] - set f [open $fn w+] - fconfigure $f -encoding binary - puts -nonewline $f A\xC0 - flush $f - seek $f 0 - fconfigure $f -encoding utf-8 -strictencoding 1 -buffering none -} -body { - set status [catch {read $f} cres copts] - set d [dict get $copts -result read] - binary scan $d H* hd - lappend res $hd $cres - chan configure $f -encoding iso8859-1 - set d [read $f] - binary scan $d H* hd - lappend res $hd - close $f - return $res -} -cleanup { - removeFile io-75.10 -} -match glob -result {41 {error reading "*": illegal byte sequence} c0} +apply [list {} { + set test { + test io-75.10_strict {incomplete multibyte encoding read is an error} -setup { + set res {} + set fn [makeFile {} io-75.10] + set f [open $fn w+] + fconfigure $f -encoding binary + puts -nonewline $f A\xC0 + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -strictencoding 1 -buffering none + } -body { + set status [catch {read $f} cres copts] + + #set d [dict get $copts -result read] + #binary scan $d H* hd + #lappend res $hd $cres + lappend res $cres + + chan configure $f -encoding iso8859-1 + + set d [read $f] + binary scan $d H* hd + lappend res $hd + close $f + return $res + } -cleanup { + removeFile io-75.10 + } -match glob\ + } + + #append test {\ + # -result {41 {error reading "*": illegal byte sequence} c0} + #} + + append test {\ + -result {{error reading "*": illegal byte sequence} c0} + } + + uplevel 1 $test + + + + set test { + # As utf-8 has a special treatment in multi-byte decoding, also test another + # one. + test io-75.11 {shiftjis encoding error read results in raw bytes} -setup { + set hd {} + set fn [makeFile {} io-75.11] + set f [open $fn w+] + fconfigure $f -encoding binary + # In shiftjis, \x81 starts a two-byte sequence. + # But 2nd byte \xFF is not allowed + puts -nonewline $f A\x81\xFFA + flush $f + seek $f 0 + fconfigure $f -encoding shiftjis -buffering none -eofchar "" \ + -translation lf -strictencoding 1 + } -body { + set status [catch {read $f} cres copts] + #set d [dict get $copts -result read] + #binary scan $d H* hd + lappend hd $status + lappend hd $cres + } -cleanup { + close $f + removeFile io-75.11 + } -match glob + } -# As utf-8 has a special treatment in multi-byte decoding, also test another -# one. -test io-75.11 {shiftjis encoding error read results in raw bytes} -setup { - set fn [makeFile {} io-75.11] - set f [open $fn w+] - fconfigure $f -encoding binary - # In shiftjis, \x81 starts a two-byte sequence. - # But 2nd byte \xFF is not allowed - puts -nonewline $f A\x81\xFFA - flush $f - seek $f 0 - fconfigure $f -encoding shiftjis -buffering none -eofchar "" \ - -translation lf -strictencoding 1 -} -body { - set status [catch {read $f} cres copts] - set d [dict get $copts -result read] - binary scan $d H* hd - lappend hd $status - lappend hd $cres -} -cleanup { - close $f - removeFile io-75.11 -} -match glob -result {41 1 {error reading "*": illegal byte sequence}} + #append test {\ + # -result {41 1 {error reading "*": illegal byte sequence}} + #} + append test {\ + -result {1 {error reading "*": illegal byte sequence}} + } -test io-75.12 {invalid utf-8 encoding read is an error} -setup { - set res {} - set fn [makeFile {} io-75.12] - set f [open $fn w+] - fconfigure $f -encoding binary - puts -nonewline $f A\x81 - flush $f - seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf \ + + set test { + test io-75.12 {invalid utf-8 encoding read is an error} -setup { + set hd {} + set res {} + set fn [makeFile {} io-75.12] + set f [open $fn w+] + fconfigure $f -encoding binary + puts -nonewline $f A\x81 + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf \ -strictencoding 1 -} -body { - set status [catch {read $f} cres copts] - set d [dict get $copts -result read] - close $f - binary scan $d H* hd - lappend res $hd $status $cres - return $res -} -cleanup { - removeFile io-75.12 -} -match glob -result {41 1 {error reading "*": illegal byte sequence}} + } -body { + set status [catch {read $f} cres copts] + #set d [dict get $copts -result read] + #binary scan $d H* hd + #lappend res $hd + lappend res $status $cres + return $res + } -cleanup { + catch {close $f} + removeFile io-75.12 + } -match glob\ + } + + #append test {\ + # -result {41 1 {error reading "*": illegal byte sequence}} + #} + + + append test {\ + -result {1 {error reading "*": illegal byte sequence}} + } + + uplevel 1 $test +} [namespace current]] + + test io-75.12_ignore {invalid utf-8 encoding read is ignored} -setup { set fn [makeFile {} io-75.12] set f [open $fn w+] @@ -9285,25 +9378,49 @@ test io-75.12_ignore {invalid utf-8 encoding read is ignored} -setup { } -cleanup { removeFile io-75.12 } -result 4181 -test io-75.13 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} -setup { - set fn [makeFile {} io-75.13] - set f [open $fn w+] - fconfigure $f -encoding binary - # \x81 is invalid in utf-8 - puts -nonewline $f "A\x81" - flush $f - seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -strictencoding 1 -} -body { - set status [catch {read $f} cres copts] - set d [dict get $copts -result read] - binary scan $d H* hd - lappend hd $status - close $f - lappend hd $cres -} -cleanup { - removeFile io-75.13 -} -match glob -result {41 1 {error reading "*": illegal byte sequence}} + + +apply [list {} { + + set test { + test io-75.13 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} -setup { + set hd {} + set fn [makeFile {} io-75.13] + set f [open $fn w+] + fconfigure $f -encoding binary + # \x81 is invalid in utf-8 + puts -nonewline $f A\x81 + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none -eofchar "" \ + -translation lf -strictencoding 1 + } -body { + set status [catch {read $f} cres copts] + #set d [dict get $copts -result read] + #binary scan $d H* hd + lappend hd $status + lappend hd $cres + } -cleanup { + catch {close $f} + removeFile io-75.13 + } -match glob\ + } + + #append test {\ + # -result {41 1 {error reading "*": illegal byte sequence}} + #} + + append test {\ + -result {1 {error reading "*": illegal byte sequence}} + } + + uplevel 1 $test + + set test { + } + +} [namespace current]] + test io-75.14 {invalid utf-8 encoding [gets] coninues in non-strict mode after error} -setup { set res {} @@ -9329,34 +9446,51 @@ test io-75.14 {invalid utf-8 encoding [gets] coninues in non-strict mode after e } -match glob -result {a 1 {error reading "*": illegal byte sequence} bÀ c} -test io-75.15 {invalid utf-8 encoding strict gets should not hang} -setup { - set res {} - set fn [makeFile {} io-75.15] - set chan [open $fn w+] - fconfigure $chan -encoding binary - # This is not valid UTF-8 - puts $chan hello\nAB\xc0\x40CD\nEFG - close $chan -} -body { - #Now try to read it with [gets] - set chan [open $fn] - fconfigure $chan -encoding utf-8 -strictencoding 1 - lappend res [gets $chan] - set status [catch {gets $chan} cres copts] - lappend res $status $cres - set status [catch {gets $chan} cres copts] - lappend res $status $cres - lappend res [dict get $copts -result] - chan configur $chan -encoding binary - foreach char [split [read $chan 2] {}] { - lappend res [format %x [scan $char %c]] + +apply [list {} { + set test { + test io-75.15 {invalid utf-8 encoding strict gets should not hang} -setup { + set res {} + set fn [makeFile {} io-75.15] + set chan [open $fn w+] + fconfigure $chan -encoding binary + # This is not valid UTF-8 + puts $chan hello\nAB\xc0\x40CD\nEFG + close $chan + } -body { + #Now try to read it with [gets] + set chan [open $fn] + fconfigure $chan -encoding utf-8 -strictencoding 1 + lappend res [gets $chan] + set status [catch {gets $chan} cres copts] + lappend res $status $cres + set status [catch {gets $chan} cres copts] + lappend res $status $cres + #lappend res [dict get $copts -result] + chan configur $chan -encoding binary + foreach char [split [read $chan 2] {}] { + lappend res [format %x [scan $char %c]] + } + return $res + } -cleanup { + close $chan + removeFile io-75.15 + } -match glob\ } - return $res -} -cleanup { - close $chan - removeFile io-75.15 -} -match glob -result {hello 1 {error reading "*": illegal byte sequence}\ - 1 {error reading "*": illegal byte sequence} {read AB} c0 40} + + #append test {\ + # -result {hello 1 {error reading "*": illegal byte sequence}\ + # 1 {error reading "*": illegal byte sequence} {read AB} c0 40} + #} + + append test {\ + -result {hello 1 {error reading "*": illegal byte sequence}\ + 1 {error reading "*": illegal byte sequence} c0 40} + } + + uplevel 1 $test + +} [namespace current]] test io-76.0 {channel modes} -setup { -- cgit v0.12 From f238eb1dbc93130d15f8b4e7dd32602c1870794a Mon Sep 17 00:00:00 2001 From: pooryorick Date: Sat, 4 Feb 2023 00:28:12 +0000 Subject: Fix test io-75.14. --- tests/io.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/io.test b/tests/io.test index 0f62a4f..75255ca 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9428,7 +9428,7 @@ test io-75.14 { set res {} set fn [makeFile {} io-75.14] set f [open $fn w+] - fconfigure $f -encoding binary + fconfigure $f -translation binary # \xc0 is invalid in utf-8 puts -nonewline $f a\nb\xc0\nc\n flush $f -- cgit v0.12 From f5f5ff4257a24b2e8a8d96c820f6874c86e81304 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 6 Feb 2023 22:43:30 +0000 Subject: Proposed fix for [10c2c17c32]: UTF-LE32 encoder mapping of surrogates. TODO: testcase --- generic/tclEncoding.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 288b07c..d19e237 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2582,6 +2582,10 @@ Utf32ToUtfProc( *dst++ = (ch & 0xFF); } else { dst += Tcl_UniCharToUtf(ch, dst); + if ((ch & ~0x3FF) == 0xD800) { + /* Bug [10c2c17c32]. If Hi surrogate, finish 3-byte UTF-8 */ + dst += Tcl_UniCharToUtf(-1, dst); + } } src += sizeof(unsigned int); } -- cgit v0.12 From 694ae1913191cf93072702e7612b88544f7bea54 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 7 Feb 2023 11:22:08 +0000 Subject: Fix call to EncodingConvertParseOption for decoding --- generic/tclCmdAH.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 9165fda..02a3a46 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -688,7 +688,7 @@ EncodingConvertfromObjCmd( Tcl_Obj *failVarObj; if (EncodingConvertParseOptions( - interp, objc, objv, 1, &encoding, &data, &flags, &failVarObj) + interp, objc, objv, 0, &encoding, &data, &flags, &failVarObj) != TCL_OK) { return TCL_ERROR; } -- cgit v0.12 From e0ee29b9b606d2a3872ddf7f04332ba62433ae32 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 7 Feb 2023 11:23:52 +0000 Subject: Refactor encoding tests for broader coverage and easier test case management --- tests/cmdAH.test | 538 +++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 343 insertions(+), 195 deletions(-) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index d7a3657..22dc2a4 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -171,239 +171,387 @@ test cmdAH-3.2 {Tcl_ContinueObjCmd, success} { list [catch {continue} msg] $msg } {4 {}} -test cmdAH-4.1 {Tcl_EncodingObjCmd} -returnCodes error -body { +### +# encoding command + +set "numargErrors(encoding system)" {^wrong # args: should be "(encoding |::tcl::encoding::)system \?encoding\?"$} +set "numargErrors(encoding convertfrom)" {^wrong # args: should be "(encoding |::tcl::encoding::)convertfrom \?\?-profile profile\? \?-failindex var\? \?encoding\?\? data"$} +set "numargErrors(encoding convertto)" {^wrong # args: should be "(encoding |::tcl::encoding::)convertto \?\?-profile profile\? \?-failindex var\? \?encoding\?\? data"$} +set "numargErrors(encoding names)" {wrong # args: should be "encoding names"} + +set encProfiles {tcl8 strict} + +# TODO - valid sequences for different encodings - shiftjis etc. +# Note utf-16, utf-32 missing because they are automatically +# generated based on le/be versions. +set encValidStrings { + ascii ABC \x41\x42\x43 + utf-8 A\u0000\u03A9\u8A9E\U00010384 \x41\x00\xCE\xA9\xE8\xAA\x9E\xF0\x90\x8E\x84 + utf-16le A\u0000\u03A9\u8A9E\U00010384 \x41\x00\x00\x00\xA9\x03\x9E\x8A\x00\xD8\x84\xDF + utf-16be A\u0000\u03A9\u8A9E\U00010384 \x00\x41\x00\x00\x03\xA9\x8A\x9E\xD8\x00\xDF\x84 + utf-32le A\u0000\u03A9\u8A9E\U00010384 \x41\x00\x00\x00\x00\x00\x00\x00\xA9\x03\x00\x00\x9E\x8A\x00\x00\x84\x03\x01\x00 + utf-32be A\u0000\u03A9\u8A9E\U00010384 \x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x03\xA9\x00\x00\x8A\x9E\x00\x01\x03\x84 +} + +# Invalid byte sequences {encoding bytes profile prefix failindex tag} +# Note tag is used in test id generation as well. The combination +# should be unique for test ids to be unique. +# Note utf-16, utf-32 missing because they are automatically +# generated based on le/be versions. +# TODO - other encodings and test cases +set encInvalidBytes { + ascii \x41\xe9\x42 default A\u00E9B -1 {non-ASCII} + ascii \x41\xe9\x42 tcl8 A\u00E9B -1 {non-ASCII} + ascii \x41\xe9\x42 strict A 1 {non-ASCII} + + utf-8 \x41\xC0\x42 default A\u00C0B -1 C0 + utf-8 \x41\xC0\x42 tcl8 A\u00C0B -1 C0 + utf-8 \x41\xC0\x42 strict A 1 C0 + utf-8 \x41\x80\x42 default A\u0080B -1 80 + utf-8 \x41\x80\x42 tcl8 A\u0080B -1 80 + utf-8 \x41\x80\x42 strict A 1 80 + utf-8 \x41\xC0\x80\x42 default A\u0000B -1 C080 + utf-8 \x41\xC0\x80\x42 tcl8 A\u0000B -1 C080 + utf-8 \x41\xC0\x80\x42 strict A 1 C080 + utf-8 \x41\xC1\x42 default A\u00C1B -1 C1 + utf-8 \x41\xC1\x42 tcl8 A\u00C1B -1 C1 + utf-8 \x41\xC1\x42 strict A 1 C1 + utf-8 \x41\xC2\x42 default A\u00C2B -1 C2-nontrail + utf-8 \x41\xC2\x42 tcl8 A\u00C2B -1 C2-nontrail + utf-8 \x41\xC2\x42 strict A 1 C2-nontrail + utf-8 \x41\xC2 default A\u00C2 -1 C2-incomplete + utf-8 \x41\xC2 tcl8 A\u00C2 -1 C2-incomplete + utf-8 \x41\xC2 strict A 1 C2-incomplete + utf-8 A\xed\xa0\x80B default A\uD800B -1 High-surrogate + utf-8 A\xed\xa0\x80B tcl8 A\uD800B -1 High-surrogate + utf-8 A\xed\xa0\x80B strict A 1 High-surrogate + utf-8 A\xed\xb0\x80B default A\uDC00B -1 Low-surrogate + utf-8 A\xed\xb0\x80B tcl8 A\uDC00B -1 Low-surrogate + utf-8 A\xed\xb0\x80B strict A 1 Low-surrogate + + utf-32le \x41\x00\x00\x00\x00\xD8\x00\x00\x42\x00\x00\x00 default A\uD800B -1 {High-surrogate} + utf-32le \x41\x00\x00\x00\x00\xD8\x00\x00\x42\x00\x00\x00 tcl8 A\uD800B -1 {High-surrogate} + utf-32le \x41\x00\x00\x00\x00\xD8\x00\x00\x42\x00\x00\x00 strict A 4 {High-surrogate} +} + +# Strings that cannot be encoded for specific encoding / profiles +# {encoding string profile bytes failindex tag} +# Note tag is used in test id generation as well. The combination +# should be unique for test ids to be unique. +# Note utf-16, utf-32 missing because they are automatically +# generated based on le/be versions. +# TODO - other encodings and test cases +# TODO - out of range code point (note cannot be generated by \U notation) +set encUnencodableStrings { + ascii A\u00e0B default \x41\x3f\x42 -1 non-ASCII + ascii A\u00e0B tcl8 \x41\x3f\x42 -1 non-ASCII + ascii A\u00e0B strict \x41 1 non-ASCII + + iso8859-1 A\u0141B default \x41\x3f\x42 -1 unencodable + iso8859-1 A\u0141B tcl8 \x41\x3f\x42 -1 unencodable + iso8859-1 A\u0141B strict \x41 1 unencodable + + utf-8 A\uD800B default \x41\xed\xa0\x80\x42 -1 High-surrogate + utf-8 A\uD800B tcl8 \x41\xed\xa0\x80\x42 -1 High-surrogate + utf-8 A\uD800B strict \x41 1 High-surrogate + utf-8 A\uDC00B default \x41\xed\xb0\x80\x42 -1 High-surrogate + utf-8 A\uDC00B tcl8 \x41\xed\xb0\x80\x42 -1 High-surrogate + utf-8 A\uDC00B strict \x41 1 High-surrogate +} + +if {$::tcl_platform(byteOrder) eq "littleEndian"} { + set endian le +} else { + set endian be +} + +# +# Check errors for invalid number of arguments +proc badnumargs {id cmd cmdargs} { + variable numargErrors + test $id.a "Syntax error: $cmd $cmdargs" \ + -body [list {*}$cmd {*}$cmdargs] \ + -result $numargErrors($cmd) \ + -match regexp \ + -returnCodes error + test $id.b "Syntax error: $cmd (byte compiled)" \ + -setup [list proc compiled_proc {} [list {*}$cmd {*}$cmdargs]] \ + -body {compiled_proc} \ + -cleanup {rename compiled_proc {}} \ + -result $numargErrors($cmd) \ + -match regexp \ + -returnCodes error +} + +# Wraps tests resulting in unknown encoding errors +proc unknownencodingtest {id cmd} { + set result "unknown encoding \"[lindex $cmd end-1]\"" + test $id.a "Unknown encoding error: $cmd" \ + -body [list encoding {*}$cmd] \ + -result $result \ + -returnCodes error + test $id.b "Syntax error: $cmd (byte compiled)" \ + -setup [list proc encoding_test {} [list encoding {*}$cmd]] \ + -body {encoding_test} \ + -cleanup {rename encoding_test {}} \ + -result $result \ + -returnCodes error +} + +# Wraps tests for conversion, successful or not. +# Really more general than just for encoding conversion. +proc testconvert {id body result args} { + test $id.a $body \ + -body $body \ + -result $result \ + {*}$args + dict append args -setup \n[list proc compiled_script {} $body] + dict append args -cleanup "\nrename compiled_script {}" + test $id.b "$body (byte compiled)" \ + -body {compiled_script} \ + -result $result \ + {*}$args +} + +test cmdAH-4.1.1 {encoding} -returnCodes error -body { encoding } -result {wrong # args: should be "encoding subcommand ?arg ...?"} -test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { +test cmdAH-4.1.2 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding foo } -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} -test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { - encoding convertto -} -result {wrong # args: should be "encoding convertto ?-strict? ?-failindex var? ?encoding? data" or "encoding convertto -nocomplain ?encoding? data"} -test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body { - encoding convertto foo bar -} -result {unknown encoding "foo"} -test cmdAH-4.5 {Tcl_EncodingObjCmd} -setup { - set system [encoding system] -} -body { - encoding system jis0208 - encoding convertto 乎 -} -cleanup { - encoding system $system -} -result 8C -test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { + +# +# encoding system 4.2.* +badnumargs cmdAH-4.2.1 {encoding system} {ascii ascii} +test cmdAH-4.2.2 {Tcl_EncodingObjCmd} -setup { set system [encoding system] } -body { encoding system iso8859-1 - encoding convertto jis0208 乎 -} -cleanup { - encoding system $system -} -result 8C -test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body { - encoding convertfrom -} -result {wrong # args: should be "encoding convertfrom ?-strict? ?-failindex var? ?encoding? data" or "encoding convertfrom -nocomplain ?encoding? data"} -test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body { - encoding convertfrom foo bar -} -result {unknown encoding "foo"} -test cmdAH-4.9 {Tcl_EncodingObjCmd} -setup { - set system [encoding system] -} -body { - encoding system jis0208 - encoding convertfrom 8C + encoding system } -cleanup { encoding system $system -} -result 乎 -test cmdAH-4.10 {Tcl_EncodingObjCmd} -setup { +} -result iso8859-1 + +# +# encoding convertfrom 4.3.* + +# Odd number of args is always invalid since last two args +# are ENCODING DATA and all options take a value +badnumargs cmdAH-4.3.1 {encoding convertfrom} {} +badnumargs cmdAH-4.3.2 {encoding convertfrom} {-failindex VAR ABC} +badnumargs cmdAH-4.3.3 {encoding convertfrom} {-profile VAR ABC} +badnumargs cmdAH-4.3.4 {encoding convertfrom} {-failindex VAR -profile strict ABC} +badnumargs cmdAH-4.3.5 {encoding convertfrom} {-profile strict -failindex VAR ABC} + +# Test that last two args always treated as ENCODING DATA +unknownencodingtest 4.3.6 {convertfrom -failindex ABC} +unknownencodingtest 4.3.7 {convertfrom -profile ABC} +unknownencodingtest 4.3.8 {convertfrom nosuchencoding ABC} +unknownencodingtest 4.3.9 {convertfrom -failindex VAR -profile ABC} +unknownencodingtest 4.3.10 {convertfrom -profile strict -failindex ABC} +testconvert cmdAH-4.3.11 { + encoding convertfrom jis0208 \x38\x43 +} \u4e4e -setup { set system [encoding system] -} -body { encoding system iso8859-1 - encoding convertfrom jis0208 8C } -cleanup { encoding system $system -} -result 乎 -test cmdAH-4.11 {Tcl_EncodingObjCmd} -returnCodes error -body { - encoding names foo -} -result {wrong # args: should be "encoding names"} -test cmdAH-4.12 {Tcl_EncodingObjCmd} -returnCodes error -body { - encoding system foo bar -} -result {wrong # args: should be "encoding system ?encoding?"} -test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup { +} + +# Verify single arg defaults to system encoding +testconvert cmdAH-4.3.12 { + encoding convertfrom \x38\x43 +} \u4e4e -setup { set system [encoding system] -} -body { - encoding system iso8859-1 - encoding system + encoding system jis0208 } -cleanup { encoding system $system -} -result iso8859-1 +} -test cmdAH-4.14.1 {Syntax error, -nocomplain and -failindex, no encoding} -body { - encoding convertfrom -nocomplain -failindex 2 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-strict? ?-failindex var? ?encoding? data" or "encoding convertfrom -nocomplain ?encoding? data"} -test cmdAH-4.14.2 {Syntax error, -nocomplain and -failindex, no encoding} -body { - encoding convertto -nocomplain -failindex 2 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-strict? ?-failindex var? ?encoding? data" or "encoding convertto -nocomplain ?encoding? data"} -test cmdAH-4.15.1 {Syntax error, -failindex and -nocomplain, no encoding} -body { - encoding convertfrom -failindex 2 -nocomplain ABC -} -returnCodes 1 -result {unknown encoding "-nocomplain"} -test cmdAH-4.15.2 {Syntax error, -failindex and -nocomplain, no encoding} -body { - encoding convertto -failindex 2 -nocomplain ABC -} -returnCodes 1 -result {unknown encoding "-nocomplain"} -test cmdAH-4.16.1 {Syntax error, -nocomplain and -failindex, encoding} -body { - encoding convertfrom -nocomplain -failindex 2 utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-strict? ?-failindex var? ?encoding? data" or "encoding convertfrom -nocomplain ?encoding? data"} -test cmdAH-4.16.2 {Syntax error, -nocomplain and -failindex, encoding} -body { - encoding convertto -nocomplain -failindex 2 utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-strict? ?-failindex var? ?encoding? data" or "encoding convertto -nocomplain ?encoding? data"} -test cmdAH-4.17.1 {Syntax error, -failindex and -nocomplain, encoding} -body { - encoding convertfrom -failindex 2 -nocomplain utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertfrom ?-strict? ?-failindex var? ?encoding? data" or "encoding convertfrom -nocomplain ?encoding? data"} -test cmdAH-4.17.2 {Syntax error, -failindex and -nocomplain, encoding} -body { - encoding convertto -failindex 2 -nocomplain utf-8 ABC -} -returnCodes 1 -result {wrong # args: should be "encoding convertto ?-strict? ?-failindex var? ?encoding? data" or "encoding convertto -nocomplain ?encoding? data"} -test cmdAH-4.18.1 {Syntax error, -failindex with no var, no encoding} -body { - encoding convertfrom -failindex ABC -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-strict? ?-failindex var? ?encoding? data" or "::tcl::encoding::convertfrom -nocomplain ?encoding? data"} -test cmdAH-4.18.2 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { - proc encoding_test {} { - encoding convertfrom -failindex ABC +# Wrapper for verifying -failindex +proc testfailindex {id converter enc data result {profile default}} { + if {$profile eq "default"} { + testconvert $id "list \[encoding $converter -failindex idx $enc $data] \[set idx]" $result + } else { + testconvert $id "list \[encoding $converter -profile $profile -failindex idx $enc $data] \[set idx]" $result } -} -body { - # Compile and execute - encoding_test -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertfrom ?-strict? ?-failindex var? ?encoding? data" or "::tcl::encoding::convertfrom -nocomplain ?encoding? data"} -cleanup { - rename encoding_test "" } -test cmdAH-4.18.3 {Syntax error, -failindex with no var, no encoding} -body { - encoding convertto -failindex ABC -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-strict? ?-failindex var? ?encoding? data" or "::tcl::encoding::convertto -nocomplain ?encoding? data"} -test cmdAH-4.18.4 {Syntax error, -failindex with no var, no encoding (byte compiled)} -setup { - proc encoding_test {} { - encoding convertto -failindex ABC + +# -failindex - valid data +foreach {enc string bytes} $encValidStrings { + testfailindex 4.3.13.$enc convertfrom $enc $bytes [list $string -1] + if {"utf-16$endian" eq $enc} { + # utf-16le ->utf-16, utf-32be -> utf32 etc. + set enc [string range $enc 0 5] + testfailindex 4.3.13.$enc convertfrom $enc $bytes [list $string -1] } -} -body { - # Compile and execute - encoding_test -} -returnCodes 1 -result {wrong # args: should be "::tcl::encoding::convertto ?-strict? ?-failindex var? ?encoding? data" or "::tcl::encoding::convertto -nocomplain ?encoding? data"} -cleanup { - rename encoding_test "" } -test cmdAH-4.19.1 {convertrom -failindex with correct data} -body { - encoding convertfrom -failindex test ABC - set test -} -returnCodes 0 -result -1 -test cmdAH-4.19.2 {convertrom -failindex with correct data (byt compiled)} -setup { - proc encoding_test {} { - encoding convertfrom -failindex test ABC - set test + +# -failindex - invalid data +foreach {enc bytes profile prefix failidx tag} $encInvalidBytes { + testfailindex 4.3.14.$enc.$profile.$tag convertfrom $enc $bytes [list $prefix $failidx] $profile + if {"utf-16$endian" eq $enc} { + # utf-16le ->utf-16, utf-32be -> utf32 etc. + set enc [string range $enc 0 5] + testfailindex 4.3.14.$enc.$profile.$tag convertfrom $enc $bytes [list $prefix $failidx] $profile } -} -body { - # Compile and execute - encoding_test -} -returnCodes 0 -result -1 -cleanup { - rename encoding_test "" } -test cmdAH-4.19.3 {convertrom -failindex with correct data} -body { - encoding convertto -failindex test ABC - set test -} -returnCodes 0 -result -1 -test cmdAH-4.19.4 {convertrom -failindex with correct data (byt compiled)} -setup { - proc encoding_test {} { - encoding convertto -failindex test ABC - set test + +# -profile + +# All valid byte sequences should be accepted by all profiles +foreach profile $encProfiles { + set i 0 + foreach {enc string bytes} $encValidStrings { + testconvert 4.3.15.$enc.$profile.[incr i] [list encoding convertfrom $enc $bytes] $string + if {"utf-16$endian" eq $enc} { + # utf-16le ->utf-16, utf-32be -> utf32 etc. + set enc [string range $enc 0 5] + testconvert 4.3.15.$enc.$profile.[incr i] [list encoding convertfrom $enc $bytes] $string + } } -} -body { - # Compile and execute - encoding_test -} -returnCodes 0 -result -1 -cleanup { - rename encoding_test "" } -test cmdAH-4.20.1 {convertrom -failindex with incomplete utf8} -body { - set x [encoding convertfrom -failindex i utf-8 A\xc3] - binary scan $x H* y - list $y $i -} -returnCodes 0 -result {41 1} -test cmdAH-4.20.2 {convertrom -failindex with incomplete utf8 (byte compiled)} -setup { - proc encoding_test {} { - set x [encoding convertfrom -failindex i utf-8 A\xc3] - binary scan $x H* y - list $y $i + +# Cycle through the various combinations of encodings and profiles +# for invalid byte sequences +foreach {enc bytes profile prefix failidx tag} $encInvalidBytes { + if {$failidx eq -1} { + set result [list $prefix] + } else { + set badbyte "'\\x[string toupper [binary encode hex [string index $bytes $failidx]]]'" + # TODO - if the bad byte is unprintable, tcltest errors out when printing a mismatch + # so glob it out for now. + set result [list "unexpected byte sequence starting at index $failidx: *" -returnCodes error -match glob] } -} -body { - # Compile and execute - encoding_test -} -returnCodes 0 -result {41 1} -cleanup { - rename encoding_test "" -} -test cmdAH-4.20.3 {convertrom -failindex with incomplete utf8} -body { - set x [encoding convertfrom -strict -failindex i utf-8 A\xc3] - binary scan $x H* y - list $y $i -} -returnCodes 0 -result {41 1} -test cmdAH-4.20.4 {convertrom -failindex with incomplete utf8 (byte compiled)} -setup { - proc encoding_test {} { - set x [encoding convertfrom -strict -failindex i utf-8 A\xc3] - binary scan $x H* y - list $y $i + if {$profile eq "default"} { + testconvert 4.3.15.$enc.$profile.$tag [list encoding convertfrom $enc $bytes] {*}$result + if {"utf-16$endian" eq $enc} { + # utf-16le ->utf-16, utf-32be -> utf32 etc. + set enc [string range $enc 0 5] + testconvert 4.3.15.$enc.$profile.$tag [list encoding convertfrom $enc $bytes] {*}$result + } + } else { + testconvert 4.3.15.$enc.$profile.$tag [list encoding convertfrom -profile $profile $enc $bytes] {*}$result + if {"utf-16$endian" eq $enc} { + # utf-16le ->utf-16, utf-32be -> utf32 etc. + set enc [string range $enc 0 5] + testconvert 4.3.15.$enc.$profile.$tag [list encoding convertfrom -profile $profile $enc $bytes] {*}$result + } } -} -body { - # Compile and execute - encoding_test -} -returnCodes 0 -result {41 1} -cleanup { - rename encoding_test "" } -test cmdAH-4.20.5 {convertrom -failindex with incomplete utf8} -body { - set x [encoding convertfrom -failindex i -strict utf-8 A\xc3] - binary scan $x H* y - list $y $i -} -returnCodes 0 -result {41 1} -test cmdAH-4.20.6 {convertrom -failindex with incomplete utf8 (byte compiled)} -setup { - proc encoding_test {} { - set x [encoding convertfrom -failindex i -strict utf-8 A\xc3] - binary scan $x H* y - list $y $i + +# +# encoding convertto 4.4.* + +badnumargs cmdAH-4.4.1 {encoding convertto} {} +badnumargs cmdAH-4.4.2 {encoding convertto} {-failindex VAR ABC} +badnumargs cmdAH-4.4.3 {encoding convertto} {-profile VAR ABC} +badnumargs cmdAH-4.4.4 {encoding convertto} {-failindex VAR -profile strict ABC} +badnumargs cmdAH-4.4.5 {encoding convertto} {-profile strict -failindex VAR ABC} + +# Test that last two args always treated as ENCODING DATA +unknownencodingtest 4.4.6 {convertto -failindex ABC} +unknownencodingtest 4.4.7 {convertto -profile ABC} +unknownencodingtest 4.4.8 {convertto nosuchencoding ABC} +unknownencodingtest 4.4.9 {convertto -failindex VAR -profile ABC} +unknownencodingtest 4.4.10 {convertto -profile strict -failindex ABC} +testconvert cmdAH-4.4.11 { + encoding convertto jis0208 \u4e4e +} \x38\x43 -setup { + set system [encoding system] + encoding system iso8859-1 +} -cleanup { + encoding system $system +} + +# Verify single arg defaults to system encoding +testconvert cmdAH-4.4.12 { + encoding convertto \u4e4e +} \x38\x43 -setup { + set system [encoding system] + encoding system jis0208 +} -cleanup { + encoding system $system +} + +# -failindex - valid data +foreach {enc string bytes} $encValidStrings { + testfailindex 4.4.13.$enc convertto $enc $string [list $bytes -1] + if {"utf-16$endian" eq $enc} { + # utf-16le ->utf-16, utf-32be -> utf32 etc. + set enc [string range $enc 0 5] + testfailindex 4.4.13.$enc convertto $enc $string [list $bytes -1] } -} -body { - # Compile and execute - encoding_test -} -returnCodes 0 -result {41 1} -cleanup { - rename encoding_test "" } -test cmdAH-4.21.1 {convertto -failindex with wrong character} -body { - set x [encoding convertto -failindex i iso8859-1 A\u0141] - binary scan $x H* y - list $y $i -} -returnCodes 0 -result {41 1} -test cmdAH-4.21.2 {convertto -failindex with wrong character (byte compiled)} -setup { - proc encoding_test {} { - set x [encoding convertto -failindex i iso8859-1 A\u0141] - binary scan $x H* y - list $y $i + +# -failindex - invalid data +foreach {enc string profile bytes failidx tag} $encUnencodableStrings { + testfailindex 4.4.14.$enc.$profile.$tag convertto $enc $string [list $bytes $failidx] $profile + if {"utf-16$endian" eq $enc} { + # utf-16le ->utf-16, utf-32be -> utf32 etc. + set enc [string range $enc 0 5] + testfailindex 4.4.14.$enc.$profile.$tag convertto $enc $string [list $bytes $failidx] $profile } -} -body { - # Compile and execute - encoding_test -} -returnCodes 0 -result {41 1} -cleanup { - rename encoding_test "" } -test cmdAH-4.22 {convertfrom -strict} -body { - encoding convertfrom -strict utf-8 A\x00B -} -result A\x00B -test cmdAH-4.23 {convertfrom -strict} -body { - encoding convertfrom -strict utf-8 A\xC0\x80B -} -returnCodes error -result {unexpected byte sequence starting at index 1: '\xC0'} +# -profile -test cmdAH-4.24 {convertto -strict} -body { - encoding convertto -strict utf-8 A\x00B -} -result A\x00B +# All valid byte sequences should be accepted by all profiles +foreach profile $encProfiles { + set i 0 + foreach {enc string bytes} $encValidStrings { + testconvert 4.4.15.$enc.$profile.[incr i] [list encoding convertto $enc $string] $bytes + if {"utf-16$endian" eq $enc} { + # utf-16le ->utf-16, utf-32be -> utf32 etc. + set enc [string range $enc 0 5] + testconvert 4.4.15.$enc.$profile.[incr i] [list encoding convertto $enc $string] $bytes + } + } +} -test cmdAH-4.25 {convertfrom -strict} -constraints knownBug -body { - encoding convertfrom -strict utf-8 A\x80B -} -returnCodes error -result {unexpected byte sequence starting at index 1: '\x80'} +# Cycle through the various combinations of encodings and profiles +# for invalid byte sequences +foreach {enc string profile bytes failidx tag} $encUnencodableStrings { + if {$failidx eq -1} { + set result [list $bytes] + } else { + # TODO - if the bad char is unprintable, tcltest errors out when printing a mismatch + # so glob it out for now. + set result [list "unexpected character at index $failidx: *" -returnCodes error -match glob] + } + if {$profile eq "default"} { + testconvert 4.4.15.$enc.$profile.$tag [list encoding convertto $enc $string] {*}$result + if {"utf-16$endian" eq $enc} { + # utf-16le ->utf-16, utf-32be -> utf32 etc. + set enc [string range $enc 0 5] + testconvert 4.3.15.$enc.$profile.$tag [list encoding convertto $enc $string] {*}$result + } + } else { + testconvert 4.4.15.$enc.$profile.$tag [list encoding convertto -profile $profile $enc $string] {*}$result + if {"utf-16$endian" eq $enc} { + # utf-16le ->utf-16, utf-32be -> utf32 etc. + set enc [string range $enc 0 5] + testconvert 4.4.15.$enc.$profile.$tag [list encoding convertto -profile $profile $enc $string] {*}$result + } + } +} -test cmdAH-4.26 {convertto -strict} -constraints {testbytestring knownBug} -body { - encoding convertto -strict utf-8 A[testbytestring \x80]B +test cmdAH-4.5.1 {convertto -profile strict} -constraints {testbytestring knownBug} -body { + # TODO - what does testbytestring even test? Invalid UTF8 in the Tcl_Obj bytes field + encoding convertto -profile strict utf-8 A[testbytestring \x80]B } -returnCodes error -result {unexpected byte sequence starting at index 1: '\x80'} +# +# encoding names 4.5.* +badnumargs cmdAH-4.5.1 {encoding names} {foo} +test cmdAH-4.5.2 {encoding names should include at least utf-8 and iso8859-1 and at least one more} -body { + set names [encoding names] + list [expr {"utf-8" in $names}] [expr {"iso8859-1" in $names}] [expr {[llength $names] > 2}] +} -result {1 1 1} + +# +# file command + test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { file } -result {wrong # args: should be "file subcommand ?arg ...?"} -- cgit v0.12 From b741dab392a7e58c23568bd821d7eff982c2ec14 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 7 Feb 2023 11:25:22 +0000 Subject: Fix tcltest to not exit on encoding errors when printing to stdout --- library/tcltest/tcltest.tcl | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 7344f9f..94010a7 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -2221,7 +2221,11 @@ proc tcltest::test {name description args} { if {$scriptCompare} { puts [outputChannel] "---- Error testing result: $scriptMatch" } else { - puts [outputChannel] "---- Result was:\n$actualAnswer" + try { + puts [outputChannel] "---- Result was:\n$actualAnswer" + } on error {errMsg errCode} { + puts [outputChannel] "---- Result was:\n" + } puts [outputChannel] "---- Result should have been\ ($match matching):\n$result" } -- cgit v0.12 From 4294befd8b12d341c6fa74ef24120838d931a07a Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 9 Feb 2023 07:27:43 +0000 Subject: Do not have -failindex imply -strict --- generic/tclCmdAH.c | 14 ++------------ 1 file changed, 2 insertions(+), 12 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 02a3a46..efc156c 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -554,7 +554,6 @@ EncodingConvertParseOptions ( Tcl_Interp *interp, /* For error messages. May be NULL */ int objc, /* Number of arguments */ Tcl_Obj *const objv[], /* Argument objects as passed to command. */ - int isEncoder, /* 1 -> convertto, 0 -> convertfrom */ Tcl_Encoding *encPtr, /* Where to store the encoding */ Tcl_Obj **dataObjPtr, /* Where to store ptr to Tcl_Obj containing data */ int *flagsPtr, /* Bit mask of encoding option flags */ @@ -640,15 +639,6 @@ numArgsError: /* ONLY jump here if nothing needs to be freed!!! */ dataObj = objv[objc - 1]; } - /* -failindex forces checking*/ - if (failVarObj != NULL && flags == TCL_ENCODING_NOCOMPLAIN) { - /* - * Historical, but I really don't like this mixing of defines - * from two different bit mask domains - ENCODING_FAILINDEX - */ - flags = isEncoder ? TCL_ENCODING_STOPONERROR : ENCODING_FAILINDEX; - } - *encPtr = encoding; *dataObjPtr = dataObj; *flagsPtr = flags; @@ -688,7 +678,7 @@ EncodingConvertfromObjCmd( Tcl_Obj *failVarObj; if (EncodingConvertParseOptions( - interp, objc, objv, 0, &encoding, &data, &flags, &failVarObj) + interp, objc, objv, &encoding, &data, &flags, &failVarObj) != TCL_OK) { return TCL_ERROR; } @@ -775,7 +765,7 @@ EncodingConverttoObjCmd( Tcl_Obj *failVarObj; if (EncodingConvertParseOptions( - interp, objc, objv, 1, &encoding, &data, &flags, &failVarObj) + interp, objc, objv, &encoding, &data, &flags, &failVarObj) != TCL_OK) { return TCL_ERROR; } -- cgit v0.12 From b185a55c3b335a847e148680c628136c7c16640f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 9 Feb 2023 07:55:29 +0000 Subject: Add 4 testcases, showing that the bug fix introduces another (minor) problem. To be fixed soon --- tests/encoding.test | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/tests/encoding.test b/tests/encoding.test index 05d9918..e42c3b9 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -485,6 +485,18 @@ test encoding-16.8 {Utf32ToUtfProc} -body { set val [encoding convertfrom -nocomplain utf-32 \x41\x00\x00\x41] list $val [format %x [scan $val %c]] } -result "\uFFFD fffd" +test encoding-16.9 {Utf32ToUtfProc} -body { + encoding convertfrom utf-32le \x00\xD8\x00\x00 +} -result \uD800 +test encoding-16.10 {Utf32ToUtfProc} -body { + encoding convertfrom utf-32le \x00\xDC\x00\x00 +} -result \uDC00 +test encoding-16.11 {Utf32ToUtfProc} -body { + encoding convertfrom utf-32le \x00\xD8\x00\x00\x00\xDC\x00\x00 +} -result \uD800\uDC00 +test encoding-16.12 {Utf32ToUtfProc} -body { + encoding convertfrom utf-32le \x00\xDC\x00\x00\x00\xD8\x00\x00 +} -result \uDC00\uD800 test encoding-16.9 { Utf16ToUtfProc, Tcl_UniCharToUtf, surrogate pairs in utf-16 -- cgit v0.12 From d46a2441593da26b460fba5a4612ec43fa0d9215 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 9 Feb 2023 17:03:31 +0000 Subject: Add equivalent tests from ff630bf370 --- tests/cmdAH.test | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index ad5e540..c4053a2 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -229,9 +229,21 @@ set encInvalidBytes { utf-8 A\xed\xb0\x80B tcl8 A\uDC00B -1 Low-surrogate utf-8 A\xed\xb0\x80B strict A 1 Low-surrogate - utf-32le \x41\x00\x00\x00\x00\xD8\x00\x00\x42\x00\x00\x00 default A\uD800B -1 {High-surrogate} - utf-32le \x41\x00\x00\x00\x00\xD8\x00\x00\x42\x00\x00\x00 tcl8 A\uD800B -1 {High-surrogate} - utf-32le \x41\x00\x00\x00\x00\xD8\x00\x00\x42\x00\x00\x00 strict A 4 {High-surrogate} + utf-32le \x00\xD8\x00\x00 default \uD800 -1 {High-surrogate} + utf-32le \x00\xD8\x00\x00 tcl8 \uD800 -1 {High-surrogate} + utf-32le \x00\xD8\x00\x00 strict "" 0 {High-surrogate} + utf-32le \x00\xDC\x00\x00 default \uDC00 -1 {Low-surrogate} + utf-32le \x00\xDC\x00\x00 tcl8 \uDC00 -1 {Low-surrogate} + utf-32le \x00\xDC\x00\x00 strict "" 0 {Low-surrogate} + utf-32le \x00\xD8\x00\x00\x00\xDC\x00\x00 default \uD800\uDC00 -1 {High-low-surrogate} + utf-32le \x00\xD8\x00\x00\x00\xDC\x00\x00 tcl8 \uD800\uDC00 -1 {High-low-surrogate} + utf-32le \x00\xD8\x00\x00\x00\xDC\x00\x00 strict "" 0 {High-low-surrogate} + utf-32le \x00\xDC\x00\x00\x00\xD8\x00\x00 default \uDC00\uD800 -1 {High-low-surrogate} + utf-32le \x00\xDC\x00\x00\x00\xD8\x00\x00 tcl8 \uDC00\uD800 -1 {High-low-surrogate} + utf-32le \x00\xDC\x00\x00\x00\xD8\x00\x00 strict "" 0 {High-low-surrogate} + utf-32le \x41\x00\x00\x00\x00\xD8\x00\x00\x42\x00\x00\x00 default A\uD800B -1 {High-surrogate-middle} + utf-32le \x41\x00\x00\x00\x00\xD8\x00\x00\x42\x00\x00\x00 tcl8 A\uD800B -1 {High-surrogate-middle} + utf-32le \x41\x00\x00\x00\x00\xD8\x00\x00\x42\x00\x00\x00 strict A 4 {High-surrogate-middle} } # Strings that cannot be encoded for specific encoding / profiles -- cgit v0.12 From 9d1ba01f11c772a015e3edbfb1ea4ae8e9f148bf Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 9 Feb 2023 17:04:33 +0000 Subject: Modify encoding C API to use profiles (in progress) --- generic/tcl.h | 22 +++++++++- generic/tclCmdAH.c | 16 ++----- generic/tclEncoding.c | 118 ++++++++++++++++++++++++++++++++++++++------------ generic/tclIO.c | 6 ++- generic/tclInt.h | 13 +----- 5 files changed, 122 insertions(+), 53 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index f373382..ec94e71 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2144,7 +2144,27 @@ typedef struct Tcl_EncodingType { #define TCL_ENCODING_CHAR_LIMIT 0x10 #define TCL_ENCODING_MODIFIED 0x20 #define TCL_ENCODING_NOCOMPLAIN 0x40 -#define TCL_ENCODING_STRICT 0x44 +#define TCL_ENCODING_STRICT 0x44 +/* Reserve top byte for profile values (disjoint) */ +#define TCL_ENCODING_PROFILE_TCL8 0x01000000 +#define TCL_ENCODING_PROFILE_STRICT 0x02000000 +#define TCL_ENCODING_PROFILE_MASK 0xFF000000 +#define TCL_ENCODING_PROFILE_GET(flags_) ((flags_) & TCL_ENCODING_PROFILE_MASK) +#define TCL_ENCODING_PROFILE_SET(flags_, profile_) \ + do { \ + (flags_) &= ~TCL_ENCODING_PROFILE_MASK; \ + (flags_) |= profile_; \ + } while (0) +/* Still being argued - For Tcl9, is the default strict? TODO */ +#if TCL_MAJOR_VERSION < 9 +#define TCL_ENCODING_PROFILE_DEFAULT TCL_ENCODING_PROFILE_TCL8 +#else +#define TCL_ENCODING_PROFILE_DEFAULT TCL_ENCODING_PROFILE_TCL8 /* STRICT? TODO */ +#endif + +#define TCL_ENCODING_EXTERNAL_FLAG_MASK \ + (TCL_ENCODING_START|TCL_ENCODING_END|TCL_ENCODING_STOPONERROR) + /* * The following definitions are the error codes returned by the conversion diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index efc156c..05c0887 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -562,7 +562,7 @@ EncodingConvertParseOptions ( { static const char *const options[] = {"-profile", "-failindex", NULL}; enum convertfromOptions { PROFILE, FAILINDEX } optIndex; - enum TclEncodingProfile profile; + int profile; Tcl_Encoding encoding; Tcl_Obj *dataObj; Tcl_Obj *failVarObj; @@ -614,17 +614,9 @@ numArgsError: /* ONLY jump here if nothing needs to be freed!!! */ != TCL_OK) { return TCL_ERROR; } - switch (profile) { - case TCL_ENCODING_PROFILE_TCL8: - flags = TCL_ENCODING_NOCOMPLAIN; - break; - case TCL_ENCODING_PROFILE_STRICT: - flags = TCL_ENCODING_STRICT; - break; - case TCL_ENCODING_PROFILE_DEFAULT: /* FALLTHRU */ - default: - break; - } + /* TODO - next line probably not needed as the conversion + functions already take care of mapping profile to flags */ + flags = TclEncodingExternalFlagsToInternal(profile); break; case FAILINDEX: failVarObj = objv[argIndex]; diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 106a2f1..8e42e26 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -542,6 +542,8 @@ TclInitEncodingSubsystem(void) Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&encodingMutex); + /* TODO - why is NOCOMPLAIN being hardcoded for encodings below? */ + /* * 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 @@ -1184,13 +1186,12 @@ Tcl_ExternalToUtfDString( * The parameter flags controls the behavior, if any of the bytes in * the source buffer are invalid or cannot be represented in utf-8. * Possible flags values: - * TCL_ENCODING_STOPONERROR: don't replace invalid characters/bytes but - * return the first error position (Default in Tcl 9.0). - * TCL_ENCODING_NOCOMPLAIN: replace invalid characters/bytes by a default - * fallback character. Always return -1 (Default in Tcl 8.7). - * TCL_ENCODING_MODIFIED: convert NULL bytes to \xC0\x80 in stead of 0x00. - * Only valid for "utf-8" and "cesu-8". This flag may be used together - * with the other flags. + * target encoding. It should be composed by OR-ing the following: + * - *At most one* of TCL_ENCODING_PROFILE{DEFAULT,TCL8,STRICT} + * - TCL_ENCODING_STOPONERROR: Backward compatibility. Sets the profile + * to TCL_ENCODING_PROFILE_STRICT overriding any specified profile flags + * - TCL_ENCODING_MODIFIED: enable Tcl internal conversion mapping \xC0\x80 + * to 0x00. Only valid for "utf-8" and "cesu-8". * * Results: * The converted bytes are stored in the DString, which is then NULL @@ -1236,6 +1237,7 @@ Tcl_ExternalToUtfDStringEx( srcLen = encodingPtr->lengthProc(src); } + flags = TclEncodingExternalFlagsToInternal(flags); flags |= TCL_ENCODING_START | TCL_ENCODING_END; if (encodingPtr->toUtfProc == UtfToUtfProc) { flags |= TCL_ENCODING_MODIFIED | TCL_ENCODING_UTF; @@ -1408,7 +1410,7 @@ Tcl_UtfToExternalDString( Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { - Tcl_UtfToExternalDStringEx(encoding, src, srcLen, TCL_ENCODING_NOCOMPLAIN, dstPtr); + Tcl_UtfToExternalDStringEx(encoding, src, srcLen, TCL_ENCODING_PROFILE_DEFAULT, dstPtr); return Tcl_DStringValue(dstPtr); } @@ -1421,15 +1423,12 @@ Tcl_UtfToExternalDString( * Convert a source buffer from UTF-8 to the specified encoding. * The parameter flags controls the behavior, if any of the bytes in * the source buffer are invalid or cannot be represented in the - * target encoding. - * Possible flags values: - * TCL_ENCODING_STOPONERROR: don't replace invalid characters/bytes but - * return the first error position (Default in Tcl 9.0). - * TCL_ENCODING_NOCOMPLAIN: replace invalid characters/bytes by a default - * fallback character. Always return -1 (Default in Tcl 8.7). - * TCL_ENCODING_MODIFIED: convert NULL bytes to \xC0\x80 in stead of 0x00. - * Only valid for "utf-8" and "cesu-8". This flag may be used together - * with the other flags. + * target encoding. It should be composed by OR-ing the following: + * - *At most one* of TCL_ENCODING_PROFILE{DEFAULT,TCL8,STRICT} + * - TCL_ENCODING_STOPONERROR: Backward compatibility. Sets the profile + * to TCL_ENCODING_PROFILE_STRICT overriding any specified profile flags + * - TCL_ENCODING_MODIFIED: convert NULL bytes to \xC0\x80 instead + * of 0x00. Only valid for "utf-8" and "cesu-8". * * Results: * The converted bytes are stored in the DString, which is then NULL @@ -1450,7 +1449,7 @@ Tcl_UtfToExternalDStringEx( const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes, or < 0 for * strlen(). */ - int flags, /* Conversion control flags. */ + int flags, /* Conversion control flags. */ Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { @@ -1474,6 +1473,7 @@ Tcl_UtfToExternalDStringEx( } else if (srcLen < 0) { srcLen = strlen(src); } + flags = TclEncodingExternalFlagsToInternal(flags); flags |= TCL_ENCODING_START | TCL_ENCODING_END; while (1) { result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, @@ -4095,7 +4095,7 @@ InitializeEncodingSearchPath( * * TclEncodingProfileParseName -- * - * Maps an encoding profile name to its enum value. + * Maps an encoding profile name to its integer equivalent. * * Results: * TCL_OK on success or TCL_ERROR on failure. @@ -4107,17 +4107,22 @@ InitializeEncodingSearchPath( */ int TclEncodingProfileParseName( - Tcl_Interp *interp, /* For error messages. May be NULL */ - const char *profileName, /* Name of profile */ - enum TclEncodingProfile *profilePtr) /* Output */ + Tcl_Interp *interp, /* For error messages. May be NULL */ + const char *profileName, /* Name of profile */ + int *profilePtr) /* Output */ { - /* NOTE: Order must match enum TclEncodingProfile !!! */ - static const char *const profileNames[] = {"", "tcl8", "strict"}; - int idx; + /* NOTE: Order in arrays must match !!! */ + static const char *const profileNames[] = {"", "tcl8", "strict", NULL}; + static int profileFlags[] = { + TCL_ENCODING_PROFILE_DEFAULT, + TCL_ENCODING_PROFILE_TCL8, + TCL_ENCODING_PROFILE_STRICT, + }; + int i; - for (idx = 0; idx < sizeof(profileNames) / sizeof(profileNames[0]); ++idx) { - if (!strcmp(profileName, profileNames[idx])) { - *profilePtr = (enum TclEncodingProfile)idx; + for (i = 0; i < sizeof(profileNames) / sizeof(profileNames[0]); ++i) { + if (!strcmp(profileName, profileNames[i])) { + *profilePtr = profileFlags[i]; return TCL_OK; } } @@ -4134,6 +4139,63 @@ TclEncodingProfileParseName( } /* + *------------------------------------------------------------------------ + * + * TclEncodingExternalFlagsToInternal -- + * + * Maps the flags supported in the encoding C API's to internal flags. + * + * TCL_ENCODING_STRICT and TCL_ENCODING_NOCOMPLAIN are masked off + * because they are for internal use only and externally specified + * through TCL_ENCODING_PROFILE_* bits. + * + * For backward compatibility reasons, TCL_ENCODING_STOPONERROR is + * is mapped to the TCL_ENCODING_PROFILE_STRICT overwriting any profile + * specified. + * + * If no profile or an invalid profile is specified, it is set to + * the default. + * + * Results: + * Internal encoding flag mask. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------ + */ +int TclEncodingExternalFlagsToInternal(int flags) +{ + flags &= ~(TCL_ENCODING_STRICT | TCL_ENCODING_NOCOMPLAIN); + if (flags & TCL_ENCODING_STOPONERROR) { + TCL_ENCODING_PROFILE_SET(flags, TCL_ENCODING_PROFILE_STRICT); + } + else { + int profile = TCL_ENCODING_PROFILE_GET(flags); + switch (profile) { + case TCL_ENCODING_PROFILE_TCL8: + flags |= TCL_ENCODING_NOCOMPLAIN; + break; + case TCL_ENCODING_PROFILE_STRICT: + flags |= TCL_ENCODING_STRICT; + break; + default: + /* TODO - clean this up once default mechanisms settled */ + TCL_ENCODING_PROFILE_SET(flags, TCL_ENCODING_PROFILE_DEFAULT); +#if TCL_ENCODING_PROFILE_DEFAULT == TCL_ENCODING_PROFILE_TCL8 + flags |= TCL_ENCODING_NOCOMPLAIN; +#elif TCL_ENCODING_PROFILE_DEFAULT == TCL_ENCODING_PROFILE_STRICT + flags |= TCL_ENCODING_STRICT; +#else +#error TCL_ENCODING_PROFILE_DEFAULT must be TCL8 or STRICT +#endif + break; + } + } + return flags; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclIO.c b/generic/tclIO.c index 370ca95..0152740 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -8379,7 +8379,7 @@ Tcl_SetChannelOption( statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; return TCL_OK; } else if (HaveOpt(1, "-encodingprofile")) { - enum TclEncodingProfile profile; + int profile; if (TclEncodingProfileParseName(interp, newValue, &profile) != TCL_OK) { return TCL_ERROR; } @@ -8392,7 +8392,11 @@ Tcl_SetChannelOption( ResetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); SetFlag(statePtr, CHANNEL_ENCODING_STRICT); break; + /* TODO - clean up this DEFAULT handling once channel flags fixed */ +#if TCL_ENCODING_PROFILE_DEFAULT != TCL_ENCODING_PROFILE_TCL8 \ + && TCL_ENCODING_PROFILE_DEFAULT != TCL_ENCODING_PROFILE_STRICT case TCL_ENCODING_PROFILE_DEFAULT: /* FALLTHRU */ +#endif default: ResetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); ResetFlag(statePtr, CHANNEL_ENCODING_STRICT); diff --git a/generic/tclInt.h b/generic/tclInt.h index 82728d3..2b491d6 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2883,21 +2883,12 @@ MODULE_SCOPE TclPlatformType tclPlatform; * Declarations related to internal encoding functions. */ -/* - * Enum for encoding profiles that control encoding treatment of - * invalid bytes. NOTE: Order must match that of encodingProfileNames in - * TclEncodingProfileParseName() !!! - */ -enum TclEncodingProfile { - TCL_ENCODING_PROFILE_DEFAULT, - TCL_ENCODING_PROFILE_TCL8, - TCL_ENCODING_PROFILE_STRICT, -}; MODULE_SCOPE Tcl_Encoding tclIdentityEncoding; MODULE_SCOPE int TclEncodingProfileParseName(Tcl_Interp *interp, const char *profileName, - enum TclEncodingProfile *profilePtr); + int *profilePtr); +MODULE_SCOPE int TclEncodingExternalFlagsToInternal(int flags); /* * TIP #233 (Virtualized Time) -- cgit v0.12 From fd83fb931e43901b77f4e480ef63841e10b39f22 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 9 Feb 2023 19:52:00 +0000 Subject: Add 4 more testcases, showing that the same bug is present in utf-16 as well. Also fix the bug (really, now!) --- generic/tclEncoding.c | 44 ++++++++++++++++++++++++++++++++++++-------- tests/encoding.test | 12 ++++++++++++ 2 files changed, 48 insertions(+), 8 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index d19e237..0941f14 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2531,7 +2531,7 @@ Utf32ToUtfProc( const char *srcStart, *srcEnd; const char *dstEnd, *dstStart; int result, numChars, charLimit = INT_MAX; - int ch; + int ch = 0; flags |= PTR2INT(clientData); if (flags & TCL_ENCODING_CHAR_LIMIT) { @@ -2548,6 +2548,19 @@ Utf32ToUtfProc( srcLen &= -4; } + /* + * If last code point is a high surrogate, we cannot handle that yet, + * unless we are at the end. + */ + + if (!(flags & TCL_ENCODING_END) && (srcLen >= 4) && + ((src[srcLen - ((flags & TCL_ENCODING_LE)?3:2)] & 0xFC) == 0xD8) && + ((src[srcLen - ((flags & TCL_ENCODING_LE)?2:3)]) == 0) && + ((src[srcLen - ((flags & TCL_ENCODING_LE)?1:4)]) == 0)) { + result = TCL_CONVERT_MULTIBYTE; + srcLen-= 4; + } + srcStart = src; srcEnd = src + srcLen; @@ -2560,11 +2573,16 @@ Utf32ToUtfProc( break; } + int prev = ch; if (flags & TCL_ENCODING_LE) { ch = (src[3] & 0xFF) << 24 | (src[2] & 0xFF) << 16 | (src[1] & 0xFF) << 8 | (src[0] & 0xFF); } else { ch = (src[0] & 0xFF) << 24 | (src[1] & 0xFF) << 16 | (src[2] & 0xFF) << 8 | (src[3] & 0xFF); } + if (((prev & ~0x3FF) == 0xD800) && ((ch & ~0x3FF) != 0xDC00)) { + /* Bug [10c2c17c32]. If Hi surrogate not followed by Lo surrogate, finish 3-byte UTF-8 */ + dst += Tcl_UniCharToUtf(-1, dst); + } if ((unsigned)ch > 0x10FFFF || (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) && ((ch & ~0x7FF) == 0xD800))) { if (STOPONERROR) { @@ -2582,14 +2600,14 @@ Utf32ToUtfProc( *dst++ = (ch & 0xFF); } else { dst += Tcl_UniCharToUtf(ch, dst); - if ((ch & ~0x3FF) == 0xD800) { - /* Bug [10c2c17c32]. If Hi surrogate, finish 3-byte UTF-8 */ - dst += Tcl_UniCharToUtf(-1, dst); - } } src += sizeof(unsigned int); } + if ((ch & ~0x3FF) == 0xD800) { + /* Bug [10c2c17c32]. If Hi surrogate, finish 3-byte UTF-8 */ + dst += Tcl_UniCharToUtf(-1, dst); + } *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; *dstCharsPtr = numChars; @@ -2734,7 +2752,7 @@ Utf16ToUtfProc( const char *srcStart, *srcEnd; const char *dstEnd, *dstStart; int result, numChars, charLimit = INT_MAX; - unsigned short ch; + unsigned short ch = 0; flags |= PTR2INT(clientData); if (flags & TCL_ENCODING_CHAR_LIMIT) { @@ -2752,10 +2770,11 @@ Utf16ToUtfProc( } /* - * If last code point is a high surrogate, we cannot handle that yet. + * If last code point is a high surrogate, we cannot handle that yet, + * unless we are at the end. */ - if ((srcLen >= 2) && + if (!(flags & TCL_ENCODING_END) && (srcLen >= 2) && ((src[srcLen - ((flags & TCL_ENCODING_LE)?1:2)] & 0xFC) == 0xD8)) { result = TCL_CONVERT_MULTIBYTE; srcLen-= 2; @@ -2773,11 +2792,16 @@ Utf16ToUtfProc( break; } + unsigned short prev = ch; if (flags & TCL_ENCODING_LE) { ch = (src[1] & 0xFF) << 8 | (src[0] & 0xFF); } else { ch = (src[0] & 0xFF) << 8 | (src[1] & 0xFF); } + if (((prev & ~0x3FF) == 0xD800) && ((ch & ~0x3FF) != 0xDC00)) { + /* Bug [10c2c17c32]. If Hi surrogate not followed by Lo surrogate, finish 3-byte UTF-8 */ + dst += Tcl_UniCharToUtf(-1, dst); + } /* * Special case for 1-byte utf chars for speed. Make sure we work with @@ -2792,6 +2816,10 @@ Utf16ToUtfProc( src += sizeof(unsigned short); } + if ((ch & ~0x3FF) == 0xD800) { + /* Bug [10c2c17c32]. If Hi surrogate, finish 3-byte UTF-8 */ + dst += Tcl_UniCharToUtf(-1, dst); + } *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; *dstCharsPtr = numChars; diff --git a/tests/encoding.test b/tests/encoding.test index e42c3b9..b2b029e 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -497,6 +497,18 @@ test encoding-16.11 {Utf32ToUtfProc} -body { test encoding-16.12 {Utf32ToUtfProc} -body { encoding convertfrom utf-32le \x00\xDC\x00\x00\x00\xD8\x00\x00 } -result \uDC00\uD800 +test encoding-16.13 {Utf16ToUtfProc} -body { + encoding convertfrom utf-16le \x00\xD8 +} -result \uD800 +test encoding-16.14 {Utf16ToUtfProc} -body { + encoding convertfrom utf-16le \x00\xDC +} -result \uDC00 +test encoding-16.15 {Utf16ToUtfProc} -body { + encoding convertfrom utf-16le \x00\xD8\x00\xDC +} -result \uD800\uDC00 +test encoding-16.16 {Utf16ToUtfProc} -body { + encoding convertfrom utf-16le \x00\xDC\x00\xD8 +} -result \uDC00\uD800 test encoding-16.9 { Utf16ToUtfProc, Tcl_UniCharToUtf, surrogate pairs in utf-16 -- cgit v0.12 From e26214c28753b22c398ba4d7196a8afae999ab5a Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 10 Feb 2023 17:07:12 +0000 Subject: Phase out (almost) STRICT and NOCOMPLAIN flags. --- generic/tclCmdAH.c | 38 +++++++++------- generic/tclEncoding.c | 114 +++++++++++++++++++++++++++++++++++------------- generic/tclIO.c | 118 ++++++++++++-------------------------------------- generic/tclIO.h | 3 +- generic/tclInt.h | 8 ++-- 5 files changed, 140 insertions(+), 141 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 05c0887..5fbe27e 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -543,7 +543,7 @@ TclInitEncodingCmd( * if non-NULL * - *dataObjPtr is set to the Tcl_Obj containing the data to encode or * decode - * - *flagsPtr is set to encoding error handling flags + * - *profilePtr is set to encoding error handling profile * - *failVarPtr is set to -failindex option value or NULL * On error, all of the above are uninitialized. * @@ -556,20 +556,19 @@ EncodingConvertParseOptions ( Tcl_Obj *const objv[], /* Argument objects as passed to command. */ Tcl_Encoding *encPtr, /* Where to store the encoding */ Tcl_Obj **dataObjPtr, /* Where to store ptr to Tcl_Obj containing data */ - int *flagsPtr, /* Bit mask of encoding option flags */ + int *profilePtr, /* Bit mask of encoding option profile */ Tcl_Obj **failVarPtr /* Where to store -failindex option value */ ) { static const char *const options[] = {"-profile", "-failindex", NULL}; enum convertfromOptions { PROFILE, FAILINDEX } optIndex; - int profile; Tcl_Encoding encoding; Tcl_Obj *dataObj; Tcl_Obj *failVarObj; #if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) - int flags = TCL_ENCODING_STOPONERROR; + int profile = TCL_ENCODING_PROFILE_TCL8; /* TODO - default for Tcl9? */ #else - int flags = TCL_ENCODING_NOCOMPLAIN; + int profile = TCL_ENCODING_PROFILE_TCL8; #endif /* @@ -609,14 +608,16 @@ numArgsError: /* ONLY jump here if nothing needs to be freed!!! */ } switch (optIndex) { case PROFILE: - if (TclEncodingProfileParseName( + if (TclEncodingProfileNameToId( interp, Tcl_GetString(objv[argIndex]), &profile) != TCL_OK) { return TCL_ERROR; } +#ifdef NOTNEEDED /* TODO - next line probably not needed as the conversion functions already take care of mapping profile to flags */ - flags = TclEncodingExternalFlagsToInternal(profile); + profile = TclEncodingExternalFlagsToInternal(profile); +#endif break; case FAILINDEX: failVarObj = objv[argIndex]; @@ -633,7 +634,7 @@ numArgsError: /* ONLY jump here if nothing needs to be freed!!! */ *encPtr = encoding; *dataObjPtr = dataObj; - *flagsPtr = flags; + *profilePtr = profile; *failVarPtr = failVarObj; return TCL_OK; @@ -676,20 +677,23 @@ EncodingConvertfromObjCmd( } /* - * Convert the string into a byte array in 'ds' + * Convert the string into a byte array in 'ds'. */ #if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) - if (!(flags & TCL_ENCODING_STOPONERROR)) { + if (TCL_ENCODING_PROFILE_GET(flags) == TCL_ENCODING_PROFILE_TCL8) { + /* Permits high bits to be non-0 in byte array (Tcl 8 style) */ bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); - } else + } + else #endif - bytesPtr = (char *) TclGetBytesFromObj(interp, data, &length); + bytesPtr = (char *) TclGetBytesFromObj(interp, data, &length); + if (bytesPtr == NULL) { return TCL_ERROR; } result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, flags, &ds); - if ((!(flags & TCL_ENCODING_NOCOMPLAIN) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)) && (result != TCL_INDEX_NONE)) { + if (result != TCL_INDEX_NONE) { if (failVarObj != NULL) { if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; @@ -704,7 +708,8 @@ EncodingConvertfromObjCmd( Tcl_DStringFree(&ds); return TCL_ERROR; } - } else if (failVarObj != NULL) { + } + else if (failVarObj != NULL) { if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(-1), TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } @@ -769,7 +774,7 @@ EncodingConverttoObjCmd( stringPtr = TclGetStringFromObj(data, &length); result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, flags, &ds); - if ((!(flags & TCL_ENCODING_NOCOMPLAIN) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)) && (result != TCL_INDEX_NONE)) { + if (result != TCL_INDEX_NONE) { if (failVarObj != NULL) { /* I hope, wide int will cover size_t data type */ if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) { @@ -788,7 +793,8 @@ EncodingConverttoObjCmd( Tcl_DStringFree(&ds); return TCL_ERROR; } - } else if (failVarObj != NULL) { + } + else if (failVarObj != NULL) { if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(-1), TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 8e42e26..153f8d3 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -188,6 +188,15 @@ static Tcl_Encoding systemEncoding = NULL; Tcl_Encoding tclIdentityEncoding = NULL; /* + * Names of encoding profiles and corresponding integer values + */ +static struct TclEncodingProfiles { + const char *name; + int value; +} encodingProfiles[] = {{"tcl8", TCL_ENCODING_PROFILE_TCL8}, + {"strict", TCL_ENCODING_PROFILE_STRICT}}; + +/* * The following variable is used in the sparse matrix code for a * TableEncoding to represent a page in the table that has no entries. */ @@ -1172,7 +1181,7 @@ Tcl_ExternalToUtfDString( Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { - Tcl_ExternalToUtfDStringEx(encoding, src, srcLen, TCL_ENCODING_NOCOMPLAIN, dstPtr); + Tcl_ExternalToUtfDStringEx(encoding, src, srcLen, TCL_ENCODING_PROFILE_TCL8, dstPtr); return Tcl_DStringValue(dstPtr); } @@ -2315,11 +2324,17 @@ BinaryProc( *------------------------------------------------------------------------- */ +#ifdef OBSOLETE #if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) # define STOPONERROR (!(flags & TCL_ENCODING_NOCOMPLAIN) || (flags & TCL_ENCODING_STOPONERROR)) #else # define STOPONERROR (flags & TCL_ENCODING_STOPONERROR) #endif +#endif + + +#define STRICT_PROFILE(flags_) (TCL_ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_STRICT) +#define STOPONERROR STRICT_PROFILE(flags) static int UtfToUtfProc( @@ -2386,10 +2401,11 @@ UtfToUtfProc( */ *dst++ = *src++; - } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) - && (UCHAR(src[1]) == 0x80) && (!(flags & TCL_ENCODING_MODIFIED) - || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) - || (flags & ENCODING_FAILINDEX))) { + } else if ((UCHAR(*src) == 0xC0) && + (src + 1 < srcEnd) && + (UCHAR(src[1]) == 0x80) && + (!(flags & TCL_ENCODING_MODIFIED) + || (STRICT_PROFILE(flags)))) { /* * If in input mode, and -strict or -failindex is specified: This is an error. */ @@ -2403,7 +2419,8 @@ UtfToUtfProc( */ *dst++ = 0; src += 2; - } else if (!Tcl_UtfCharComplete(src, srcEnd - src)) { + } + else if (!Tcl_UtfCharComplete(src, srcEnd - src)) { /* * Always check before using TclUtfToUCS4. Not doing can so * cause it run beyond the end of the buffer! If we happen such an @@ -2416,10 +2433,10 @@ UtfToUtfProc( result = TCL_CONVERT_MULTIBYTE; break; } - if (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) || (flags & ENCODING_FAILINDEX)) { - result = TCL_CONVERT_SYNTAX; - break; - } + if (STRICT_PROFILE(flags)) { + result = TCL_CONVERT_SYNTAX; + break; + } ch = UCHAR(*src++); } else { char chbuf[2]; @@ -2427,12 +2444,13 @@ UtfToUtfProc( TclUtfToUCS4(chbuf, &ch); } dst += Tcl_UniCharToUtf(ch, dst); - } else { + } + else { int low; const char *saveSrc = src; size_t len = TclUtfToUCS4(src, &ch); if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_MODIFIED) - && (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT))) { + && STRICT_PROFILE(flags)) { result = TCL_CONVERT_SYNTAX; break; } @@ -2475,8 +2493,9 @@ UtfToUtfProc( result = TCL_CONVERT_UNKNOWN; src = saveSrc; break; - } else if (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) - && (flags & TCL_ENCODING_MODIFIED) && ((ch & ~0x7FF) == 0xD800)) { + } else if (STRICT_PROFILE(flags) && + (flags & TCL_ENCODING_MODIFIED) && + ((ch & ~0x7FF) == 0xD800)) { result = TCL_CONVERT_SYNTAX; src = saveSrc; break; @@ -2567,8 +2586,8 @@ Utf32ToUtfProc( } else { ch = (src[0] & 0xFF) << 24 | (src[1] & 0xFF) << 16 | (src[2] & 0xFF) << 8 | (src[3] & 0xFF); } - if ((unsigned)ch > 0x10FFFF || (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) - && ((ch & ~0x7FF) == 0xD800))) { + if ((unsigned)ch > 0x10FFFF + || (STRICT_PROFILE(flags) && ((ch & ~0x7FF) == 0xD800))) { if (STOPONERROR) { result = TCL_CONVERT_SYNTAX; break; @@ -4095,34 +4114,27 @@ InitializeEncodingSearchPath( * * TclEncodingProfileParseName -- * - * Maps an encoding profile name to its integer equivalent. + * Maps an encoding profile name to its integer equivalent. * * Results: - * TCL_OK on success or TCL_ERROR on failure. + * TCL_OK on success or TCL_ERROR on failure. * * Side effects: - * Returns the profile enum value in *profilePtr + * Returns the profile enum value in *profilePtr * *------------------------------------------------------------------------ */ int -TclEncodingProfileParseName( +TclEncodingProfileNameToId( Tcl_Interp *interp, /* For error messages. May be NULL */ const char *profileName, /* Name of profile */ int *profilePtr) /* Output */ { - /* NOTE: Order in arrays must match !!! */ - static const char *const profileNames[] = {"", "tcl8", "strict", NULL}; - static int profileFlags[] = { - TCL_ENCODING_PROFILE_DEFAULT, - TCL_ENCODING_PROFILE_TCL8, - TCL_ENCODING_PROFILE_STRICT, - }; int i; - for (i = 0; i < sizeof(profileNames) / sizeof(profileNames[0]); ++i) { - if (!strcmp(profileName, profileNames[i])) { - *profilePtr = profileFlags[i]; + for (i = 0; i < sizeof(encodingProfiles) / sizeof(encodingProfiles[0]); ++i) { + if (!strcmp(profileName, encodingProfiles[i].name)) { + *profilePtr = encodingProfiles[i].value; return TCL_OK; } } @@ -4130,13 +4142,52 @@ TclEncodingProfileParseName( Tcl_SetObjResult( interp, Tcl_ObjPrintf( - "bad profile \"%s\". Must be \"\", \"tcl8\" or \"strict\".", + "bad profile \"%s\". Must be \"tcl8\" or \"strict\".", profileName)); Tcl_SetErrorCode( interp, "TCL", "ENCODING", "PROFILE", profileName, NULL); } return TCL_ERROR; } + +/* + *------------------------------------------------------------------------ + * + * TclEncodingProfileValueToName -- + * + * Maps an encoding profile value to its name. + * + * Results: + * Pointer to the name or NULL on failure. Caller must not make + * not modify the string and must make a copy to hold on to it. + * + * Side effects: + * None. + *------------------------------------------------------------------------ + */ +const char * +TclEncodingProfileIdToName( + Tcl_Interp *interp, /* For error messages. May be NULL */ + int profileValue) /* Profile #define value */ +{ + int i; + + for (i = 0; i < sizeof(encodingProfiles) / sizeof(encodingProfiles[0]); ++i) { + if (profileValue == encodingProfiles[i].value) { + return encodingProfiles[i].name; + } + } + if (interp) { + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf( + "Internal error. Bad profile id \"%d\".", + profileValue)); + Tcl_SetErrorCode( + interp, "TCL", "ENCODING", "PROFILEID", NULL); + } + return NULL; +} /* *------------------------------------------------------------------------ @@ -4179,6 +4230,7 @@ int TclEncodingExternalFlagsToInternal(int flags) case TCL_ENCODING_PROFILE_STRICT: flags |= TCL_ENCODING_STRICT; break; + case 0: /* Unspecified by caller */ default: /* TODO - clean this up once default mechanisms settled */ TCL_ENCODING_PROFILE_SET(flags, TCL_ENCODING_PROFILE_DEFAULT); diff --git a/generic/tclIO.c b/generic/tclIO.c index 0152740..49f4257 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -1700,8 +1700,12 @@ Tcl_CreateChannel( } statePtr->inputEncodingState = NULL; statePtr->inputEncodingFlags = TCL_ENCODING_START; + TCL_ENCODING_PROFILE_SET(statePtr->inputEncodingFlags, + TCL_ENCODING_PROFILE_DEFAULT); statePtr->outputEncodingState = NULL; statePtr->outputEncodingFlags = TCL_ENCODING_START; + TCL_ENCODING_PROFILE_SET(statePtr->outputEncodingFlags, + TCL_ENCODING_PROFILE_DEFAULT); /* * Set the channel up initially in AUTO input translation mode to accept @@ -4394,21 +4398,6 @@ Write( } /* - * Transfer encoding nocomplain/strict option to the encoding flags - */ - - if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) { - statePtr->outputEncodingFlags |= TCL_ENCODING_STRICT; -#ifdef TCL_NO_DEPRECATED - } else if (GotFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN)) { - statePtr->outputEncodingFlags &= ~TCL_ENCODING_STRICT; - statePtr->outputEncodingFlags |= TCL_ENCODING_NOCOMPLAIN; -#endif - } else { - statePtr->outputEncodingFlags &= ~TCL_ENCODING_STRICT; - } - - /* * Write the terminated escape sequence even if srcLen is 0. */ @@ -4733,21 +4722,6 @@ Tcl_GetsObj( } /* - * Transfer encoding nocomplain/strict option to the encoding flags - */ - - if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) { - statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT; -#ifdef TCL_NO_DEPRECATED - } else if (GotFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN)) { - statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT; - statePtr->inputEncodingFlags |= TCL_ENCODING_NOCOMPLAIN; -#endif - } else { - statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT; - } - - /* * Object used by FilterInputBytes to keep track of how much data has been * consumed from the channel buffers. */ @@ -5528,21 +5502,6 @@ FilterInputBytes( } gsPtr->state = statePtr->inputEncodingState; - /* - * Transfer encoding nocomplain/strict option to the encoding flags - */ - - if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) { - statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT; -#ifdef TCL_NO_DEPRECATED - } else if (GotFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN)) { - statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT; - statePtr->inputEncodingFlags |= TCL_ENCODING_NOCOMPLAIN; -#endif - } else { - statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT; - } - result = Tcl_ExternalToUtf(NULL, gsPtr->encoding, raw, rawLen, statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE, &statePtr->inputEncodingState, dst, spaceLeft, &gsPtr->rawRead, @@ -6349,21 +6308,6 @@ ReadChars( } /* - * Transfer encoding nocomplain/strict option to the encoding flags - */ - - if (GotFlag(statePtr, CHANNEL_ENCODING_STRICT)) { - statePtr->inputEncodingFlags |= TCL_ENCODING_STRICT; -#ifdef TCL_NO_DEPRECATED - } else if (GotFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN)) { - statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT; - statePtr->inputEncodingFlags |= TCL_ENCODING_NOCOMPLAIN; -#endif - } else { - statePtr->inputEncodingFlags &= ~TCL_ENCODING_STRICT; - } - - /* * This routine is burdened with satisfying several constraints. It cannot * append more than 'charsToRead` chars onto objPtr. This is measured * after encoding and translation transformations are completed. There is @@ -8065,16 +8009,18 @@ Tcl_GetChannelOption( } } if (len == 0 || HaveOpt(1, "-encodingprofile")) { + int profile; + const char *profileName; if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-encodingprofile"); } - if (flags & CHANNEL_ENCODING_STRICT) { - Tcl_DStringAppendElement(dsPtr, "strict"); - } else if (flags & CHANNEL_ENCODING_NOCOMPLAIN) { - Tcl_DStringAppendElement(dsPtr, "tcl8"); - } else { - Tcl_DStringAppendElement(dsPtr, ""); + /* Note currently input and output profiles are same */ + profile = TCL_ENCODING_PROFILE_GET(statePtr->inputEncodingFlags); + profileName = TclEncodingProfileIdToName(interp, profile); + if (profileName == NULL) { + return TCL_ERROR; } + Tcl_DStringAppendElement(dsPtr, profileName); if (len > 0) { return TCL_OK; } @@ -8293,6 +8239,7 @@ Tcl_SetChannelOption( return TCL_OK; } else if (HaveOpt(2, "-encoding")) { Tcl_Encoding encoding; + int profile; if ((newValue[0] == '\0') || (strcmp(newValue, "binary") == 0)) { encoding = NULL; @@ -8317,9 +8264,12 @@ Tcl_SetChannelOption( Tcl_FreeEncoding(statePtr->encoding); statePtr->encoding = encoding; statePtr->inputEncodingState = NULL; + profile = TCL_ENCODING_PROFILE_GET(statePtr->inputEncodingFlags); statePtr->inputEncodingFlags = TCL_ENCODING_START; + TCL_ENCODING_PROFILE_SET(statePtr->inputEncodingFlags, profile); statePtr->outputEncodingState = NULL; statePtr->outputEncodingFlags = TCL_ENCODING_START; + TCL_ENCODING_PROFILE_SET(statePtr->outputEncodingFlags, profile); /* Same as input */ ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA|CHANNEL_ENCODING_ERROR); UpdateInterest(chanPtr); return TCL_OK; @@ -8380,28 +8330,11 @@ Tcl_SetChannelOption( return TCL_OK; } else if (HaveOpt(1, "-encodingprofile")) { int profile; - if (TclEncodingProfileParseName(interp, newValue, &profile) != TCL_OK) { + if (TclEncodingProfileNameToId(interp, newValue, &profile) != TCL_OK) { return TCL_ERROR; } - switch (profile) { - case TCL_ENCODING_PROFILE_TCL8: - ResetFlag(statePtr, CHANNEL_ENCODING_STRICT); - SetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); - break; - case TCL_ENCODING_PROFILE_STRICT: - ResetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); - SetFlag(statePtr, CHANNEL_ENCODING_STRICT); - break; - /* TODO - clean up this DEFAULT handling once channel flags fixed */ -#if TCL_ENCODING_PROFILE_DEFAULT != TCL_ENCODING_PROFILE_TCL8 \ - && TCL_ENCODING_PROFILE_DEFAULT != TCL_ENCODING_PROFILE_STRICT - case TCL_ENCODING_PROFILE_DEFAULT: /* FALLTHRU */ -#endif - default: - ResetFlag(statePtr, CHANNEL_ENCODING_NOCOMPLAIN); - ResetFlag(statePtr, CHANNEL_ENCODING_STRICT); - break; - } + TCL_ENCODING_PROFILE_SET(statePtr->inputEncodingFlags, profile); + TCL_ENCODING_PROFILE_SET(statePtr->outputEncodingFlags, profile); ResetFlag(statePtr, CHANNEL_NEED_MORE_DATA|CHANNEL_ENCODING_ERROR); return TCL_OK; } else if (HaveOpt(1, "-translation")) { @@ -9493,12 +9426,17 @@ TclCopyChannel( * of the bytes themselves. */ + /* + * TODO - should really only allow lossless profiles. Below reflects + * Tcl 8.7 alphas prior to encoding profiles + */ + moveBytes = inStatePtr->inEofChar == '\0' /* No eofChar to stop input */ && inStatePtr->inputTranslation == TCL_TRANSLATE_LF && outStatePtr->outputTranslation == TCL_TRANSLATE_LF && inStatePtr->encoding == outStatePtr->encoding - && (inStatePtr->flags & TCL_ENCODING_STRICT) != TCL_ENCODING_STRICT - && outStatePtr->flags & TCL_ENCODING_NOCOMPLAIN; + && TCL_ENCODING_PROFILE_GET(inStatePtr->flags) != TCL_ENCODING_PROFILE_STRICT + && TCL_ENCODING_PROFILE_GET(outStatePtr->flags) == TCL_ENCODING_PROFILE_TCL8; /* * Allocate a new CopyState to maintain info about the current copy in @@ -9826,8 +9764,8 @@ CopyData( inBinary = (inStatePtr->encoding == NULL); outBinary = (outStatePtr->encoding == NULL); sameEncoding = inStatePtr->encoding == outStatePtr->encoding - && (inStatePtr->flags & TCL_ENCODING_STRICT) != TCL_ENCODING_STRICT - && outStatePtr->flags & TCL_ENCODING_NOCOMPLAIN; + && TCL_ENCODING_PROFILE_GET(inStatePtr->flags) != TCL_ENCODING_PROFILE_STRICT + && TCL_ENCODING_PROFILE_GET(outStatePtr->flags) == TCL_ENCODING_PROFILE_TCL8; if (!(inBinary || sameEncoding)) { TclNewObj(bufObj); diff --git a/generic/tclIO.h b/generic/tclIO.h index a69e990..3f2feee 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -275,16 +275,17 @@ typedef struct ChannelState { * encountered an encoding error */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ +#ifdef APN #define CHANNEL_ENCODING_NOCOMPLAIN (1<<17) /* set if option * -nocomplainencoding is set to 1 */ #define CHANNEL_ENCODING_STRICT (1<<18) /* set if option * -strictencoding is set to 1 */ +#endif #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. * Its structures are still live and * usable, but it may not be closed * again from within the close * handler. */ -#define ENCODING_FAILINDEX (1<<20) /* Internal flag, fail on Invalid bytes only */ #define CHANNEL_CLOSEDWRITE (1<<21) /* Channel write side has been closed. * No further Tcl-level write IO on * the channel is allowed. */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 2b491d6..4b6303d 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2885,9 +2885,11 @@ MODULE_SCOPE TclPlatformType tclPlatform; MODULE_SCOPE Tcl_Encoding tclIdentityEncoding; MODULE_SCOPE int -TclEncodingProfileParseName(Tcl_Interp *interp, - const char *profileName, - int *profilePtr); +TclEncodingProfileNameToId(Tcl_Interp *interp, + const char *profileName, + int *profilePtr); +MODULE_SCOPE const char *TclEncodingProfileIdToName(Tcl_Interp *interp, + int profileId); MODULE_SCOPE int TclEncodingExternalFlagsToInternal(int flags); /* -- cgit v0.12 From bab9170bdca67622ada57df9a0e7f55c5ac92b2f Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 10 Feb 2023 20:22:07 +0000 Subject: Proposed fix (and testcases) for [4a7397e0b3]: Tcl 9: fcopy with -strictencoding 1 UTF-8 channels --- generic/tclIO.c | 8 +++++ tests/io.test | 97 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 105 insertions(+) diff --git a/generic/tclIO.c b/generic/tclIO.c index fed469c..2e0cd1f 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -9820,12 +9820,20 @@ CopyData( Tcl_SetErrno(inStatePtr->unreportedError); inStatePtr->unreportedError = 0; goto readError; + } else if (inStatePtr->flags & CHANNEL_ENCODING_ERROR) { + Tcl_SetErrno(EILSEQ); + inStatePtr->flags &= ~CHANNEL_ENCODING_ERROR; + goto readError; } Tcl_GetChannelError(outChan, &msg); if ((outStatePtr->unreportedError != 0) || (msg != NULL)) { Tcl_SetErrno(outStatePtr->unreportedError); outStatePtr->unreportedError = 0; goto writeError; + } else if (outStatePtr->flags & CHANNEL_ENCODING_ERROR) { + Tcl_SetErrno(EILSEQ); + outStatePtr->flags &= ~CHANNEL_ENCODING_ERROR; + goto writeError; } if (cmdPtr && (mask == 0)) { diff --git a/tests/io.test b/tests/io.test index 2708906..7b8182e 100644 --- a/tests/io.test +++ b/tests/io.test @@ -7609,6 +7609,103 @@ test io-52.19 {coverage of eofChar handling} { close $out file size $path(test2) } 8 +test io-52.20 {TclCopyChannel & encodings} -setup { + set out [open $path(utf8-fcopy.txt) w] + fconfigure $out -encoding utf-8 -translation lf + puts $out "Á" + close $out +} -constraints {fcopy} -body { + # binary to encoding => the input has to be + # in utf-8 to make sense to the encoder + + set in [open $path(utf8-fcopy.txt) r] + set out [open $path(kyrillic.txt) w] + + # Using "-encoding ascii" means reading the "Á" gives an error + fconfigure $in -encoding ascii -strictencoding 1 + fconfigure $out -encoding koi8-r -translation lf + + fcopy $in $out +} -cleanup { + close $in + close $out +} -returnCodes 1 -match glob -result {error reading "file*": illegal byte sequence} +test io-52.21 {TclCopyChannel & encodings} -setup { + set out [open $path(utf8-fcopy.txt) w] + fconfigure $out -encoding utf-8 -translation lf + puts $out "Á" + close $out +} -constraints {fcopy} -body { + # binary to encoding => the input has to be + # in utf-8 to make sense to the encoder + + set in [open $path(utf8-fcopy.txt) r] + set out [open $path(kyrillic.txt) w] + + # Using "-encoding ascii" means writing the "Á" gives an error + fconfigure $in -encoding utf-8 + fconfigure $out -encoding ascii -translation lf -strictencoding 1 + + fcopy $in $out +} -cleanup { + close $in + close $out +} -returnCodes 1 -match glob -result {error writing "file*": illegal byte sequence} +test io-52.22 {TclCopyChannel & encodings} -setup { + set out [open $path(utf8-fcopy.txt) w] + fconfigure $out -encoding utf-8 -translation lf + puts $out "Á" + close $out +} -constraints {fcopy} -body { + # binary to encoding => the input has to be + # in utf-8 to make sense to the encoder + + set in [open $path(utf8-fcopy.txt) r] + set out [open $path(kyrillic.txt) w] + + # Using "-encoding ascii" means reading the "Á" gives an error + fconfigure $in -encoding ascii -strictencoding 1 + fconfigure $out -encoding koi8-r -translation lf + proc ::xxx args { + set ::s0 $args + } + + fcopy $in $out -command ::xxx + vwait ::s0 + set ::s0 +} -cleanup { + close $in + close $out + unset ::s0 +} -match glob -result {0 {error reading "file*": illegal byte sequence}} +test io-52.23 {TclCopyChannel & encodings} -setup { + set out [open $path(utf8-fcopy.txt) w] + fconfigure $out -encoding utf-8 -translation lf + puts $out "Á" + close $out +} -constraints {fcopy} -body { + # binary to encoding => the input has to be + # in utf-8 to make sense to the encoder + + set in [open $path(utf8-fcopy.txt) r] + set out [open $path(kyrillic.txt) w] + + # Using "-encoding ascii" means writing the "Á" gives an error + fconfigure $in -encoding utf-8 + fconfigure $out -encoding ascii -translation lf -strictencoding 1 + proc ::xxx args { + set ::s0 $args + } + + fcopy $in $out -command ::xxx + vwait ::s0 + set ::s0 +} -cleanup { + close $in + close $out + unset ::s0 +} -match glob -result {0 {error writing "file*": illegal byte sequence}} + test io-53.1 {CopyData} {fcopy} { file delete $path(test1) -- cgit v0.12 From c2f0e2f8da529b6bd9f8793a07e73ed1bb6eb903 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 11 Feb 2023 01:51:32 +0000 Subject: Eliminate TCL_ENCODING_{STRICT,NOCOMPLAIN} --- generic/tcl.h | 12 ++---------- generic/tclEncoding.c | 37 ++++++++----------------------------- generic/tclIO.h | 6 ------ 3 files changed, 10 insertions(+), 45 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index ec94e71..b7d31aa 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2127,14 +2127,8 @@ typedef struct Tcl_EncodingType { * 0x00. Only valid for "utf-8" and "cesu-8". * This flag is implicit for external -> internal conversions, * optional for internal -> external conversions. - * TCL_ENCODING_NOCOMPLAIN - If set, the converter - * substitutes the problematic character(s) with - * one or more "close" characters in the - * destination buffer and then continues to - * convert the source. If clear, the converter returns - * immediately upon encountering an invalid byte sequence - * or a source character that has no mapping in the - * target encoding. Only for Tcl 9.x. + * TCL_ENCODING_PROFILE_* - Mutually exclusive encoding profile ids. Note + * these are bit masks. */ #define TCL_ENCODING_START 0x01 @@ -2143,8 +2137,6 @@ typedef struct Tcl_EncodingType { #define TCL_ENCODING_NO_TERMINATE 0x08 #define TCL_ENCODING_CHAR_LIMIT 0x10 #define TCL_ENCODING_MODIFIED 0x20 -#define TCL_ENCODING_NOCOMPLAIN 0x40 -#define TCL_ENCODING_STRICT 0x44 /* Reserve top byte for profile values (disjoint) */ #define TCL_ENCODING_PROFILE_TCL8 0x01000000 #define TCL_ENCODING_PROFILE_STRICT 0x02000000 diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 153f8d3..85c2b6a 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -574,7 +574,7 @@ TclInitEncodingSubsystem(void) type.nullSize = 1; type.clientData = INT2PTR(TCL_ENCODING_UTF); Tcl_CreateEncoding(&type); - type.clientData = INT2PTR(TCL_ENCODING_NOCOMPLAIN); + type.clientData = INT2PTR(0); type.encodingName = "cesu-8"; Tcl_CreateEncoding(&type); @@ -583,13 +583,13 @@ TclInitEncodingSubsystem(void) type.freeProc = NULL; type.nullSize = 2; type.encodingName = "ucs-2le"; - type.clientData = INT2PTR(TCL_ENCODING_LE|TCL_ENCODING_NOCOMPLAIN); + type.clientData = INT2PTR(TCL_ENCODING_LE); Tcl_CreateEncoding(&type); type.encodingName = "ucs-2be"; - type.clientData = INT2PTR(TCL_ENCODING_NOCOMPLAIN); + type.clientData = INT2PTR(0); Tcl_CreateEncoding(&type); type.encodingName = "ucs-2"; - type.clientData = INT2PTR(isLe.c|TCL_ENCODING_NOCOMPLAIN); + type.clientData = INT2PTR(isLe.c); Tcl_CreateEncoding(&type); type.toUtfProc = Utf32ToUtfProc; @@ -2324,16 +2324,11 @@ BinaryProc( *------------------------------------------------------------------------- */ -#ifdef OBSOLETE -#if TCL_MAJOR_VERSION > 8 || defined(TCL_NO_DEPRECATED) -# define STOPONERROR (!(flags & TCL_ENCODING_NOCOMPLAIN) || (flags & TCL_ENCODING_STOPONERROR)) -#else -# define STOPONERROR (flags & TCL_ENCODING_STOPONERROR) -#endif -#endif - +#define STRICT_PROFILE(flags_) \ + ((TCL_ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_STRICT) \ + || (TCL_ENCODING_PROFILE_GET(flags_) == 0 \ + && TCL_ENCODING_PROFILE_DEFAULT == TCL_ENCODING_PROFILE_STRICT)) -#define STRICT_PROFILE(flags_) (TCL_ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_STRICT) #define STOPONERROR STRICT_PROFILE(flags) static int @@ -4196,10 +4191,6 @@ TclEncodingProfileIdToName( * * Maps the flags supported in the encoding C API's to internal flags. * - * TCL_ENCODING_STRICT and TCL_ENCODING_NOCOMPLAIN are masked off - * because they are for internal use only and externally specified - * through TCL_ENCODING_PROFILE_* bits. - * * For backward compatibility reasons, TCL_ENCODING_STOPONERROR is * is mapped to the TCL_ENCODING_PROFILE_STRICT overwriting any profile * specified. @@ -4217,7 +4208,6 @@ TclEncodingProfileIdToName( */ int TclEncodingExternalFlagsToInternal(int flags) { - flags &= ~(TCL_ENCODING_STRICT | TCL_ENCODING_NOCOMPLAIN); if (flags & TCL_ENCODING_STOPONERROR) { TCL_ENCODING_PROFILE_SET(flags, TCL_ENCODING_PROFILE_STRICT); } @@ -4225,22 +4215,11 @@ int TclEncodingExternalFlagsToInternal(int flags) int profile = TCL_ENCODING_PROFILE_GET(flags); switch (profile) { case TCL_ENCODING_PROFILE_TCL8: - flags |= TCL_ENCODING_NOCOMPLAIN; - break; case TCL_ENCODING_PROFILE_STRICT: - flags |= TCL_ENCODING_STRICT; break; case 0: /* Unspecified by caller */ default: - /* TODO - clean this up once default mechanisms settled */ TCL_ENCODING_PROFILE_SET(flags, TCL_ENCODING_PROFILE_DEFAULT); -#if TCL_ENCODING_PROFILE_DEFAULT == TCL_ENCODING_PROFILE_TCL8 - flags |= TCL_ENCODING_NOCOMPLAIN; -#elif TCL_ENCODING_PROFILE_DEFAULT == TCL_ENCODING_PROFILE_STRICT - flags |= TCL_ENCODING_STRICT; -#else -#error TCL_ENCODING_PROFILE_DEFAULT must be TCL8 or STRICT -#endif break; } } diff --git a/generic/tclIO.h b/generic/tclIO.h index 3f2feee..dded07f 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -275,12 +275,6 @@ typedef struct ChannelState { * encountered an encoding error */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ -#ifdef APN -#define CHANNEL_ENCODING_NOCOMPLAIN (1<<17) /* set if option - * -nocomplainencoding is set to 1 */ -#define CHANNEL_ENCODING_STRICT (1<<18) /* set if option - * -strictencoding is set to 1 */ -#endif #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being closed. * Its structures are still live and * usable, but it may not be closed -- cgit v0.12 From 727887b6dc02960e49117cb5db99e44806a0327f Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 11 Feb 2023 17:38:07 +0000 Subject: Partial implementation of replace profile --- generic/tcl.h | 7 +-- generic/tclEncoding.c | 119 +++++++++++++++++++++++++++++++++++++++----------- tests/cmdAH.test | 3 ++ 3 files changed, 99 insertions(+), 30 deletions(-) diff --git a/generic/tcl.h b/generic/tcl.h index b7d31aa..3fc53db 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -2140,6 +2140,7 @@ typedef struct Tcl_EncodingType { /* Reserve top byte for profile values (disjoint) */ #define TCL_ENCODING_PROFILE_TCL8 0x01000000 #define TCL_ENCODING_PROFILE_STRICT 0x02000000 +#define TCL_ENCODING_PROFILE_REPLACE 0x03000000 #define TCL_ENCODING_PROFILE_MASK 0xFF000000 #define TCL_ENCODING_PROFILE_GET(flags_) ((flags_) & TCL_ENCODING_PROFILE_MASK) #define TCL_ENCODING_PROFILE_SET(flags_, profile_) \ @@ -2151,13 +2152,9 @@ typedef struct Tcl_EncodingType { #if TCL_MAJOR_VERSION < 9 #define TCL_ENCODING_PROFILE_DEFAULT TCL_ENCODING_PROFILE_TCL8 #else -#define TCL_ENCODING_PROFILE_DEFAULT TCL_ENCODING_PROFILE_TCL8 /* STRICT? TODO */ +#define TCL_ENCODING_PROFILE_DEFAULT TCL_ENCODING_PROFILE_TCL8 /* STRICT? REPLACE? TODO */ #endif -#define TCL_ENCODING_EXTERNAL_FLAG_MASK \ - (TCL_ENCODING_START|TCL_ENCODING_END|TCL_ENCODING_STOPONERROR) - - /* * The following definitions are the error codes returned by the conversion * routines: diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 85c2b6a..bb1f32f 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -193,8 +193,12 @@ Tcl_Encoding tclIdentityEncoding = NULL; static struct TclEncodingProfiles { const char *name; int value; -} encodingProfiles[] = {{"tcl8", TCL_ENCODING_PROFILE_TCL8}, - {"strict", TCL_ENCODING_PROFILE_STRICT}}; +} encodingProfiles[] = { + {"tcl8", TCL_ENCODING_PROFILE_TCL8}, + {"strict", TCL_ENCODING_PROFILE_STRICT}, + {"replace", TCL_ENCODING_PROFILE_REPLACE}, +}; +#define UNICODE_REPLACE_CHAR 0xFFFD /* * The following variable is used in the sparse matrix code for a @@ -2336,7 +2340,7 @@ UtfToUtfProc( void *clientData, /* additional flags, e.g. TCL_ENCODING_MODIFIED */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ - int flags, /* Conversion control flags. */ + int flags, /* TCL_ENCODING_* conversion control flags. */ TCL_UNUSED(Tcl_EncodingState *), char *dst, /* Output buffer in which converted string is * stored. */ @@ -2376,6 +2380,8 @@ UtfToUtfProc( dstEnd = dst + dstLen - ((flags & TCL_ENCODING_UTF) ? TCL_UTF_MAX : 6); for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { + int profile = TCL_ENCODING_PROFILE_GET(flags); + if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { /* * If there is more string to follow, this will ensure that the @@ -2389,34 +2395,51 @@ UtfToUtfProc( result = TCL_CONVERT_NOSPACE; break; } - if (UCHAR(*src) < 0x80 && !((UCHAR(*src) == 0) && (flags & TCL_ENCODING_MODIFIED))) { + /* + * TCL_ENCODING_MODIFIED is set when the target encoding is Tcl's + * internal UTF-8 modified version. + */ + if (UCHAR(*src) < 0x80 + && !((UCHAR(*src) == 0) && (flags & TCL_ENCODING_MODIFIED))) { /* - * Copy 7bit characters, but skip null-bytes when we are in input - * mode, so that they get converted to 0xC080. + * Copy 7bit characters, but skip null-bytes when target encoding + * is Tcl's "modified" UTF-8. These need to be converted to + * \xC0\x80 as is done in a later branch. */ *dst++ = *src++; - } else if ((UCHAR(*src) == 0xC0) && - (src + 1 < srcEnd) && - (UCHAR(src[1]) == 0x80) && - (!(flags & TCL_ENCODING_MODIFIED) - || (STRICT_PROFILE(flags)))) { + } + else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) + && (UCHAR(src[1]) == 0x80) + && (!(flags & TCL_ENCODING_MODIFIED) + || (profile == TCL_ENCODING_PROFILE_STRICT))) { /* - * If in input mode, and -strict or -failindex is specified: This is an error. + * \xC0\x80 and either strict profile or target is "real" UTF-8 + * - Strict profile - error + * - Non-strict, real UTF-8 - output \x00 */ if (flags & TCL_ENCODING_MODIFIED) { + /* + * TODO - should above check not be against STRICT? + * That would probably break a convertto command that goes + * from the internal UTF8 to the real UTF8. On the other + * hand this means, a strict UTF8->UTF8 transform is not + * possible using this function. + */ result = TCL_CONVERT_SYNTAX; break; } /* - * Convert 0xC080 to real nulls when we are in output mode, with or without '-strict'. + * Convert 0xC080 to real nulls when we are in output mode, + * irrespective of the profile. */ *dst++ = 0; src += 2; } else if (!Tcl_UtfCharComplete(src, srcEnd - src)) { /* + * Incomplete byte sequence. * Always check before using TclUtfToUCS4. Not doing can so * cause it run beyond the end of the buffer! If we happen such an * incomplete char its bytes are made to represent themselves @@ -2424,17 +2447,39 @@ UtfToUtfProc( */ if (flags & TCL_ENCODING_MODIFIED) { - if ((STOPONERROR) && (flags & TCL_ENCODING_CHAR_LIMIT)) { - result = TCL_CONVERT_MULTIBYTE; + /* Incomplete bytes for modified UTF-8 target */ + if (profile == TCL_ENCODING_PROFILE_STRICT) { + result = (flags & TCL_ENCODING_CHAR_LIMIT) + ? TCL_CONVERT_MULTIBYTE + : TCL_CONVERT_SYNTAX; break; } - if (STRICT_PROFILE(flags)) { - result = TCL_CONVERT_SYNTAX; - break; + if (profile == TCL_ENCODING_PROFILE_REPLACE) { + ch = UNICODE_REPLACE_CHAR; + } else { + /* TCL_ENCODING_PROFILE_TCL8 */ + ch = UCHAR(*src); } - ch = UCHAR(*src++); - } else { + ++src; + } + else { + /* + * Incomplete bytes for real UTF-8 target. + * TODO - no profile check here because did not have any + * checks in the pre-profile code. Why? Is it because on + * output a valid internal utf-8 stream is assumed? + */ char chbuf[2]; + /* + * TODO - this code seems broken to me. + * - it does not check profiles + * - generates invalid output for real UTF-8 target + * (consider \xC2) + * A possible explanation is this behavior matches the + * Tcl8 decoding behavior of mapping invalid bytes to the same + * code point value. Still, at least strictness checks should + * be made. + */ chbuf[0] = UCHAR(*src++); chbuf[1] = 0; TclUtfToUCS4(chbuf, &ch); } @@ -2444,11 +2489,31 @@ UtfToUtfProc( int low; const char *saveSrc = src; size_t len = TclUtfToUCS4(src, &ch); + + /* + * Valid single char encodings were already handled earlier. + * So len==1 means an invalid byte that is magically transformed + * to a code point unless it resulted from the special + * \xC0\x80 sequence. Tests io-75.* + * TODO - below check could be simplified to remove the MODIFIED + * expression I think given the checks already made above. May be. + */ +#if 0 if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_MODIFIED) - && STRICT_PROFILE(flags)) { + && (profile == TCL_ENCODING_PROFILE_STRICT)) { result = TCL_CONVERT_SYNTAX; break; } +#else + if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_MODIFIED)) { + if (profile == TCL_ENCODING_PROFILE_STRICT) { + result = TCL_CONVERT_SYNTAX; + break; + } else if (profile == TCL_ENCODING_PROFILE_REPLACE) { + ch = UNICODE_REPLACE_CHAR; + } + } +#endif src += len; if (!(flags & TCL_ENCODING_UTF) && (ch > 0x3FF)) { if (ch > 0xFFFF) { @@ -2464,13 +2529,14 @@ UtfToUtfProc( /* * A surrogate character is detected, handle especially. */ + /* TODO - what about REPLACE profile? */ low = ch; len = (src <= srcEnd-3) ? TclUtfToUCS4(src, &low) : 0; if (((low & ~0x3FF) != 0xDC00) || (ch & 0x400)) { - if (STOPONERROR) { + if (profile == TCL_ENCODING_PROFILE_STRICT) { result = TCL_CONVERT_UNKNOWN; src = saveSrc; break; @@ -2484,12 +2550,14 @@ UtfToUtfProc( src += len; dst += Tcl_UniCharToUtf(ch, dst); ch = low; - } else if (STOPONERROR && !(flags & TCL_ENCODING_MODIFIED) && (((ch & ~0x7FF) == 0xD800))) { + } else if ((profile == TCL_ENCODING_PROFILE_STRICT) && + !(flags & TCL_ENCODING_MODIFIED) && + (((ch & ~0x7FF) == 0xD800))) { result = TCL_CONVERT_UNKNOWN; src = saveSrc; break; - } else if (STRICT_PROFILE(flags) && - (flags & TCL_ENCODING_MODIFIED) && + } else if ((profile == TCL_ENCODING_PROFILE_STRICT) && + (flags & TCL_ENCODING_MODIFIED) && ((ch & ~0x7FF) == 0xD800)) { result = TCL_CONVERT_SYNTAX; src = saveSrc; @@ -4216,6 +4284,7 @@ int TclEncodingExternalFlagsToInternal(int flags) switch (profile) { case TCL_ENCODING_PROFILE_TCL8: case TCL_ENCODING_PROFILE_STRICT: + case TCL_ENCODING_PROFILE_REPLACE: break; case 0: /* Unspecified by caller */ default: diff --git a/tests/cmdAH.test b/tests/cmdAH.test index c4053a2..52e7ac3 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -228,6 +228,9 @@ set encInvalidBytes { utf-8 A\xed\xb0\x80B default A\uDC00B -1 Low-surrogate utf-8 A\xed\xb0\x80B tcl8 A\uDC00B -1 Low-surrogate utf-8 A\xed\xb0\x80B strict A 1 Low-surrogate + utf-8 \xed\xa0\x80\xed\xb0\x80 default \U00010000 -1 High-low-surrogate + utf-8 \xed\xa0\x80\xed\xb0\x80 tcl8 \U00010000 -1 High-low-surrogate + utf-8 \xed\xa0\x80\xed\xb0\x80 strict \U00010000 0 High-low-surrogate utf-32le \x00\xD8\x00\x00 default \uD800 -1 {High-surrogate} utf-32le \x00\xD8\x00\x00 tcl8 \uD800 -1 {High-surrogate} -- cgit v0.12 From b5095134dfebce7a33739c75d6533d90862901e3 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 12 Feb 2023 06:15:59 +0000 Subject: Minor readability changes --- generic/tclEncoding.c | 101 ++++++++++++++++++++++++++++++++------------------ tests/cmdAH.test | 2 +- 2 files changed, 65 insertions(+), 38 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index bb1f32f..d2f3551 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -198,7 +198,20 @@ static struct TclEncodingProfiles { {"strict", TCL_ENCODING_PROFILE_STRICT}, {"replace", TCL_ENCODING_PROFILE_REPLACE}, }; +#define PROFILE_STRICT(flags_) \ + ((TCL_ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_STRICT) \ + || (TCL_ENCODING_PROFILE_GET(flags_) == 0 \ + && TCL_ENCODING_PROFILE_DEFAULT == TCL_ENCODING_PROFILE_STRICT)) + +#define PROFILE_REPLACE(flags_) \ + ((TCL_ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_REPLACE) \ + || (TCL_ENCODING_PROFILE_GET(flags_) == 0 \ + && TCL_ENCODING_PROFILE_DEFAULT == TCL_ENCODING_PROFILE_REPLACE)) + #define UNICODE_REPLACE_CHAR 0xFFFD +#define SURROGATE(c_) (((c_) & ~0x7FF) == 0xD800) +#define HIGH_SURROGATE(c_) (((c_) & ~0x3FF) == 0xD800) +#define LOW_SURROGATE(c_) (((c_) & ~0x3FF) == 0xDC00) /* * The following variable is used in the sparse matrix code for a @@ -243,6 +256,7 @@ static Tcl_EncodingConvertProc UtfToUtfProc; static Tcl_EncodingConvertProc Iso88591FromUtfProc; static Tcl_EncodingConvertProc Iso88591ToUtfProc; + /* * A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1 field * of the internalrep. This should help the lifetime of encodings be more useful. @@ -2328,13 +2342,6 @@ BinaryProc( *------------------------------------------------------------------------- */ -#define STRICT_PROFILE(flags_) \ - ((TCL_ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_STRICT) \ - || (TCL_ENCODING_PROFILE_GET(flags_) == 0 \ - && TCL_ENCODING_PROFILE_DEFAULT == TCL_ENCODING_PROFILE_STRICT)) - -#define STOPONERROR STRICT_PROFILE(flags) - static int UtfToUtfProc( void *clientData, /* additional flags, e.g. TCL_ENCODING_MODIFIED */ @@ -2412,7 +2419,7 @@ UtfToUtfProc( else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) && (UCHAR(src[1]) == 0x80) && (!(flags & TCL_ENCODING_MODIFIED) - || (profile == TCL_ENCODING_PROFILE_STRICT))) { + || PROFILE_STRICT(profile))) { /* * \xC0\x80 and either strict profile or target is "real" UTF-8 * - Strict profile - error @@ -2448,13 +2455,13 @@ UtfToUtfProc( if (flags & TCL_ENCODING_MODIFIED) { /* Incomplete bytes for modified UTF-8 target */ - if (profile == TCL_ENCODING_PROFILE_STRICT) { + if (PROFILE_STRICT(profile)) { result = (flags & TCL_ENCODING_CHAR_LIMIT) ? TCL_CONVERT_MULTIBYTE : TCL_CONVERT_SYNTAX; break; } - if (profile == TCL_ENCODING_PROFILE_REPLACE) { + if (PROFILE_REPLACE(profile)) { ch = UNICODE_REPLACE_CHAR; } else { /* TCL_ENCODING_PROFILE_TCL8 */ @@ -2506,10 +2513,10 @@ UtfToUtfProc( } #else if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_MODIFIED)) { - if (profile == TCL_ENCODING_PROFILE_STRICT) { + if (PROFILE_STRICT(profile)) { result = TCL_CONVERT_SYNTAX; break; - } else if (profile == TCL_ENCODING_PROFILE_REPLACE) { + } else if (PROFILE_REPLACE(profile)) { ch = UNICODE_REPLACE_CHAR; } } @@ -2534,9 +2541,9 @@ UtfToUtfProc( low = ch; len = (src <= srcEnd-3) ? TclUtfToUCS4(src, &low) : 0; - if (((low & ~0x3FF) != 0xDC00) || (ch & 0x400)) { + if ((!LOW_SURROGATE(low)) || (ch & 0x400)) { - if (profile == TCL_ENCODING_PROFILE_STRICT) { + if (PROFILE_STRICT(profile)) { result = TCL_CONVERT_UNKNOWN; src = saveSrc; break; @@ -2550,15 +2557,15 @@ UtfToUtfProc( src += len; dst += Tcl_UniCharToUtf(ch, dst); ch = low; - } else if ((profile == TCL_ENCODING_PROFILE_STRICT) && - !(flags & TCL_ENCODING_MODIFIED) && - (((ch & ~0x7FF) == 0xD800))) { + } else if (PROFILE_STRICT(profile) && + (!(flags & TCL_ENCODING_MODIFIED)) && + SURROGATE(ch)) { result = TCL_CONVERT_UNKNOWN; src = saveSrc; break; - } else if ((profile == TCL_ENCODING_PROFILE_STRICT) && + } else if (PROFILE_STRICT(profile) && (flags & TCL_ENCODING_MODIFIED) && - ((ch & ~0x7FF) == 0xD800)) { + SURROGATE(ch)) { result = TCL_CONVERT_SYNTAX; src = saveSrc; break; @@ -2649,12 +2656,15 @@ Utf32ToUtfProc( } else { ch = (src[0] & 0xFF) << 24 | (src[1] & 0xFF) << 16 | (src[2] & 0xFF) << 8 | (src[3] & 0xFF); } - if ((unsigned)ch > 0x10FFFF - || (STRICT_PROFILE(flags) && ((ch & ~0x7FF) == 0xD800))) { - if (STOPONERROR) { + + if ((unsigned)ch > 0x10FFFF || SURROGATE(ch)) { + if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; break; } + if (PROFILE_REPLACE(flags)) { + ch = UNICODE_REPLACE_CHAR; + } } /* @@ -2666,7 +2676,7 @@ Utf32ToUtfProc( *dst++ = (ch & 0xFF); } else { dst += Tcl_UniCharToUtf(ch, dst); - if ((ch & ~0x3FF) == 0xD800) { + if (HIGH_SURROGATE(ch)) { /* Bug [10c2c17c32]. If Hi surrogate, finish 3-byte UTF-8 */ dst += Tcl_UniCharToUtf(-1, dst); } @@ -2750,11 +2760,14 @@ UtfToUtf32Proc( break; } len = TclUtfToUCS4(src, &ch); - if ((ch & ~0x7FF) == 0xD800) { - if (STOPONERROR) { + if (SURROGATE(ch)) { + if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_UNKNOWN; break; } + if (PROFILE_REPLACE(flags)) { + ch = UNICODE_REPLACE_CHAR; + } } src += len; if (flags & TCL_ENCODING_LE) { @@ -2952,11 +2965,14 @@ UtfToUtf16Proc( break; } len = TclUtfToUCS4(src, &ch); - if ((ch & ~0x7FF) == 0xD800) { - if (STOPONERROR) { + if (SURROGATE(ch)) { + if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_UNKNOWN; break; } + if (PROFILE_REPLACE(flags)) { + ch = UNICODE_REPLACE_CHAR; + } } src += len; if (flags & TCL_ENCODING_LE) { @@ -3059,6 +3075,9 @@ UtfToUcs2Proc( result = TCL_CONVERT_NOSPACE; break; } + /* TODO - there were no STRICT or NOCOMPLAIN checks here (why?) + * so no profile checks either for now. */ + #if TCL_UTF_MAX < 4 src += (len = TclUtfToUniChar(src, &ch)); if ((ch >= 0xD800) && (len < 3)) { @@ -3163,23 +3182,30 @@ TableToUtfProc( if (prefixBytes[byte]) { src++; if (src >= srcEnd) { + /* + * TODO - this is broken. For consistency with other + * decoders, an error should be raised only if strict. + * However, doing that check cause a whole bunch of test + * failures. Need to verify if those tests are in fact + * correct. + */ src--; result = TCL_CONVERT_MULTIBYTE; break; } - ch = toUnicode[byte][*((unsigned char *) src)]; + ch = toUnicode[byte][*((unsigned char *)src)]; } else { ch = pageZero[byte]; } if ((ch == 0) && (byte != 0)) { - if (STOPONERROR) { + if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; break; } if (prefixBytes[byte]) { src--; } - ch = (Tcl_UniChar) byte; + ch = (Tcl_UniChar)byte; } /* @@ -3288,11 +3314,11 @@ TableFromUtfProc( word = fromUnicode[(ch >> 8)][ch & 0xFF]; if ((word == 0) && (ch != 0)) { - if (STOPONERROR) { + if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_UNKNOWN; break; } - word = dataPtr->fallback; + word = dataPtr->fallback; /* Both profiles REPLACE and TCL8 */ } if (prefixBytes[(word >> 8)] != 0) { if (dst + 1 > dstEnd) { @@ -3476,7 +3502,7 @@ Iso88591FromUtfProc( || ((ch >= 0xD800) && (len < 3)) #endif ) { - if (STOPONERROR) { + if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_UNKNOWN; break; } @@ -3489,7 +3515,7 @@ Iso88591FromUtfProc( * Plunge on, using '?' as a fallback character. */ - ch = (Tcl_UniChar) '?'; + ch = (Tcl_UniChar) '?'; /* Profiles TCL8 and REPLACE */ } if (dst > dstEnd) { @@ -3703,9 +3729,10 @@ EscapeToUtfProc( if ((checked == dataPtr->numSubTables + 2) || (flags & TCL_ENCODING_END)) { - if (!STOPONERROR) { + if (!PROFILE_STRICT(flags)) { /* - * Skip the unknown escape sequence. + * Skip the unknown escape sequence. TODO - bug? + * May be replace with UNICODE_REPLACE_CHAR? */ src += longest; @@ -3878,7 +3905,7 @@ EscapeFromUtfProc( if (word == 0) { state = oldState; - if (STOPONERROR) { + if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_UNKNOWN; break; } diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 52e7ac3..7b2d99f 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -179,7 +179,7 @@ set "numargErrors(encoding convertfrom)" {^wrong # args: should be "(encoding |: set "numargErrors(encoding convertto)" {^wrong # args: should be "(encoding |::tcl::encoding::)convertto \?\?-profile profile\? \?-failindex var\? \?encoding\?\? data"$} set "numargErrors(encoding names)" {wrong # args: should be "encoding names"} -set encProfiles {tcl8 strict} +set encProfiles {tcl8 strict replace} # TODO - valid sequences for different encodings - shiftjis etc. # Note utf-16, utf-32 missing because they are automatically -- cgit v0.12 From bf448a6421c4fd0340d6bba70aba3b0a713d049b Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 12 Feb 2023 11:04:16 +0000 Subject: Added 'encoding profiles' --- generic/tclEncoding.c | 31 ++++++++++++++++++++++++++++++- tests/cmdAH.test | 9 +++++++++ 2 files changed, 39 insertions(+), 1 deletion(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index d2f3551..e8e1756 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -4278,7 +4278,7 @@ TclEncodingProfileIdToName( } return NULL; } - + /* *------------------------------------------------------------------------ * @@ -4321,6 +4321,35 @@ int TclEncodingExternalFlagsToInternal(int flags) } return flags; } + +/* + *------------------------------------------------------------------------ + * + * TclGetEncodingProfiles -- + * + * Get the list of supported encoding profiles. + * + * Results: + * None. + * + * Side effects: + * The list of profile names is stored in the interpreter result. + * + *------------------------------------------------------------------------ + */ +void +TclGetEncodingProfiles(Tcl_Interp *interp) +{ + int i, n; + Tcl_Obj *objPtr; + n = sizeof(encodingProfiles) / sizeof(encodingProfiles[0]); + objPtr = Tcl_NewListObj(n, NULL); + for (i = 0; i < n; ++i) { + Tcl_ListObjAppendElement( + interp, objPtr, Tcl_NewStringObj(encodingProfiles[i].name, -1)); + } + Tcl_SetObjResult(interp, objPtr); +} /* * Local Variables: diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 7b2d99f..c666513 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -178,6 +178,7 @@ set "numargErrors(encoding system)" {^wrong # args: should be "(encoding |::tcl: set "numargErrors(encoding convertfrom)" {^wrong # args: should be "(encoding |::tcl::encoding::)convertfrom \?\?-profile profile\? \?-failindex var\? \?encoding\?\? data"$} set "numargErrors(encoding convertto)" {^wrong # args: should be "(encoding |::tcl::encoding::)convertto \?\?-profile profile\? \?-failindex var\? \?encoding\?\? data"$} set "numargErrors(encoding names)" {wrong # args: should be "encoding names"} +set "numargErrors(encoding profiles)" {wrong # args: should be "encoding profiles"} set encProfiles {tcl8 strict replace} @@ -202,6 +203,7 @@ set encValidStrings { set encInvalidBytes { ascii \x41\xe9\x42 default A\u00E9B -1 {non-ASCII} ascii \x41\xe9\x42 tcl8 A\u00E9B -1 {non-ASCII} + ascii \x41\xe9\x42 replace A\uFFFDB -1 {non-ASCII} ascii \x41\xe9\x42 strict A 1 {non-ASCII} utf-8 \x41\xC0\x42 default A\u00C0B -1 C0 @@ -565,6 +567,13 @@ test cmdAH-4.5.2 {encoding names should include at least utf-8 and iso8859-1 and } -result {1 1 1} # +# encoding profiles 4.6.* +badnumargs cmdAH-4.6.1 {encoding profiles} {foo} +test cmdAH-4.6.2 {encoding profiles} -body { + lsort [encoding profiles] +} -result {replace strict tcl8} + +# # file command test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { -- cgit v0.12 From 0c764d2b03ab2b8daf95b3a25a470b56dffdad4f Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 12 Feb 2023 16:56:17 +0000 Subject: Minor fixes and tests --- generic/tclCmdAH.c | 30 ++++++++++++++++++++++++++++++ generic/tclEncoding.c | 22 ++++++++++------------ generic/tclInt.h | 1 + tests/cmdAH.test | 7 ++++++- tests/socket.test | 2 +- 5 files changed, 48 insertions(+), 14 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 5fbe27e..692c75b 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -51,6 +51,7 @@ static Tcl_ObjCmdProc EncodingConvertfromObjCmd; static Tcl_ObjCmdProc EncodingConverttoObjCmd; static Tcl_ObjCmdProc EncodingDirsObjCmd; static Tcl_ObjCmdProc EncodingNamesObjCmd; +static Tcl_ObjCmdProc EncodingProfilesObjCmd; static Tcl_ObjCmdProc EncodingSystemObjCmd; static inline int ForeachAssignments(Tcl_Interp *interp, struct ForeachState *statePtr); @@ -519,6 +520,7 @@ TclInitEncodingCmd( {"convertto", EncodingConverttoObjCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, {"names", EncodingNamesObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"profiles", EncodingProfilesObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -891,6 +893,34 @@ EncodingNamesObjCmd( /* *----------------------------------------------------------------------------- * + * EncodingProfilesObjCmd -- + * + * This command returns a list of the available encoding profiles + * + * Results: + * Returns a standard Tcl result + * + *----------------------------------------------------------------------------- + */ + +int +EncodingProfilesObjCmd( + TCL_UNUSED(void *), + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Number of command line args */ + Tcl_Obj* const objv[]) /* Vector of command line args */ +{ + if (objc > 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + TclGetEncodingProfiles(interp); + return TCL_OK; +} + +/* + *----------------------------------------------------------------------------- + * * EncodingSystemObjCmd -- * * This command retrieves or changes the system encoding diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index e8e1756..fc3ac77 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -208,7 +208,7 @@ static struct TclEncodingProfiles { || (TCL_ENCODING_PROFILE_GET(flags_) == 0 \ && TCL_ENCODING_PROFILE_DEFAULT == TCL_ENCODING_PROFILE_REPLACE)) -#define UNICODE_REPLACE_CHAR 0xFFFD +#define UNICODE_REPLACE_CHAR ((Tcl_UniChar)0xFFFD) #define SURROGATE(c_) (((c_) & ~0x7FF) == 0xD800) #define HIGH_SURROGATE(c_) (((c_) & ~0x3FF) == 0xD800) #define LOW_SURROGATE(c_) (((c_) & ~0x3FF) == 0xDC00) @@ -547,6 +547,7 @@ FillEncodingFileMap(void) * TCL_ENCODING_LE is only used for utf-16/utf-32/ucs-2. re-use the same value */ #define TCL_ENCODING_LE TCL_ENCODING_MODIFIED /* Little-endian encoding */ #define TCL_ENCODING_UTF 0x200 /* For UTF-8 encoding, allow 4-byte output sequences */ +#define TCL_ENCODING_CESU8 0x400 /* TODO - Distinguishes cesu-8 from utf-8*/ void TclInitEncodingSubsystem(void) @@ -592,7 +593,7 @@ TclInitEncodingSubsystem(void) type.nullSize = 1; type.clientData = INT2PTR(TCL_ENCODING_UTF); Tcl_CreateEncoding(&type); - type.clientData = INT2PTR(0); + type.clientData = INT2PTR(TCL_ENCODING_CESU8); type.encodingName = "cesu-8"; Tcl_CreateEncoding(&type); @@ -2505,13 +2506,6 @@ UtfToUtfProc( * TODO - below check could be simplified to remove the MODIFIED * expression I think given the checks already made above. May be. */ -#if 0 - if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_MODIFIED) - && (profile == TCL_ENCODING_PROFILE_STRICT)) { - result = TCL_CONVERT_SYNTAX; - break; - } -#else if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_MODIFIED)) { if (PROFILE_STRICT(profile)) { result = TCL_CONVERT_SYNTAX; @@ -2520,7 +2514,7 @@ UtfToUtfProc( ch = UNICODE_REPLACE_CHAR; } } -#endif + src += len; if (!(flags & TCL_ENCODING_UTF) && (ch > 0x3FF)) { if (ch > 0xFFFF) { @@ -2551,7 +2545,7 @@ UtfToUtfProc( cesu8: *dst++ = (char) (((ch >> 12) | 0xE0) & 0xEF); *dst++ = (char) (((ch >> 6) | 0x80) & 0xBF); - *dst++ = (char) ((ch | 0x80) & 0xBF); + *dst++ = (char) ((ch | 0x80) & 0xBF); continue; } src += len; @@ -3205,7 +3199,11 @@ TableToUtfProc( if (prefixBytes[byte]) { src--; } - ch = (Tcl_UniChar)byte; + if (PROFILE_REPLACE(flags)) { + ch = UNICODE_REPLACE_CHAR; + } else { + ch = (Tcl_UniChar)byte; + } } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 4b6303d..538b177 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2891,6 +2891,7 @@ TclEncodingProfileNameToId(Tcl_Interp *interp, MODULE_SCOPE const char *TclEncodingProfileIdToName(Tcl_Interp *interp, int profileId); MODULE_SCOPE int TclEncodingExternalFlagsToInternal(int flags); +MODULE_SCOPE void TclGetEncodingProfiles(Tcl_Interp *interp); /* * TIP #233 (Virtualized Time) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index c666513..65ecac5 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -208,21 +208,26 @@ set encInvalidBytes { utf-8 \x41\xC0\x42 default A\u00C0B -1 C0 utf-8 \x41\xC0\x42 tcl8 A\u00C0B -1 C0 + utf-8 \x41\xC0\x42 replace A\uFFFDB -1 C0 utf-8 \x41\xC0\x42 strict A 1 C0 utf-8 \x41\x80\x42 default A\u0080B -1 80 utf-8 \x41\x80\x42 tcl8 A\u0080B -1 80 + utf-8 \x41\x80\x42 replace A\uFFFDB -1 80 utf-8 \x41\x80\x42 strict A 1 80 utf-8 \x41\xC0\x80\x42 default A\u0000B -1 C080 utf-8 \x41\xC0\x80\x42 tcl8 A\u0000B -1 C080 utf-8 \x41\xC0\x80\x42 strict A 1 C080 utf-8 \x41\xC1\x42 default A\u00C1B -1 C1 utf-8 \x41\xC1\x42 tcl8 A\u00C1B -1 C1 + utf-8 \x41\xC1\x42 replace A\uFFFDB -1 C1 utf-8 \x41\xC1\x42 strict A 1 C1 utf-8 \x41\xC2\x42 default A\u00C2B -1 C2-nontrail utf-8 \x41\xC2\x42 tcl8 A\u00C2B -1 C2-nontrail + utf-8 \x41\xC2\x42 replace A\uFFFDB -1 C2-nontrail utf-8 \x41\xC2\x42 strict A 1 C2-nontrail utf-8 \x41\xC2 default A\u00C2 -1 C2-incomplete utf-8 \x41\xC2 tcl8 A\u00C2 -1 C2-incomplete + utf-8 \x41\xC2 replace A\uFFFD -1 C2-incomplete utf-8 \x41\xC2 strict A 1 C2-incomplete utf-8 A\xed\xa0\x80B default A\uD800B -1 High-surrogate utf-8 A\xed\xa0\x80B tcl8 A\uD800B -1 High-surrogate @@ -335,7 +340,7 @@ test cmdAH-4.1.1 {encoding} -returnCodes error -body { } -result {wrong # args: should be "encoding subcommand ?arg ...?"} test cmdAH-4.1.2 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding foo -} -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} +} -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, profiles, or system} # # encoding system 4.2.* diff --git a/tests/socket.test b/tests/socket.test index a0fe2f7..b1435be 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -1071,7 +1071,7 @@ test socket_$af-7.3 {testing socket specific options} -constraints [list socket close $s update llength $l -} -result 22 +} -result 20 test socket_$af-7.4 {testing socket specific options} -constraints [list socket supported_$af] -setup { set timer [after 10000 "set x timed_out"] set l "" -- cgit v0.12 From 86d84d444cba1b00cf6b8771db83f21d9e6e5e13 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 12 Feb 2023 17:34:58 +0000 Subject: Tentative fix for [bd1a60eb9] - surrogates in strict utf-8 --- generic/tclEncoding.c | 11 +++++++++-- tests/cmdAH.test | 5 +++-- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index fc3ac77..5d099f9 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -547,7 +547,8 @@ FillEncodingFileMap(void) * TCL_ENCODING_LE is only used for utf-16/utf-32/ucs-2. re-use the same value */ #define TCL_ENCODING_LE TCL_ENCODING_MODIFIED /* Little-endian encoding */ #define TCL_ENCODING_UTF 0x200 /* For UTF-8 encoding, allow 4-byte output sequences */ -#define TCL_ENCODING_CESU8 0x400 /* TODO - Distinguishes cesu-8 from utf-8*/ +#define TCL_ENCODING_CESU8_SOURCE 0x400 /* TODO - Distinguishes cesu-8 + * *source* from utf-8 *source* */ void TclInitEncodingSubsystem(void) @@ -593,7 +594,7 @@ TclInitEncodingSubsystem(void) type.nullSize = 1; type.clientData = INT2PTR(TCL_ENCODING_UTF); Tcl_CreateEncoding(&type); - type.clientData = INT2PTR(TCL_ENCODING_CESU8); + type.clientData = INT2PTR(TCL_ENCODING_CESU8_SOURCE); type.encodingName = "cesu-8"; Tcl_CreateEncoding(&type); @@ -2370,6 +2371,7 @@ UtfToUtfProc( const char *dstStart, *dstEnd; int result, numChars, charLimit = INT_MAX; int ch; + int isCesu8; result = TCL_OK; @@ -2531,6 +2533,11 @@ UtfToUtfProc( * A surrogate character is detected, handle especially. */ /* TODO - what about REPLACE profile? */ + if (PROFILE_STRICT(profile) && !(flags & TCL_ENCODING_CESU8_SOURCE)) { + result = TCL_CONVERT_UNKNOWN; + src = saveSrc; + break; + } low = ch; len = (src <= srcEnd-3) ? TclUtfToUCS4(src, &low) : 0; diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 65ecac5..f2aab52 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -237,8 +237,9 @@ set encInvalidBytes { utf-8 A\xed\xb0\x80B strict A 1 Low-surrogate utf-8 \xed\xa0\x80\xed\xb0\x80 default \U00010000 -1 High-low-surrogate utf-8 \xed\xa0\x80\xed\xb0\x80 tcl8 \U00010000 -1 High-low-surrogate - utf-8 \xed\xa0\x80\xed\xb0\x80 strict \U00010000 0 High-low-surrogate - + utf-8 \xed\xa0\x80\xed\xb0\x80 strict {} 0 High-low-surrogate +} +set utf32-le-TODO { utf-32le \x00\xD8\x00\x00 default \uD800 -1 {High-surrogate} utf-32le \x00\xD8\x00\x00 tcl8 \uD800 -1 {High-surrogate} utf-32le \x00\xD8\x00\x00 strict "" 0 {High-surrogate} -- cgit v0.12 From 2974b5727951737a5b67789f4b7712cf72096ed0 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 14 Feb 2023 07:29:36 +0000 Subject: Make a start fixing [bd1a60eb9c]. WIP --- generic/tclEncoding.c | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 0941f14..01c4eb1 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -519,7 +519,8 @@ FillEncodingFileMap(void) /* Since TCL_ENCODING_MODIFIED is only used for utf-8/cesu-8 and * TCL_ENCODING_LE is only used for utf-16/utf-32/ucs-2. re-use the same value */ #define TCL_ENCODING_LE TCL_ENCODING_MODIFIED /* Little-endian encoding */ -#define TCL_ENCODING_UTF 0x200 /* For UTF-8 encoding, allow 4-byte output sequences */ +#define ENCODING_UTF 0x200 /* For UTF-8 encoding, allow 4-byte output sequences */ +#define ENCODING_INPUT 0x400 /* For UTF-8/CESU-8 encoding, means external -> internal */ void TclInitEncodingSubsystem(void) @@ -561,7 +562,7 @@ TclInitEncodingSubsystem(void) type.fromUtfProc = UtfToUtfProc; type.freeProc = NULL; type.nullSize = 1; - type.clientData = INT2PTR(TCL_ENCODING_UTF); + type.clientData = INT2PTR(ENCODING_UTF); Tcl_CreateEncoding(&type); type.clientData = INT2PTR(TCL_ENCODING_NOCOMPLAIN); type.encodingName = "cesu-8"; @@ -1238,7 +1239,7 @@ Tcl_ExternalToUtfDStringEx( flags |= TCL_ENCODING_START | TCL_ENCODING_END; if (encodingPtr->toUtfProc == UtfToUtfProc) { - flags |= TCL_ENCODING_MODIFIED | TCL_ENCODING_UTF; + flags |= ENCODING_INPUT; } while (1) { @@ -1355,7 +1356,7 @@ Tcl_ExternalToUtf( dstLen--; } if (encodingPtr->toUtfProc == UtfToUtfProc) { - flags |= TCL_ENCODING_MODIFIED | TCL_ENCODING_UTF; + flags |= ENCODING_INPUT; } do { Tcl_EncodingState savedState = *statePtr; @@ -1450,7 +1451,7 @@ Tcl_UtfToExternalDStringEx( const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes, or < 0 for * strlen(). */ - int flags, /* Conversion control flags. */ + int flags, /* Conversion control flags. */ Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { @@ -2363,7 +2364,7 @@ UtfToUtfProc( dstStart = dst; flags |= PTR2INT(clientData); - dstEnd = dst + dstLen - ((flags & TCL_ENCODING_UTF) ? TCL_UTF_MAX : 6); + dstEnd = dst + dstLen - ((flags & ENCODING_UTF) ? TCL_UTF_MAX : 6); for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { @@ -2435,7 +2436,7 @@ UtfToUtfProc( break; } src += len; - if (!(flags & TCL_ENCODING_UTF) && (ch > 0x3FF)) { + if (!(flags & ENCODING_UTF) && (ch > 0x3FF)) { if (ch > 0xFFFF) { /* CESU-8 6-byte sequence for chars > U+FFFF */ ch -= 0x10000; -- cgit v0.12 From 85320f8fd074a2a55f76a7c0a8290f0a195530dc Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 14 Feb 2023 11:37:35 +0000 Subject: Bug [bd1a60eb9c]. Eliminate TCL_ENCODING_UTF. --- generic/tclEncoding.c | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 5d099f9..778fca8 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -546,7 +546,6 @@ FillEncodingFileMap(void) /* Since TCL_ENCODING_MODIFIED is only used for utf-8/cesu-8 and * TCL_ENCODING_LE is only used for utf-16/utf-32/ucs-2. re-use the same value */ #define TCL_ENCODING_LE TCL_ENCODING_MODIFIED /* Little-endian encoding */ -#define TCL_ENCODING_UTF 0x200 /* For UTF-8 encoding, allow 4-byte output sequences */ #define TCL_ENCODING_CESU8_SOURCE 0x400 /* TODO - Distinguishes cesu-8 * *source* from utf-8 *source* */ @@ -592,7 +591,7 @@ TclInitEncodingSubsystem(void) type.fromUtfProc = UtfToUtfProc; type.freeProc = NULL; type.nullSize = 1; - type.clientData = INT2PTR(TCL_ENCODING_UTF); + type.clientData = INT2PTR(0); Tcl_CreateEncoding(&type); type.clientData = INT2PTR(TCL_ENCODING_CESU8_SOURCE); type.encodingName = "cesu-8"; @@ -1269,7 +1268,7 @@ Tcl_ExternalToUtfDStringEx( flags = TclEncodingExternalFlagsToInternal(flags); flags |= TCL_ENCODING_START | TCL_ENCODING_END; if (encodingPtr->toUtfProc == UtfToUtfProc) { - flags |= TCL_ENCODING_MODIFIED | TCL_ENCODING_UTF; + flags |= TCL_ENCODING_MODIFIED; } while (1) { @@ -1386,7 +1385,7 @@ Tcl_ExternalToUtf( dstLen--; } if (encodingPtr->toUtfProc == UtfToUtfProc) { - flags |= TCL_ENCODING_MODIFIED | TCL_ENCODING_UTF; + flags |= TCL_ENCODING_MODIFIED; } do { Tcl_EncodingState savedState = *statePtr; @@ -2371,7 +2370,6 @@ UtfToUtfProc( const char *dstStart, *dstEnd; int result, numChars, charLimit = INT_MAX; int ch; - int isCesu8; result = TCL_OK; @@ -2387,7 +2385,7 @@ UtfToUtfProc( dstStart = dst; flags |= PTR2INT(clientData); - dstEnd = dst + dstLen - ((flags & TCL_ENCODING_UTF) ? TCL_UTF_MAX : 6); + dstEnd = dst + dstLen - ((flags & TCL_ENCODING_CESU8_SOURCE) ? 6 : TCL_UTF_MAX); for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { int profile = TCL_ENCODING_PROFILE_GET(flags); @@ -2518,7 +2516,7 @@ UtfToUtfProc( } src += len; - if (!(flags & TCL_ENCODING_UTF) && (ch > 0x3FF)) { + if ((flags & TCL_ENCODING_CESU8_SOURCE) && (ch > 0x3FF)) { if (ch > 0xFFFF) { /* CESU-8 6-byte sequence for chars > U+FFFF */ ch -= 0x10000; -- cgit v0.12 From a750ed2c2475387ab61073159ebf455c2452c78e Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 14 Feb 2023 11:39:35 +0000 Subject: Fix uniqueness parsing fconfigure -encoding / -encodingprofile options --- generic/tclIO.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 49f4257..8a6f76a 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -7994,7 +7994,7 @@ Tcl_GetChannelOption( return TCL_OK; } } - if (len == 0 || HaveOpt(2, "-encoding")) { + if (len == 0 || HaveOpt(8, "-encoding")) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-encoding"); } @@ -8008,7 +8008,7 @@ Tcl_GetChannelOption( return TCL_OK; } } - if (len == 0 || HaveOpt(1, "-encodingprofile")) { + if (len == 0 || HaveOpt(9, "-encodingprofile")) { int profile; const char *profileName; if (len == 0) { -- cgit v0.12 From 891d60a9ad2f9600dd9b1c3f0ce966d79a8942e8 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 14 Feb 2023 11:56:49 +0000 Subject: Remove obsolete comment --- generic/tclEncoding.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 778fca8..0f5e05f 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -570,8 +570,6 @@ TclInitEncodingSubsystem(void) Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&encodingMutex); - /* TODO - why is NOCOMPLAIN being hardcoded for encodings below? */ - /* * 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 -- cgit v0.12 From 38df35585000fd7245c6604e845663751a7bd524 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 14 Feb 2023 20:50:26 +0000 Subject: Complete fix for [bd1a60eb9c]. Also fix a bug in the tableencoding. With testcases. --- generic/tclEncoding.c | 24 ++++++++++++++++-------- tests/encoding.test | 38 ++++++++++++++++++++++++++++++++++++-- 2 files changed, 52 insertions(+), 10 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 01c4eb1..c5ecc46 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2380,7 +2380,7 @@ UtfToUtfProc( result = TCL_CONVERT_NOSPACE; break; } - if (UCHAR(*src) < 0x80 && !((UCHAR(*src) == 0) && (flags & TCL_ENCODING_MODIFIED))) { + if (UCHAR(*src) < 0x80 && !((UCHAR(*src) == 0) && (flags & ENCODING_INPUT))) { /* * Copy 7bit characters, but skip null-bytes when we are in input * mode, so that they get converted to 0xC080. @@ -2388,11 +2388,13 @@ UtfToUtfProc( *dst++ = *src++; } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) - && (UCHAR(src[1]) == 0x80) && (!(flags & TCL_ENCODING_MODIFIED) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) || (flags & ENCODING_FAILINDEX))) { + && (UCHAR(src[1]) == 0x80) && (flags & ENCODING_UTF) && (!(flags & ENCODING_INPUT) + || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) + || (flags & ENCODING_FAILINDEX))) { /* * If in input mode, and -strict or -failindex is specified: This is an error. */ - if (flags & TCL_ENCODING_MODIFIED) { + if (flags & ENCODING_INPUT) { result = TCL_CONVERT_SYNTAX; break; } @@ -2410,7 +2412,7 @@ UtfToUtfProc( * unless the user has explicitly asked to be told. */ - if (flags & TCL_ENCODING_MODIFIED) { + if (flags & ENCODING_INPUT) { if ((STOPONERROR) && (flags & TCL_ENCODING_CHAR_LIMIT)) { result = TCL_CONVERT_MULTIBYTE; break; @@ -2430,7 +2432,7 @@ UtfToUtfProc( int low; const char *saveSrc = src; size_t len = TclUtfToUCS4(src, &ch); - if ((len < 2) && (ch != 0) && (flags & TCL_ENCODING_MODIFIED) + if ((len < 2) && (ch != 0) && (flags & ENCODING_INPUT) && (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT))) { result = TCL_CONVERT_SYNTAX; break; @@ -2451,6 +2453,11 @@ UtfToUtfProc( * A surrogate character is detected, handle especially. */ + if (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) && (flags & ENCODING_UTF)) { + result = TCL_CONVERT_UNKNOWN; + src = saveSrc; + break; + } low = ch; len = (src <= srcEnd-3) ? TclUtfToUCS4(src, &low) : 0; @@ -2470,12 +2477,12 @@ UtfToUtfProc( src += len; dst += Tcl_UniCharToUtf(ch, dst); ch = low; - } else if (STOPONERROR && !(flags & TCL_ENCODING_MODIFIED) && (((ch & ~0x7FF) == 0xD800))) { + } else if (STOPONERROR && !(flags & ENCODING_INPUT) && (((ch & ~0x7FF) == 0xD800))) { result = TCL_CONVERT_UNKNOWN; src = saveSrc; break; } else if (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) - && (flags & TCL_ENCODING_MODIFIED) && ((ch & ~0x7FF) == 0xD800)) { + && (flags & ENCODING_INPUT) && ((ch & ~0x7FF) == 0xD800)) { result = TCL_CONVERT_SYNTAX; src = saveSrc; break; @@ -3117,7 +3124,8 @@ TableToUtfProc( ch = pageZero[byte]; } if ((ch == 0) && (byte != 0)) { - if (STOPONERROR) { + if ((flags & ENCODING_FAILINDEX) + || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)) { result = TCL_CONVERT_SYNTAX; break; } diff --git a/tests/encoding.test b/tests/encoding.test index b2b029e..bbb40d7 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -452,6 +452,24 @@ test encoding-15.24 {UtfToUtfProc CESU-8 bug [048dd20b4171c8da]} { binary scan $y H* z list [string length $y] $z } {2 cfbf} +test encoding-15.25 {UtfToUtfProc CESU-8} { + encoding convertfrom cesu-8 \x00 +} \x00 +test encoding-15.26 {UtfToUtfProc CESU-8} { + encoding convertfrom cesu-8 \xC0\x80 +} \x00 +test encoding-15.27 {UtfToUtfProc -strict CESU-8} { + encoding convertfrom -strict cesu-8 \xC0\x80 +} \x00 +test encoding-15.28 {UtfToUtfProc -strict CESU-8} { + encoding convertfrom -strict cesu-8 \xC0\x80 +} \x00 +test encoding-15.29 {UtfToUtfProc CESU-8} { + encoding convertto cesu-8 \x00 +} \xC0\x80 +test encoding-15.30 {UtfToUtfProc -strict CESU-8} { + encoding convertto -strict cesu-8 \x00 +} \xC0\x80 test encoding-16.1 {Utf16ToUtfProc} -body { set val [encoding convertfrom utf-16 NN] @@ -584,8 +602,21 @@ test encoding-18.6 {TableToUtfProc on invalid input with -nocomplain} -body { list [catch {encoding convertto -nocomplain jis0208 \\} res] $res } -result {0 !)} -test encoding-19.1 {TableFromUtfProc} { -} {} +test encoding-19.1 {TableFromUtfProc} -body { + encoding convertfrom ascii AÁ +} -result AÁ +test encoding-19.2 {TableFromUtfProc} -body { + encoding convertfrom -nocomplain ascii AÁ +} -result AÁ +test encoding-19.3 {TableFromUtfProc} -body { + encoding convertfrom -strict ascii AÁ +} -returnCodes 1 -result {unexpected byte sequence starting at index 1: '\xC1'} +test encoding-19.4 {TableFromUtfProc} -body { + list [encoding convertfrom -failindex idx ascii AÁ] [set idx] +} -result {A 1} +test encoding-19.4 {TableFromUtfProc} -body { + list [encoding convertfrom -failindex idx -strict ascii AÁ] [set idx] +} -result {A 1} test encoding-20.1 {TableFreefProc} { } {} @@ -804,6 +835,9 @@ test encoding-24.39 {Try to generate invalid utf-8 with -strict} -body { test encoding-24.40 {Try to generate invalid utf-8 with -nocomplain} -body { encoding convertto -nocomplain utf-8 \uD800 } -result \xED\xA0\x80 +test encoding-24.41 {Parse invalid utf-8 with -strict} -body { + encoding convertfrom -strict utf-8 \xED\xA0\x80\xED\xB0\x80 +} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xED'} file delete [file join [temporaryDirectory] iso2022.txt] -- cgit v0.12 From 4c2d834fca441a8d463e3bd1a06489f0b864cf73 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 15 Feb 2023 07:21:55 +0000 Subject: Ticket [10c2c17c32] follow-up. One output char too much with -failindex. --- generic/tclEncoding.c | 1 + tests/encoding.test | 3 +++ 2 files changed, 4 insertions(+) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index c5ecc46..c4db314 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2595,6 +2595,7 @@ Utf32ToUtfProc( && ((ch & ~0x7FF) == 0xD800))) { if (STOPONERROR) { result = TCL_CONVERT_SYNTAX; + ch = 0; break; } } diff --git a/tests/encoding.test b/tests/encoding.test index bbb40d7..916a84a 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -527,6 +527,9 @@ test encoding-16.15 {Utf16ToUtfProc} -body { test encoding-16.16 {Utf16ToUtfProc} -body { encoding convertfrom utf-16le \x00\xDC\x00\xD8 } -result \uDC00\uD800 +test encoding-16.17 {Utf32ToUtfProc} -body { + list [encoding convertfrom -strict -failindex idx utf-32le \x41\x00\x00\x00\x00\xD8\x00\x00\x42\x00\x00\x00] [set idx] +} -result {A 4} test encoding-16.9 { Utf16ToUtfProc, Tcl_UniCharToUtf, surrogate pairs in utf-16 -- cgit v0.12 From 96e60d29b763fa1c662fb77e731556ddfaf9c912 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 15 Feb 2023 17:27:55 +0000 Subject: Start on expanding encoding tests --- generic/tclEncoding.c | 41 +++++------ tests/cmdAH.test | 196 +++++++++++++++++++++++++++++++++++++++++++------- 2 files changed, 190 insertions(+), 47 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 7886910..8cd970f 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2409,32 +2409,29 @@ UtfToUtfProc( */ *dst++ = *src++; - } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) - && (UCHAR(src[1]) == 0x80) && (flags & ENCODING_UTF) && (!(flags & ENCODING_INPUT) - || PROFILE_STRICT(profile))) { - /* - * \xC0\x80 and either strict profile or target is "real" UTF-8 - * - Strict profile - error - * - Non-strict, real UTF-8 - output \x00 - */ - if (flags & ENCODING_INPUT) { - /* - * TODO - should above check not be against STRICT? - * That would probably break a convertto command that goes - * from the internal UTF8 to the real UTF8. On the other - * hand this means, a strict UTF8->UTF8 transform is not - * possible using this function. - */ + } + else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) && + (UCHAR(src[1]) == 0x80) && (flags & ENCODING_UTF) && + (!(flags & ENCODING_INPUT) || PROFILE_STRICT(profile) || + PROFILE_REPLACE(profile))) { + /* Special sequence \xC0\x80 */ + if (PROFILE_STRICT(profile)) { result = TCL_CONVERT_SYNTAX; break; } - /* - * Convert 0xC080 to real nulls when we are in output mode, - * irrespective of the profile. - */ - *dst++ = 0; - src += 2; + if (PROFILE_REPLACE(profile)) { + dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst); + src += 1; /* C0, 80 handled in next loop iteration + since dst limit has to be checked */ + } else { + /* + * Convert 0xC080 to real nulls when we are in output mode, + * irrespective of the profile. + */ + *dst++ = 0; + src += 2; + } } else if (!Tcl_UtfCharComplete(src, srcEnd - src)) { /* diff --git a/tests/cmdAH.test b/tests/cmdAH.test index f2aab52..6aa3c2e 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -184,7 +184,8 @@ set encProfiles {tcl8 strict replace} # TODO - valid sequences for different encodings - shiftjis etc. # Note utf-16, utf-32 missing because they are automatically -# generated based on le/be versions. +# generated based on le/be versions. Also add all ranges from Unicode standard +# Table 3.7 set encValidStrings { ascii ABC \x41\x42\x43 utf-8 A\u0000\u03A9\u8A9E\U00010384 \x41\x00\xCE\xA9\xE8\xAA\x9E\xF0\x90\x8E\x84 @@ -194,22 +195,106 @@ set encValidStrings { utf-32be A\u0000\u03A9\u8A9E\U00010384 \x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x03\xA9\x00\x00\x8A\x9E\x00\x01\x03\x84 } -# Invalid byte sequences {encoding bytes profile prefix failindex tag} +# Invalid byte sequences. These are driven from a table with format +# {encoding bytes profile expectedresult expectedfailindex ctrl comment} +# # Note tag is used in test id generation as well. The combination -# should be unique for test ids to be unique. -# Note utf-16, utf-32 missing because they are automatically -# generated based on le/be versions. +# should be unique for test ids to be unique. Note utf-16, +# utf-32 missing because they are automatically generated based on le/be +# versions. Each entry potentially results in generation of multiple tests. +# This is controlled by the ctrl field. This should be a list of +# zero or more of the following: +# solo - the test data is the string itself +# lead - the test data is the string followed by a valid suffix +# tail - the test data is the string preceded by a prefix +# middle - the test data is the string wrapped by a prefix and suffix +# If the ctrl field is empty it is treated as all of the above +# Note if there is any other value by itself, it will cause the test to +# be skipped. This is intentional to skip known bugs. + # TODO - other encodings and test cases + +# ascii - Any byte above 127 is invalid set encInvalidBytes { + ascii 80 default \u20AC -1 {} {map to cp1252} + ascii 80 tcl8 \u20AC -1 {} {map to cp1252} + ascii 80 replace \uFFFD -1 {} {Smallest invalid byte} + ascii 80 strict {} 0 {} {Smallest invalid byte} + + ascii 81 default \u0081 -1 {knownBug} {map to cp1252} + ascii 82 default \u201A -1 {knownBug} {map to cp1252} + ascii 83 default \u0192 -1 {knownBug} {map to cp1252} + ascii 84 default \u201E -1 {knownBug} {map to cp1252} + ascii 85 default \u2026 -1 {knownBug} {map to cp1252} + ascii 86 default \u2020 -1 {knownBug} {map to cp1252} + ascii 87 default \u2021 -1 {knownBug} {map to cp1252} + ascii 88 default \u0276 -1 {knownBug} {map to cp1252} + ascii 89 default \u2030 -1 {knownBug} {map to cp1252} + ascii 8A default \u0160 -1 {knownBug} {map to cp1252} + ascii 8B default \u2039 -1 {knownBug} {map to cp1252} + ascii 8C default \u0152 -1 {knownBug} {map to cp1252} + ascii 8D default \u008D -1 {knownBug} {map to cp1252} + ascii 8E default \u017D -1 {knownBug} {map to cp1252} + ascii 8F default \u008F -1 {knownBug} {map to cp1252} + ascii 90 default \u0090 -1 {knownBug} {map to cp1252} + ascii 91 default \u2018 -1 {knownBug} {map to cp1252} + ascii 92 default \u2019 -1 {knownBug} {map to cp1252} + ascii 93 default \u201C -1 {knownBug} {map to cp1252} + ascii 94 default \u201D -1 {knownBug} {map to cp1252} + ascii 95 default \u2022 -1 {knownBug} {map to cp1252} + ascii 96 default \u2013 -1 {knownBug} {map to cp1252} + ascii 97 default \u2014 -1 {knownBug} {map to cp1252} + ascii 98 default \u02DC -1 {knownBug} {map to cp1252} + ascii 99 default \u2122 -1 {knownBug} {map to cp1252} + ascii 9A default \u0161 -1 {knownBug} {map to cp1252} + ascii 9B default \u203A -1 {knownBug} {map to cp1252} + ascii 9C default \u0153 -1 {knownBug} {map to cp1252} + ascii 9D default \u009D -1 {knownBug} {map to cp1252} + ascii 9E default \u017E -1 {knownBug} {map to cp1252} + ascii 9F default \u0178 -1 {knownBug} {map to cp1252} + + ascii FF default \u00FF -1 {} {Largest invalid byte} + ascii FF tcl8 \u00FF -1 {} {Largest invalid byte} + ascii FF replace \uFFFD -1 {} {Largest invalid byte} + ascii FF strict {} 0 {} {Largest invalid byte} +} + +# Following invalid sequences based on Table 3.7 in the Unicode standard. +# utf-8 C0, C1, F5:FF are invalid bytes ANYWHERE. +# Exception is C080 in non-strict mode. +# +lappend encInvalidBytes {*}{ + utf-8 C0 default \u00C0 -1 {} {C0 is invalid anywhere} + utf-8 C0 tcl8 \u00C0 -1 {} {C0 is invalid anywhere} + utf-8 C0 replace \uFFFD -1 {} {C0 is invalid anywhere} + utf-8 C0 strict {} 0 {} {C0 is invalid anywhere} + + utf-8 C080 default \u0000 -1 {} {C080 -> U+0 in Tcl's internal modified UTF8} + utf-8 C080 tcl8 \u0000 -1 {} {C080 -> U+0 in Tcl's internal modified UTF8} + utf-8 C080 replace \uFFFD\uFFFD -1 C080 {} {C080 -> U+0 in Tcl's internal modified UTF8} + utf-8 C080 strict {} 0 {} {C080 -> U+0 in Tcl's internal modified UTF8} + + utf-8 C1 default \u00C1 -1 {} {C1 is invalid everywhere} + utf-8 C1 tcl8 \u00C1 -1 {} {C1 is invalid everywhere} + utf-8 C1 replace \uFFFD -1 {} {C1 is invalid everywhere} + utf-8 C1 strict {} 0 {} {C1 is invalid everywhere} + utf-8 F5 default \u00F5 -1 {} {F5:FF are invalid everywhere} + utf-8 F5 tcl8 \u00F5 -1 {} {F5:FF are invalid everywhere} + utf-8 F5 replace \uFFFD -1 {} {F5:FF are invalid everywhere} + utf-8 F5 strict {} 0 {} {F5:FF are invalid everywhere} + utf-8 FF default \u00FF -1 {} {F5:FF are invalid everywhere} + utf-8 FF tcl8 \u00FF -1 {} {F5:FF are invalid everywhere} + utf-8 FF replace \uFFFD -1 {} {F5:FF are invalid everywhere} + utf-8 FF strict {} 0 {} {F5:FF are invalid everywhere} + utf-8 F5908080 default \u00F5 -1 {knownBug} {F5:FF with trailing bytes} +} + +set xxencInvalidBytes { ascii \x41\xe9\x42 default A\u00E9B -1 {non-ASCII} ascii \x41\xe9\x42 tcl8 A\u00E9B -1 {non-ASCII} ascii \x41\xe9\x42 replace A\uFFFDB -1 {non-ASCII} ascii \x41\xe9\x42 strict A 1 {non-ASCII} - - utf-8 \x41\xC0\x42 default A\u00C0B -1 C0 - utf-8 \x41\xC0\x42 tcl8 A\u00C0B -1 C0 - utf-8 \x41\xC0\x42 replace A\uFFFDB -1 C0 - utf-8 \x41\xC0\x42 strict A 1 C0 + utf-8 \x41\x80\x42 default A\u0080B -1 80 utf-8 \x41\x80\x42 tcl8 A\u0080B -1 80 utf-8 \x41\x80\x42 replace A\uFFFDB -1 80 @@ -272,7 +357,7 @@ set encUnencodableStrings { iso8859-1 A\u0141B default \x41\x3f\x42 -1 unencodable iso8859-1 A\u0141B tcl8 \x41\x3f\x42 -1 unencodable - iso8859-1 A\u0141B strict \x41 1 unencodable + iso8859-1 A\u0141B strict \x41 0 unencodable utf-8 A\uD800B default \x41\xed\xa0\x80\x42 -1 High-surrogate utf-8 A\uD800B tcl8 \x41\xed\xa0\x80\x42 -1 High-surrogate @@ -282,12 +367,28 @@ set encUnencodableStrings { utf-8 A\uDC00B strict \x41 1 High-surrogate } + if {$::tcl_platform(byteOrder) eq "littleEndian"} { set endian le } else { set endian be } +# Maps utf-{16,32}{le,be} to utf-16, utf-32 and +# others to "". Used to test utf-16, utf-32 based +# on system endianness +proc endianUtf {enc} { + if {$::tcl_platform(byteOrder) eq "littleEndian"} { + set endian le + } else { + set endian be + } + if {$enc eq "utf-16$endian" || $enc eq "utf-32$endian"} { + return [string range $enc 0 5] + } + return "" +} + # # Check errors for invalid number of arguments proc badnumargs {id cmd cmdargs} { @@ -394,9 +495,17 @@ testconvert cmdAH-4.3.12 { # Wrapper for verifying -failindex proc testfailindex {id converter enc data result {profile default}} { if {$profile eq "default"} { - testconvert $id "list \[encoding $converter -failindex idx $enc $data] \[set idx]" $result + testconvert $id.$enc "list \[encoding $converter -failindex idx $enc $data] \[set idx]" $result + if {[set enc [endianUtf $enc]] ne ""} { + # If utf{16,32}-{le,be}, also do utf{16,32} + testconvert $id.$enc "list \[encoding $converter -failindex idx $enc $data] \[set idx]" $result + } } else { - testconvert $id "list \[encoding $converter -profile $profile -failindex idx $enc $data] \[set idx]" $result + testconvert $id.$enc "list \[encoding $converter -profile $profile -failindex idx $enc $data] \[set idx]" $result + if {[set enc [endianUtf $enc]] ne ""} { + # If utf{16,32}-{le,be}, also do utf{16,32} + testconvert $id.$enc "list \[encoding $converter -profile $profile -failindex idx $enc $data] \[set idx]" $result + } } } @@ -410,13 +519,49 @@ foreach {enc string bytes} $encValidStrings { } } -# -failindex - invalid data -foreach {enc bytes profile prefix failidx tag} $encInvalidBytes { - testfailindex cmdAH-4.3.14.$enc.$profile.$tag convertfrom $enc $bytes [list $prefix $failidx] $profile - if {"utf-16$endian" eq $enc} { - # utf-16le ->utf-16, utf-32be -> utf32 etc. - set enc [string range $enc 0 5] - testfailindex cmdAH-4.3.14.$enc.$profile.$tag convertfrom $enc $bytes [list $prefix $failidx] $profile +# -failindex - invalid data for each profile +foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { + # There are multiple test cases based on location of invalid bytes + set bytes [binary format H* $hex] + set prefix A + set suffix B + set prefixLen [string length [encoding convertto $enc $prefix]] + if {$ctrl eq {} || "solo" in $ctrl} { + testfailindex xxcmdAH-4.3.14.$profile.$hex.solo convertfrom $enc $bytes [list $str $failidx] $profile + } + if {$ctrl eq {} || "lead" in $ctrl} { + if {$failidx == -1} { + # If success expected + set result $str$suffix + } else { + # Failure expected + set result "" + } + testfailindex xxcmdAH-4.3.14.$profile.$hex.lead convertfrom $enc $bytes$suffix [list $result $failidx] $profile + } + if {$ctrl eq {} || "tail" in $ctrl} { + set expected_failidx $failidx + if {$failidx == -1} { + # If success expected + set result $prefix$str + } else { + # Failure expected + set result $prefix + incr expected_failidx [string length [encoding convertto $enc $prefix]] + } + testfailindex xxcmdAH-4.3.14.$profile.$hex.tail convertfrom $enc $prefix$bytes [list $result $expected_failidx] $profile + } + if {$ctrl eq {} || "middle" in $ctrl} { + set expected_failidx $failidx + if {$failidx == -1} { + # If success expected + set result $prefix$str$suffix + } else { + # Failure expected + set result $prefix + incr expected_failidx [string length [encoding convertto $enc $prefix]] + } + testfailindex xxcmdAH-4.3.14.$profile.$hex.middle convertfrom $enc $prefix$bytes$suffix [list $result $expected_failidx] $profile } } @@ -437,7 +582,8 @@ foreach profile $encProfiles { # Cycle through the various combinations of encodings and profiles # for invalid byte sequences -foreach {enc bytes profile prefix failidx tag} $encInvalidBytes { +foreach {enc hex profile prefix failidx ctrl comment} $encInvalidBytes { + set bytes [binary format H* $hex] if {$failidx eq -1} { set result [list $prefix] } else { @@ -447,18 +593,18 @@ foreach {enc bytes profile prefix failidx tag} $encInvalidBytes { set result [list "unexpected byte sequence starting at index $failidx: *" -returnCodes error -match glob] } if {$profile eq "default"} { - testconvert cmdAH-4.3.15.$enc.$profile.$tag [list encoding convertfrom $enc $bytes] {*}$result + testconvert cmdAH-4.3.15.$enc.$profile.$hex [list encoding convertfrom $enc $bytes] {*}$result if {"utf-16$endian" eq $enc} { # utf-16le ->utf-16, utf-32be -> utf32 etc. set enc [string range $enc 0 5] - testconvert cmdAH-4.3.15.$enc.$profile.$tag [list encoding convertfrom $enc $bytes] {*}$result + testconvert cmdAH-4.3.15.$enc.$profile.$hex [list encoding convertfrom $enc $bytes] {*}$result } } else { - testconvert cmdAH-4.3.15.$enc.$profile.$tag [list encoding convertfrom -profile $profile $enc $bytes] {*}$result + testconvert cmdAH-4.3.15.$enc.$profile.$hex [list encoding convertfrom -profile $profile $enc $bytes] {*}$result if {"utf-16$endian" eq $enc} { # utf-16le ->utf-16, utf-32be -> utf32 etc. set enc [string range $enc 0 5] - testconvert cmdAH-4.3.15.$enc.$profile.$tag [list encoding convertfrom -profile $profile $enc $bytes] {*}$result + testconvert cmdAH-4.3.15.$enc.$profile.$hex [list encoding convertfrom -profile $profile $enc $bytes] {*}$result } } } -- cgit v0.12 From f06c5e7af1c85806bcbce3202000670b90ab4528 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 15 Feb 2023 20:26:10 +0000 Subject: Fix for [33ab6d08eb]: Inconsistent behavior with encoding convertfrom -failindex --- generic/tclEncoding.c | 2 +- tests/encoding.test | 5 ++++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index c4db314..af7f30a 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2433,7 +2433,7 @@ UtfToUtfProc( const char *saveSrc = src; size_t len = TclUtfToUCS4(src, &ch); if ((len < 2) && (ch != 0) && (flags & ENCODING_INPUT) - && (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT))) { + && (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) || (flags & ENCODING_FAILINDEX))) { result = TCL_CONVERT_SYNTAX; break; } diff --git a/tests/encoding.test b/tests/encoding.test index 916a84a..6f1a760 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -617,9 +617,12 @@ test encoding-19.3 {TableFromUtfProc} -body { test encoding-19.4 {TableFromUtfProc} -body { list [encoding convertfrom -failindex idx ascii AÁ] [set idx] } -result {A 1} -test encoding-19.4 {TableFromUtfProc} -body { +test encoding-19.5 {TableFromUtfProc} -body { list [encoding convertfrom -failindex idx -strict ascii AÁ] [set idx] } -result {A 1} +test encoding-19.6 {TableFromUtfProc} -body { + list [encoding convertfrom -failindex idx -strict ascii AÁB] [set idx] +} -result {A 1} test encoding-20.1 {TableFreefProc} { } {} -- cgit v0.12 From 50538911836e76d66a3526e5fe950134cca022d8 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 16 Feb 2023 07:59:09 +0000 Subject: Try to fix [885c86a9a0]. Doesn't work completely yet. --- generic/tclEncoding.c | 8 +++----- tests/encoding.test | 8 +++++++- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index c4db314..e178f80 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2421,12 +2421,10 @@ UtfToUtfProc( result = TCL_CONVERT_SYNTAX; break; } - ch = UCHAR(*src++); - } else { - char chbuf[2]; - chbuf[0] = UCHAR(*src++); chbuf[1] = 0; - TclUtfToUCS4(chbuf, &ch); } + char chbuf[2]; + chbuf[0] = UCHAR(*src++); chbuf[1] = 0; + Tcl_UtfToUniChar(chbuf, &ch); dst += Tcl_UniCharToUtf(ch, dst); } else { int low; diff --git a/tests/encoding.test b/tests/encoding.test index 916a84a..270c351 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -762,7 +762,7 @@ test encoding-24.14 {Parse valid or invalid utf-8} { } 1 test encoding-24.15 {Parse valid or invalid utf-8} -constraints deprecated -body { encoding convertfrom utf-8 "Z\xE0\x80" -} -result Z\xE0\x80 +} -result Z\xE0\u20AC test encoding-24.16 {Parse valid or invalid utf-8} -constraints testbytestring -body { encoding convertto utf-8 [testbytestring "Z\u4343\x80"] } -returnCodes 1 -result {expected byte sequence but character 1 was '䍃€' (U+004343)} @@ -841,6 +841,12 @@ test encoding-24.40 {Try to generate invalid utf-8 with -nocomplain} -body { test encoding-24.41 {Parse invalid utf-8 with -strict} -body { encoding convertfrom -strict utf-8 \xED\xA0\x80\xED\xB0\x80 } -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xED'} +test encoding-24.42 {Parse invalid utf-8, fallback to cp1252 [885c86a9a0]} -body { + encoding convertfrom -nocomplain utf-8 \xF0\x80\x80\x80 +} -result \xF0\u20AC\u20AC\u20AC€€ +test encoding-24.43 {Parse invalid utf-8, fallback to cp1252 [885c86a9a0]} -body { + encoding convertfrom -nocomplain utf-8 \x80 +} -result \u20AC€€ file delete [file join [temporaryDirectory] iso2022.txt] -- cgit v0.12 From 0563a789022a80cd7745d596028b570f0fb24cbb Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 16 Feb 2023 16:59:10 +0000 Subject: Fix [5e6ae6e05e]: Implement -strict correctly for cesu-8 --- generic/tclEncoding.c | 24 +++++++++++++++--------- tests/encoding.test | 13 ++++++++----- 2 files changed, 23 insertions(+), 14 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index c4db314..73cbc5c 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -564,7 +564,7 @@ TclInitEncodingSubsystem(void) type.nullSize = 1; type.clientData = INT2PTR(ENCODING_UTF); Tcl_CreateEncoding(&type); - type.clientData = INT2PTR(TCL_ENCODING_NOCOMPLAIN); + type.clientData = INT2PTR(0); type.encodingName = "cesu-8"; Tcl_CreateEncoding(&type); @@ -2388,13 +2388,13 @@ UtfToUtfProc( *dst++ = *src++; } else if ((UCHAR(*src) == 0xC0) && (src + 1 < srcEnd) - && (UCHAR(src[1]) == 0x80) && (flags & ENCODING_UTF) && (!(flags & ENCODING_INPUT) + && (UCHAR(src[1]) == 0x80) && !(flags & TCL_ENCODING_MODIFIED) && (!(flags & ENCODING_INPUT) || ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) || (flags & ENCODING_FAILINDEX))) { /* * If in input mode, and -strict or -failindex is specified: This is an error. */ - if (flags & ENCODING_INPUT) { + if ((STOPONERROR) && (flags & ENCODING_INPUT)) { result = TCL_CONVERT_SYNTAX; break; } @@ -2430,15 +2430,21 @@ UtfToUtfProc( dst += Tcl_UniCharToUtf(ch, dst); } else { int low; - const char *saveSrc = src; size_t len = TclUtfToUCS4(src, &ch); - if ((len < 2) && (ch != 0) && (flags & ENCODING_INPUT) - && (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT))) { - result = TCL_CONVERT_SYNTAX; - break; + if (flags & ENCODING_INPUT) { + if ((len < 2) && (ch != 0) + && ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)) { + result = TCL_CONVERT_SYNTAX; + break; + } else if ((ch > 0xFFFF) && !(flags & ENCODING_UTF) + && ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)) { + result = TCL_CONVERT_SYNTAX; + break; + } } + const char *saveSrc = src; src += len; - if (!(flags & ENCODING_UTF) && (ch > 0x3FF)) { + if (!(flags & ENCODING_UTF) && !(flags & ENCODING_INPUT) && (ch > 0x3FF)) { if (ch > 0xFFFF) { /* CESU-8 6-byte sequence for chars > U+FFFF */ ch -= 0x10000; diff --git a/tests/encoding.test b/tests/encoding.test index 916a84a..34dfafb 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -459,17 +459,20 @@ test encoding-15.26 {UtfToUtfProc CESU-8} { encoding convertfrom cesu-8 \xC0\x80 } \x00 test encoding-15.27 {UtfToUtfProc -strict CESU-8} { - encoding convertfrom -strict cesu-8 \xC0\x80 + encoding convertfrom -strict cesu-8 \x00 } \x00 -test encoding-15.28 {UtfToUtfProc -strict CESU-8} { +test encoding-15.28 {UtfToUtfProc -strict CESU-8} -body { encoding convertfrom -strict cesu-8 \xC0\x80 -} \x00 +} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xC0'} test encoding-15.29 {UtfToUtfProc CESU-8} { encoding convertto cesu-8 \x00 -} \xC0\x80 +} \x00 test encoding-15.30 {UtfToUtfProc -strict CESU-8} { encoding convertto -strict cesu-8 \x00 -} \xC0\x80 +} \x00 +test encoding-15.31 {UtfToUtfProc -strict CESU-8 (bytes F0-F4 are invalid)} -body { + encoding convertfrom -strict cesu-8 \xF1\x86\x83\x9C +} -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xF1'} test encoding-16.1 {Utf16ToUtfProc} -body { set val [encoding convertfrom utf-16 NN] -- cgit v0.12 From 684cbb8f5cc3ed03b9349b0d322b04f1c87cc86a Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 16 Feb 2023 17:15:35 +0000 Subject: Bit more work on encoding test framework. Long way to go. --- generic/tclEncoding.c | 65 ++++---- tests/cmdAH.test | 427 ++++++++++++++++++++++++++++++++++---------------- 2 files changed, 324 insertions(+), 168 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 8cd970f..470f8f3 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2368,6 +2368,7 @@ UtfToUtfProc( const char *dstStart, *dstEnd; int result, numChars, charLimit = INT_MAX; int ch; + int profile; result = TCL_OK; @@ -2385,8 +2386,8 @@ UtfToUtfProc( flags |= PTR2INT(clientData); dstEnd = dst + dstLen - ((flags & ENCODING_UTF) ? TCL_UTF_MAX : 6); + profile = TCL_ENCODING_PROFILE_GET(flags); for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) { - int profile = TCL_ENCODING_PROFILE_GET(flags); if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { /* @@ -2415,15 +2416,15 @@ UtfToUtfProc( (!(flags & ENCODING_INPUT) || PROFILE_STRICT(profile) || PROFILE_REPLACE(profile))) { /* Special sequence \xC0\x80 */ - if (PROFILE_STRICT(profile)) { - result = TCL_CONVERT_SYNTAX; - break; - } - - if (PROFILE_REPLACE(profile)) { - dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst); - src += 1; /* C0, 80 handled in next loop iteration - since dst limit has to be checked */ + if (flags & ENCODING_INPUT) { + if (PROFILE_REPLACE(profile)) { + dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst); + src += 2; + } else { + /* PROFILE_STRICT */ + result = TCL_CONVERT_SYNTAX; + break; + } } else { /* * Convert 0xC080 to real nulls when we are in output mode, @@ -2432,6 +2433,7 @@ UtfToUtfProc( *dst++ = 0; src += 2; } + } else if (!Tcl_UtfCharComplete(src, srcEnd - src)) { /* @@ -2516,32 +2518,37 @@ UtfToUtfProc( /* * A surrogate character is detected, handle especially. */ - /* TODO - what about REPLACE profile? */ if (PROFILE_STRICT(profile) && (flags & ENCODING_UTF)) { result = TCL_CONVERT_UNKNOWN; src = saveSrc; break; } - - low = ch; - len = (src <= srcEnd-3) ? TclUtfToUCS4(src, &low) : 0; - - if ((!LOW_SURROGATE(low)) || (ch & 0x400)) { - - if (PROFILE_STRICT(profile)) { - result = TCL_CONVERT_UNKNOWN; - src = saveSrc; - break; + if (0 && PROFILE_REPLACE(profile)) { + ch = UNICODE_REPLACE_CHAR; + src += len; + // dst += Tcl_UniCharToUtf(ch, dst); + } + else { + low = ch; + len = (src <= srcEnd - 3) ? TclUtfToUCS4(src, &low) : 0; + + if ((!LOW_SURROGATE(low)) || (ch & 0x400)) { + + if (PROFILE_STRICT(profile)) { + result = TCL_CONVERT_UNKNOWN; + src = saveSrc; + break; + } +cesu8: + *dst++ = (char)(((ch >> 12) | 0xE0) & 0xEF); + *dst++ = (char)(((ch >> 6) | 0x80) & 0xBF); + *dst++ = (char)((ch | 0x80) & 0xBF); + continue; } - cesu8: - *dst++ = (char) (((ch >> 12) | 0xE0) & 0xEF); - *dst++ = (char) (((ch >> 6) | 0x80) & 0xBF); - *dst++ = (char) ((ch | 0x80) & 0xBF); - continue; + src += len; + dst += Tcl_UniCharToUtf(ch, dst); + ch = low; } - src += len; - dst += Tcl_UniCharToUtf(ch, dst); - ch = low; } else if (PROFILE_STRICT(profile) && (!(flags & ENCODING_INPUT)) && SURROGATE(ch)) { diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 6aa3c2e..6386658 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -187,19 +187,18 @@ set encProfiles {tcl8 strict replace} # generated based on le/be versions. Also add all ranges from Unicode standard # Table 3.7 set encValidStrings { - ascii ABC \x41\x42\x43 - utf-8 A\u0000\u03A9\u8A9E\U00010384 \x41\x00\xCE\xA9\xE8\xAA\x9E\xF0\x90\x8E\x84 - utf-16le A\u0000\u03A9\u8A9E\U00010384 \x41\x00\x00\x00\xA9\x03\x9E\x8A\x00\xD8\x84\xDF - utf-16be A\u0000\u03A9\u8A9E\U00010384 \x00\x41\x00\x00\x03\xA9\x8A\x9E\xD8\x00\xDF\x84 - utf-32le A\u0000\u03A9\u8A9E\U00010384 \x41\x00\x00\x00\x00\x00\x00\x00\xA9\x03\x00\x00\x9E\x8A\x00\x00\x84\x03\x01\x00 - utf-32be A\u0000\u03A9\u8A9E\U00010384 \x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x03\xA9\x00\x00\x8A\x9E\x00\x01\x03\x84 + ascii ABC 414243 + utf-8 A\u0000\u03A9\u8A9E\U00010384 4100CEA9E8AA9EF0908E84 + utf-16le A\u0000\u03A9\u8A9E\U00010384 41000000A9039E8A00D884DF + utf-16be A\u0000\u03A9\u8A9E\U00010384 0041000003A98A9ED800DF84 + utf-32le A\u0000\u03A9\u8A9E\U00010384 4100000000000000A90300009E8A000084030100 + utf-32be A\u0000\u03A9\u8A9E\U00010384 0000004100000000000003A900008A9E00010384 } # Invalid byte sequences. These are driven from a table with format # {encoding bytes profile expectedresult expectedfailindex ctrl comment} # -# Note tag is used in test id generation as well. The combination -# should be unique for test ids to be unique. Note utf-16, +# should be unique for test ids to be unique. Note utf-16, # utf-32 missing because they are automatically generated based on le/be # versions. Each entry potentially results in generation of multiple tests. # This is controlled by the ctrl field. This should be a list of @@ -214,13 +213,15 @@ set encValidStrings { # TODO - other encodings and test cases -# ascii - Any byte above 127 is invalid -set encInvalidBytes { - ascii 80 default \u20AC -1 {} {map to cp1252} - ascii 80 tcl8 \u20AC -1 {} {map to cp1252} +# ascii - Any byte above 127 is invalid and is mapped +# to the same numeric code point except for the range +# 80-9F which is treated as cp1252. +# This tests the TableToUtfProc code path. +lappend encInvalidBytes {*}{ + ascii 80 default \u20AC -1 {knownBug} {map to cp1252} + ascii 80 tcl8 \u20AC -1 {knownBug} {map to cp1252} ascii 80 replace \uFFFD -1 {} {Smallest invalid byte} ascii 80 strict {} 0 {} {Smallest invalid byte} - ascii 81 default \u0081 -1 {knownBug} {map to cp1252} ascii 82 default \u201A -1 {knownBug} {map to cp1252} ascii 83 default \u0192 -1 {knownBug} {map to cp1252} @@ -259,25 +260,80 @@ set encInvalidBytes { ascii FF strict {} 0 {} {Largest invalid byte} } -# Following invalid sequences based on Table 3.7 in the Unicode standard. -# utf-8 C0, C1, F5:FF are invalid bytes ANYWHERE. -# Exception is C080 in non-strict mode. -# +# utf-8 - valid sequences based on Table 3.7 in the Unicode +# standard. +# +# Code Points First Second Third Fourth Byte +# U+0000..U+007F 00..7F +# U+0080..U+07FF C2..DF 80..BF +# U+0800..U+0FFF E0 A0..BF 80..BF +# U+1000..U+CFFF E1..EC 80..BF 80..BF +# U+D000..U+D7FF ED 80..9F 80..BF +# U+E000..U+FFFF EE..EF 80..BF 80..BF +# U+10000..U+3FFFF F0 90..BF 80..BF 80..BF +# U+40000..U+FFFFF F1..F3 80..BF 80..BF 80..BF +# U+100000..U+10FFFF F4 80..8F 80..BF 80..BF +# +# Tests below are based on the "gaps" in the above table. Note ascii test +# values are repeated because internally a different code path is used +# (UtfToUtfProc). +# Note C0, C1, F5:FF are invalid bytes ANYWHERE. Exception is C080 lappend encInvalidBytes {*}{ + utf-8 80 default \u20AC -1 {knownBug} {map to cp1252} + utf-8 80 tcl8 \u20AC -1 {knownBug} {map to cp1252} + utf-8 80 replace \uFFFD -1 {} {Smallest invalid byte} + utf-8 80 strict {} 0 {} {Smallest invalid byte} + utf-8 81 default \u0081 -1 {knownBug} {map to cp1252} + utf-8 82 default \u201A -1 {knownBug} {map to cp1252} + utf-8 83 default \u0192 -1 {knownBug} {map to cp1252} + utf-8 84 default \u201E -1 {knownBug} {map to cp1252} + utf-8 85 default \u2026 -1 {knownBug} {map to cp1252} + utf-8 86 default \u2020 -1 {knownBug} {map to cp1252} + utf-8 87 default \u2021 -1 {knownBug} {map to cp1252} + utf-8 88 default \u0276 -1 {knownBug} {map to cp1252} + utf-8 89 default \u2030 -1 {knownBug} {map to cp1252} + utf-8 8A default \u0160 -1 {knownBug} {map to cp1252} + utf-8 8B default \u2039 -1 {knownBug} {map to cp1252} + utf-8 8C default \u0152 -1 {knownBug} {map to cp1252} + utf-8 8D default \u008D -1 {knownBug} {map to cp1252} + utf-8 8E default \u017D -1 {knownBug} {map to cp1252} + utf-8 8F default \u008F -1 {knownBug} {map to cp1252} + utf-8 90 default \u0090 -1 {knownBug} {map to cp1252} + utf-8 91 default \u2018 -1 {knownBug} {map to cp1252} + utf-8 92 default \u2019 -1 {knownBug} {map to cp1252} + utf-8 93 default \u201C -1 {knownBug} {map to cp1252} + utf-8 94 default \u201D -1 {knownBug} {map to cp1252} + utf-8 95 default \u2022 -1 {knownBug} {map to cp1252} + utf-8 96 default \u2013 -1 {knownBug} {map to cp1252} + utf-8 97 default \u2014 -1 {knownBug} {map to cp1252} + utf-8 98 default \u02DC -1 {knownBug} {map to cp1252} + utf-8 99 default \u2122 -1 {knownBug} {map to cp1252} + utf-8 9A default \u0161 -1 {knownBug} {map to cp1252} + utf-8 9B default \u203A -1 {knownBug} {map to cp1252} + utf-8 9C default \u0153 -1 {knownBug} {map to cp1252} + utf-8 9D default \u009D -1 {knownBug} {map to cp1252} + utf-8 9E default \u017E -1 {knownBug} {map to cp1252} + utf-8 9F default \u0178 -1 {knownBug} {map to cp1252} + utf-8 C0 default \u00C0 -1 {} {C0 is invalid anywhere} utf-8 C0 tcl8 \u00C0 -1 {} {C0 is invalid anywhere} - utf-8 C0 replace \uFFFD -1 {} {C0 is invalid anywhere} utf-8 C0 strict {} 0 {} {C0 is invalid anywhere} - + utf-8 C0 replace \uFFFD -1 {} {C0 is invalid anywhere} utf-8 C080 default \u0000 -1 {} {C080 -> U+0 in Tcl's internal modified UTF8} utf-8 C080 tcl8 \u0000 -1 {} {C080 -> U+0 in Tcl's internal modified UTF8} - utf-8 C080 replace \uFFFD\uFFFD -1 C080 {} {C080 -> U+0 in Tcl's internal modified UTF8} - utf-8 C080 strict {} 0 {} {C080 -> U+0 in Tcl's internal modified UTF8} - + utf-8 C080 strict {} 0 {} {C080 -> invalid} + utf-8 C080 replace \uFFFD -1 {} {C080 -> single replacement char} utf-8 C1 default \u00C1 -1 {} {C1 is invalid everywhere} utf-8 C1 tcl8 \u00C1 -1 {} {C1 is invalid everywhere} utf-8 C1 replace \uFFFD -1 {} {C1 is invalid everywhere} utf-8 C1 strict {} 0 {} {C1 is invalid everywhere} + + utf-8 C1 default \u00C1 -1 {} {Require valid trail byte} + utf-8 C1 tcl8 \u00C1 -1 {} {Require valid trail byte} + utf-8 C1 replace \uFFFD -1 {} {Require valid trail byte} + utf-8 C1 strict {} 0 {} {Require valid trail byte} + + utf-8 F5 default \u00F5 -1 {} {F5:FF are invalid everywhere} utf-8 F5 tcl8 \u00F5 -1 {} {F5:FF are invalid everywhere} utf-8 F5 replace \uFFFD -1 {} {F5:FF are invalid everywhere} @@ -286,14 +342,14 @@ lappend encInvalidBytes {*}{ utf-8 FF tcl8 \u00FF -1 {} {F5:FF are invalid everywhere} utf-8 FF replace \uFFFD -1 {} {F5:FF are invalid everywhere} utf-8 FF strict {} 0 {} {F5:FF are invalid everywhere} - utf-8 F5908080 default \u00F5 -1 {knownBug} {F5:FF with trailing bytes} + + utf-8 C0AFE080BFF0818130 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {} {Unicode Table 3-8} + utf-8 EDA080EDBFBFEDAF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {knownBug} {Unicode Table 3-9} + utf-8 F4919293FF4180BF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\u0041\uFFFD\uFFFD\x30 -1 {} {Unicode Table 3-10} + utf-8 E180E2F09192F1BF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {knownBug} {Unicode Table 3.11} } set xxencInvalidBytes { - ascii \x41\xe9\x42 default A\u00E9B -1 {non-ASCII} - ascii \x41\xe9\x42 tcl8 A\u00E9B -1 {non-ASCII} - ascii \x41\xe9\x42 replace A\uFFFDB -1 {non-ASCII} - ascii \x41\xe9\x42 strict A 1 {non-ASCII} utf-8 \x41\x80\x42 default A\u0080B -1 80 utf-8 \x41\x80\x42 tcl8 A\u0080B -1 80 @@ -343,31 +399,39 @@ set utf32-le-TODO { } # Strings that cannot be encoded for specific encoding / profiles -# {encoding string profile bytes failindex tag} -# Note tag is used in test id generation as well. The combination -# should be unique for test ids to be unique. +# {encoding string profile exptedresult expectedfailindex ctrl comment} +# should be unique for test ids to be unique. # Note utf-16, utf-32 missing because they are automatically # generated based on le/be versions. +# Each entry potentially results in generation of multiple tests. +# This is controlled by the ctrl field. This should be a list of +# zero or more of the following: +# solo - the test data is the string itself +# lead - the test data is the string followed by a valid suffix +# tail - the test data is the string preceded by a prefix +# middle - the test data is the string wrapped by a prefix and suffix +# If the ctrl field is empty it is treated as all of the above +# Note if there is any other value by itself, it will cause the test to +# be skipped. This is intentional to skip known bugs. # TODO - other encodings and test cases # TODO - out of range code point (note cannot be generated by \U notation) set encUnencodableStrings { - ascii A\u00e0B default \x41\x3f\x42 -1 non-ASCII - ascii A\u00e0B tcl8 \x41\x3f\x42 -1 non-ASCII - ascii A\u00e0B strict \x41 1 non-ASCII - - iso8859-1 A\u0141B default \x41\x3f\x42 -1 unencodable - iso8859-1 A\u0141B tcl8 \x41\x3f\x42 -1 unencodable - iso8859-1 A\u0141B strict \x41 0 unencodable - - utf-8 A\uD800B default \x41\xed\xa0\x80\x42 -1 High-surrogate - utf-8 A\uD800B tcl8 \x41\xed\xa0\x80\x42 -1 High-surrogate - utf-8 A\uD800B strict \x41 1 High-surrogate - utf-8 A\uDC00B default \x41\xed\xb0\x80\x42 -1 High-surrogate - utf-8 A\uDC00B tcl8 \x41\xed\xb0\x80\x42 -1 High-surrogate - utf-8 A\uDC00B strict \x41 1 High-surrogate + ascii \u00e0 default 3f -1 {} {unencodable} + ascii \u00e0 tcl8 3f -1 {} {unencodable} + ascii \u00e0 strict {} 0 {} {unencodable} + + iso8859-1 \u0141 default 3f -1 {} unencodable + iso8859-1 \u0141 tcl8 3f -1 {} unencodable + iso8859-1 \u0141 strict {} 0 {} unencodable + + utf-8 \uD800 default eda080 -1 {} High-surrogate + utf-8 \uD800 tcl8 eda080 -1 {} High-surrogate + utf-8 \uD800 strict {} 0 {} High-surrogate + utf-8 \uDC00 default edb080 -1 {} High-surrogate + utf-8 \uDC00 tcl8 edb080 -1 {} High-surrogate + utf-8 \uDC00 strict {} 0 {} High-surrogate } - if {$::tcl_platform(byteOrder) eq "littleEndian"} { set endian le } else { @@ -437,6 +501,40 @@ proc testconvert {id body result args} { {*}$args } +proc testprofile {id converter enc profile data result args} { + if {$profile eq "default"} { + testconvert $id.$enc.$profile [list encoding $converter $enc $data] $result {*}$args + if {[set enc [endianUtf $enc]] ne ""} { + # If utf{16,32}-{le,be}, also do utf{16,32} + testconvert $id.$enc.$profile [list encoding $converter $enc $data] $result {*}$args + } + } else { + testconvert $id.$enc.$profile [list encoding $converter -profile $profile $enc $data] $result {*}$args + if {[set enc [endianUtf $enc]] ne ""} { + # If utf{16,32}-{le,be}, also do utf{16,32} + testconvert $id.$enc.$profile [list encoding $converter -profile $profile $enc $data] $result {*}$args + } + } +} + + +# Wrapper for verifying -failindex +proc testfailindex {id converter enc data result {profile default}} { + if {$profile eq "default"} { + testconvert $id.$enc.$profile "list \[encoding $converter -failindex idx $enc $data] \[set idx]" $result + if {[set enc [endianUtf $enc]] ne ""} { + # If utf{16,32}-{le,be}, also do utf{16,32} + testconvert $id.$enc.$profile "list \[encoding $converter -failindex idx $enc $data] \[set idx]" $result + } + } else { + testconvert $id.$enc.$profile "list \[encoding $converter -profile $profile -failindex idx $enc $data] \[set idx]" $result + if {[set enc [endianUtf $enc]] ne ""} { + # If utf{16,32}-{le,be}, also do utf{16,32} + testconvert $id.$enc.$profile "list \[encoding $converter -profile $profile -failindex idx $enc $data] \[set idx]" $result + } + } +} + test cmdAH-4.1.1 {encoding} -returnCodes error -body { encoding } -result {wrong # args: should be "encoding subcommand ?arg ...?"} @@ -492,42 +590,110 @@ testconvert cmdAH-4.3.12 { encoding system $system } -# Wrapper for verifying -failindex -proc testfailindex {id converter enc data result {profile default}} { - if {$profile eq "default"} { - testconvert $id.$enc "list \[encoding $converter -failindex idx $enc $data] \[set idx]" $result - if {[set enc [endianUtf $enc]] ne ""} { - # If utf{16,32}-{le,be}, also do utf{16,32} - testconvert $id.$enc "list \[encoding $converter -failindex idx $enc $data] \[set idx]" $result +# convertfrom, convertfrom -profile + +# convertfrom ?-profile? : All valid byte sequences should be accepted by all profiles +foreach {enc str hex} $encValidStrings { + set bytes [binary decode hex $hex] + set prefix A + set suffix B + set prefix_bytes [encoding convertto $enc A] + set suffix_bytes [encoding convertto $enc B] + foreach profile $encProfiles { + testfailindex cmdAH-4.3.13.$hex.solo convertfrom $enc $bytes [list $str -1] $profile + testfailindex cmdAH-4.3.13.$hex.lead convertfrom $enc $bytes$suffix_bytes [list $str$suffix -1] $profile + testfailindex cmdAH-4.3.13.$hex.tail convertfrom $enc $prefix_bytes$bytes [list $prefix$str -1] $profile + testfailindex cmdAH-4.3.13.$hex.middle convertfrom $enc $prefix_bytes$bytes$suffix_bytes [list $prefix$str$suffix -1] $profile + } +} + +# convertfrom ?-profile? : invalid byte sequences +foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { + set bytes [binary format H* $hex] + set prefix A + set suffix B + set prefixLen [string length [encoding convertto $enc $prefix]] + set result [list $str] + # TODO - if the bad byte is unprintable, tcltest errors out when printing a mismatch + # so glob it out in error message pattern for now. + set errorWithoutPrefix [list "unexpected byte sequence starting at index $failidx: *" -returnCodes error -match glob] + set errorWithPrefix [list "unexpected byte sequence starting at index [expr {$failidx+$prefixLen}]: *" -returnCodes error -match glob] + if {$ctrl eq {} || "solo" in $ctrl} { + if {$failidx == -1} { + set result [list $str] + } else { + set result $errorWithoutPrefix } - } else { - testconvert $id.$enc "list \[encoding $converter -profile $profile -failindex idx $enc $data] \[set idx]" $result - if {[set enc [endianUtf $enc]] ne ""} { - # If utf{16,32}-{le,be}, also do utf{16,32} - testconvert $id.$enc "list \[encoding $converter -profile $profile -failindex idx $enc $data] \[set idx]" $result + testprofile cmdAH-4.3.15.$hex.solo convertfrom $enc $profile $bytes {*}$result + } + if {$ctrl eq {} || "lead" in $ctrl} { + if {$failidx == -1} { + set result [list $str$suffix] + } else { + set result $errorWithoutPrefix + } + testprofile cmdAH-4.3.15.$hex.lead convertfrom $enc $profile $bytes$suffix {*}$result + } + if {$ctrl eq {} || "tail" in $ctrl} { + if {$failidx == -1} { + set result [list $prefix$str] + } else { + set result $errorWithPrefix + } + testprofile cmdAH-4.3.15.$hex.tail convertfrom $enc $profile $prefix$bytes {*}$result + } + if {$ctrl eq {} || "middle" in $ctrl} { + if {$failidx == -1} { + set result [list $prefix$str$suffix] + } else { + set result $errorWithPrefix } + testprofile cmdAH-4.3.15.$hex.middle convertfrom $enc $profile $prefix$bytes$suffix {*}$result } } -# -failindex - valid data -foreach {enc string bytes} $encValidStrings { - testfailindex cmdAH-4.3.13.$enc convertfrom $enc $bytes [list $string -1] - if {"utf-16$endian" eq $enc} { - # utf-16le ->utf-16, utf-32be -> utf32 etc. - set enc [string range $enc 0 5] - testfailindex cmdAH-4.3.13.$enc convertfrom $enc $bytes [list $string -1] +proc printable {s} { + set print "" + foreach c [split $s ""] { + set i [scan $c %c] + if {[string is print $c] && ($i <= 127)} { + append print $c + } elseif {$i <= 0xff} { + append print \\x[format %02X $i] + } elseif {$i <= 0xffff} { + append print \\u[format %04X $i] + } else { + append print \\U[format %08X $i] + } } + return $print } -# -failindex - invalid data for each profile +# convertfrom -failindex - valid data +foreach {enc str hex} $encValidStrings { + set bytes [binary decode hex $hex] + set prefix A + set suffix B + set prefix_bytes [encoding convertto $enc A] + set suffix_bytes [encoding convertto $enc B] + foreach profile $encProfiles { + testfailindex cmdAH-4.3.13.$hex.solo convertfrom $enc $bytes [list $str -1] $profile + testfailindex cmdAH-4.3.13.$hex.lead convertfrom $enc $bytes$suffix_bytes [list $str$suffix -1] $profile + testfailindex cmdAH-4.3.13.$hex.tail convertfrom $enc $prefix_bytes$bytes [list $prefix$str -1] $profile + testfailindex cmdAH-4.3.13.$hex.middle convertfrom $enc $prefix_bytes$bytes$suffix_bytes [list $prefix$str$suffix -1] $profile + } +} + + +# convertfrom -failindex, convertfrom -failindex -profile, invalid data foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { # There are multiple test cases based on location of invalid bytes - set bytes [binary format H* $hex] + set bytes [binary decode hex $hex] set prefix A set suffix B set prefixLen [string length [encoding convertto $enc $prefix]] if {$ctrl eq {} || "solo" in $ctrl} { - testfailindex xxcmdAH-4.3.14.$profile.$hex.solo convertfrom $enc $bytes [list $str $failidx] $profile + testfailindex cmdAH-4.3.14.$hex.solo convertfrom $enc $bytes [list $str $failidx] $profile } if {$ctrl eq {} || "lead" in $ctrl} { if {$failidx == -1} { @@ -537,7 +703,7 @@ foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { # Failure expected set result "" } - testfailindex xxcmdAH-4.3.14.$profile.$hex.lead convertfrom $enc $bytes$suffix [list $result $failidx] $profile + testfailindex cmdAH-4.3.14.$hex.lead convertfrom $enc $bytes$suffix [list $result $failidx] $profile } if {$ctrl eq {} || "tail" in $ctrl} { set expected_failidx $failidx @@ -547,9 +713,9 @@ foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { } else { # Failure expected set result $prefix - incr expected_failidx [string length [encoding convertto $enc $prefix]] + incr expected_failidx $prefixLen } - testfailindex xxcmdAH-4.3.14.$profile.$hex.tail convertfrom $enc $prefix$bytes [list $result $expected_failidx] $profile + testfailindex cmdAH-4.3.14.$hex.tail convertfrom $enc $prefix$bytes [list $result $expected_failidx] $profile } if {$ctrl eq {} || "middle" in $ctrl} { set expected_failidx $failidx @@ -559,53 +725,9 @@ foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { } else { # Failure expected set result $prefix - incr expected_failidx [string length [encoding convertto $enc $prefix]] - } - testfailindex xxcmdAH-4.3.14.$profile.$hex.middle convertfrom $enc $prefix$bytes$suffix [list $result $expected_failidx] $profile - } -} - -# -profile - -# All valid byte sequences should be accepted by all profiles -foreach profile $encProfiles { - set i 0 - foreach {enc string bytes} $encValidStrings { - testconvert cmdAH-4.3.15.$enc.$profile.[incr i] [list encoding convertfrom $enc $bytes] $string - if {"utf-16$endian" eq $enc} { - # utf-16le ->utf-16, utf-32be -> utf32 etc. - set enc [string range $enc 0 5] - testconvert cmdAH-4.3.15.$enc.$profile.[incr i] [list encoding convertfrom $enc $bytes] $string - } - } -} - -# Cycle through the various combinations of encodings and profiles -# for invalid byte sequences -foreach {enc hex profile prefix failidx ctrl comment} $encInvalidBytes { - set bytes [binary format H* $hex] - if {$failidx eq -1} { - set result [list $prefix] - } else { - set badbyte "'\\x[string toupper [binary encode hex [string index $bytes $failidx]]]'" - # TODO - if the bad byte is unprintable, tcltest errors out when printing a mismatch - # so glob it out for now. - set result [list "unexpected byte sequence starting at index $failidx: *" -returnCodes error -match glob] - } - if {$profile eq "default"} { - testconvert cmdAH-4.3.15.$enc.$profile.$hex [list encoding convertfrom $enc $bytes] {*}$result - if {"utf-16$endian" eq $enc} { - # utf-16le ->utf-16, utf-32be -> utf32 etc. - set enc [string range $enc 0 5] - testconvert cmdAH-4.3.15.$enc.$profile.$hex [list encoding convertfrom $enc $bytes] {*}$result - } - } else { - testconvert cmdAH-4.3.15.$enc.$profile.$hex [list encoding convertfrom -profile $profile $enc $bytes] {*}$result - if {"utf-16$endian" eq $enc} { - # utf-16le ->utf-16, utf-32be -> utf32 etc. - set enc [string range $enc 0 5] - testconvert cmdAH-4.3.15.$enc.$profile.$hex [list encoding convertfrom -profile $profile $enc $bytes] {*}$result + incr expected_failidx $prefixLen } + testfailindex cmdAH-4.3.14.$hex.middle convertfrom $enc $prefix$bytes$suffix [list $result $expected_failidx] $profile } } @@ -646,41 +768,67 @@ testconvert cmdAH-4.4.12 { # -failindex - valid data foreach {enc string bytes} $encValidStrings { testfailindex cmdAH-4.4.13.$enc convertto $enc $string [list $bytes -1] - if {"utf-16$endian" eq $enc} { - # utf-16le ->utf-16, utf-32be -> utf32 etc. - set enc [string range $enc 0 5] - testfailindex cmdAH-4.4.13.$enc convertto $enc $string [list $bytes -1] - } } # -failindex - invalid data -foreach {enc string profile bytes failidx tag} $encUnencodableStrings { - testfailindex cmdAH-4.4.14.$enc.$profile.$tag convertto $enc $string [list $bytes $failidx] $profile - if {"utf-16$endian" eq $enc} { - # utf-16le ->utf-16, utf-32be -> utf32 etc. - set enc [string range $enc 0 5] - testfailindex cmdAH-4.4.14.$enc.$profile.$tag convertto $enc $string [list $bytes $failidx] $profile +foreach {enc string profile hex failidx ctrl comment} $encUnencodableStrings { + set bytes [binary decode hex $hex] + set prefix A + set suffix B + set prefixLen [string length [encoding convertto $enc $prefix]] + if {$ctrl eq {} || "solo" in $ctrl} { + testfailindex cmdAH-4.4.14.$string.solo convertto $enc $string [list $bytes $failidx] $profile + } + if {$ctrl eq {} || "lead" in $ctrl} { + if {$failidx == -1} { + # If success expected + set result $bytes$suffix + } else { + # Failure expected + set result "" + } + testfailindex cmdAH-4.4.14.$string.lead convertto $enc $string$suffix [list $result $failidx] $profile + } + if {$ctrl eq {} || "tail" in $ctrl} { + set expected_failidx $failidx + if {$failidx == -1} { + # If success expected + set result $prefix$bytes + } else { + # Failure expected + set result $prefix + incr expected_failidx $prefixLen + } + testfailindex cmdAH-4.4.14.$string.tail convertto $enc $prefix$string [list $result $expected_failidx] $profile + } + if {$ctrl eq {} || "middle" in $ctrl} { + set expected_failidx $failidx + if {$failidx == -1} { + # If success expected + set result $prefix$bytes$suffix + } else { + # Failure expected + set result $prefix + incr expected_failidx $prefixLen + } + testfailindex cmdAH-4.4.14.$string.middle convertto $enc $prefix$string$suffix [list $result $expected_failidx] $profile } } -# -profile +# convertto -profile # All valid byte sequences should be accepted by all profiles foreach profile $encProfiles { set i 0 foreach {enc string bytes} $encValidStrings { - testconvert cmdAH-4.4.15.$enc.$profile.[incr i] [list encoding convertto $enc $string] $bytes - if {"utf-16$endian" eq $enc} { - # utf-16le ->utf-16, utf-32be -> utf32 etc. - set enc [string range $enc 0 5] - testconvert cmdAH-4.4.15.$enc.$profile.[incr i] [list encoding convertto $enc $string] $bytes - } + testprofile cmdAH-4.4.15 convertto $enc $profile $string $bytes } } # Cycle through the various combinations of encodings and profiles # for invalid byte sequences -foreach {enc string profile bytes failidx tag} $encUnencodableStrings { +foreach {enc string profile hex failidx ctrl comment} $encUnencodableStrings { + set bytes [binary decode hex $hex] if {$failidx eq -1} { set result [list $bytes] } else { @@ -688,19 +836,20 @@ foreach {enc string profile bytes failidx tag} $encUnencodableStrings { # so glob it out for now. set result [list "unexpected character at index $failidx: *" -returnCodes error -match glob] } + #testprofile xx convertto $enc $profile $string {*}$result if {$profile eq "default"} { - testconvert cmdAH-4.4.15.$enc.$profile.$tag [list encoding convertto $enc $string] {*}$result + # testconvert cmdAH-4.4.15.$enc.$profile.$tag [list encoding convertto $enc $string] {*}$result if {"utf-16$endian" eq $enc} { # utf-16le ->utf-16, utf-32be -> utf32 etc. set enc [string range $enc 0 5] - testconvert cmdAH-4.4.15.$enc.$profile.$tag [list encoding convertto $enc $string] {*}$result + # xxtestconvert cmdAH-4.4.15.$enc.$profile.$tag [list encoding convertto $enc $string] {*}$result } } else { - testconvert cmdAH-4.4.15.$enc.$profile.$tag [list encoding convertto -profile $profile $enc $string] {*}$result + # testconvert cmdAH-4.4.15.$enc.$profile.$tag [list encoding convertto -profile $profile $enc $string] {*}$result if {"utf-16$endian" eq $enc} { # utf-16le ->utf-16, utf-32be -> utf32 etc. set enc [string range $enc 0 5] - testconvert cmdAH-4.4.15.$enc.$profile.$tag [list encoding convertto -profile $profile $enc $string] {*}$result + # testconvert cmdAH-4.4.15.$enc.$profile.$tag [list encoding convertto -profile $profile $enc $string] {*}$result } } } -- cgit v0.12 From 6d674a96a1b99426cabf17e5b52272399c73e8bc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 16 Feb 2023 21:29:07 +0000 Subject: Final part of [10c2c17c32]: UTF-LE32 encoder mapping of surrogates. Problem was in testcase, not in actual code --- tests/encoding.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tests/encoding.test b/tests/encoding.test index ed41937..a46fa5f 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -525,9 +525,9 @@ test encoding-16.13 {Utf16ToUtfProc} -body { test encoding-16.14 {Utf16ToUtfProc} -body { encoding convertfrom utf-16le \x00\xDC } -result \uDC00 -test encoding-16.15 {Utf16ToUtfProc} -constraints knownBug -body { +test encoding-16.15 {Utf16ToUtfProc} -body { encoding convertfrom utf-16le \x00\xD8\x00\xDC -} -result \uD800\uDC00 +} -result \U010000 test encoding-16.16 {Utf16ToUtfProc} -body { encoding convertfrom utf-16le \x00\xDC\x00\xD8 } -result \uDC00\uD800 -- cgit v0.12 From 45796af99db14504cedf31f0336e108930482ebf Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 16 Feb 2023 21:50:53 +0000 Subject: complete fix --- generic/tclEncoding.c | 10 +++++----- tests/encoding.test | 4 ++-- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index fe78e03..1d3a3eb 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2417,14 +2417,14 @@ UtfToUtfProc( result = TCL_CONVERT_MULTIBYTE; break; } - if (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) || (flags & ENCODING_FAILINDEX)) { - result = TCL_CONVERT_SYNTAX; - break; - } + if (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) || (flags & ENCODING_FAILINDEX)) { + result = TCL_CONVERT_SYNTAX; + break; + } } char chbuf[2]; chbuf[0] = UCHAR(*src++); chbuf[1] = 0; - Tcl_UtfToUniChar(chbuf, &ch); + TclUtfToUCS4(chbuf, &ch); dst += Tcl_UniCharToUtf(ch, dst); } else { int low; diff --git a/tests/encoding.test b/tests/encoding.test index 1b41925..03f0273 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -849,10 +849,10 @@ test encoding-24.41 {Parse invalid utf-8 with -strict} -body { } -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xED'} test encoding-24.42 {Parse invalid utf-8, fallback to cp1252 [885c86a9a0]} -body { encoding convertfrom -nocomplain utf-8 \xF0\x80\x80\x80 -} -result \xF0\u20AC\u20AC\u20AC€€ +} -result \xF0\u20AC\u20AC\u20AC test encoding-24.43 {Parse invalid utf-8, fallback to cp1252 [885c86a9a0]} -body { encoding convertfrom -nocomplain utf-8 \x80 -} -result \u20AC€€ +} -result \u20AC file delete [file join [temporaryDirectory] iso2022.txt] -- cgit v0.12 From fdbb12eced9b528f6246424cf0916b620f1783bc Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 17 Feb 2023 18:59:28 +0000 Subject: Part way through utf-8 test equivalence classes --- generic/tclEncoding.c | 4 +- library/tcltest/tcltest.tcl | 37 +++- tests/cmdAH.test | 503 +++++++++++++++++++++++++++----------------- 3 files changed, 342 insertions(+), 202 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index a11e696..4d5743c 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2525,10 +2525,8 @@ UtfToUtfProc( src = saveSrc; break; } - if (0 && PROFILE_REPLACE(profile)) { + if (PROFILE_REPLACE(profile)) { ch = UNICODE_REPLACE_CHAR; - src += len; - // dst += Tcl_UniCharToUtf(ch, dst); } else { low = ch; diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 94010a7..9ca7b09 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -1134,6 +1134,39 @@ proc tcltest::SafeFetch {n1 n2 op} { } } + +# tcltest::Asciify -- +# +# Transforms the passed string to contain only printable ascii characters. +# Useful for printing to terminals. Non-printables are mapped to +# \x, \u or \U sequences. +# +# Arguments: +# s - string to transform +# +# Results: +# The transformed strings +# +# Side effects: +# None. + +proc tcltest::Asciify {s} { + set print "" + foreach c [split $s ""] { + set i [scan $c %c] + if {[string is print $c] && ($i <= 127)} { + append print $c + } elseif {$i <= 0xff} { + append print \\x[format %02X $i] + } elseif {$i <= 0xffff} { + append print \\u[format %04X $i] + } else { + append print \\U[format %08X $i] + } + } + return $print +} + # tcltest::ConstraintInitializer -- # # Get or set a script that when evaluated in the tcltest namespace @@ -2222,12 +2255,12 @@ proc tcltest::test {name description args} { puts [outputChannel] "---- Error testing result: $scriptMatch" } else { try { - puts [outputChannel] "---- Result was:\n$actualAnswer" + puts [outputChannel] "---- Result was:\n[Asciify $actualAnswer]" } on error {errMsg errCode} { puts [outputChannel] "---- Result was:\n" } puts [outputChannel] "---- Result should have been\ - ($match matching):\n$result" + ($match matching):\n[Asciify $result]" } } if {$errorCodeFailure} { diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 6386658..df28b2e 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -181,6 +181,7 @@ set "numargErrors(encoding names)" {wrong # args: should be "encoding names"} set "numargErrors(encoding profiles)" {wrong # args: should be "encoding profiles"} set encProfiles {tcl8 strict replace} +set encDefaultProfile tcl8; # Should reflect the default from implementation # TODO - valid sequences for different encodings - shiftjis etc. # Note utf-16, utf-32 missing because they are automatically @@ -218,43 +219,41 @@ set encValidStrings { # 80-9F which is treated as cp1252. # This tests the TableToUtfProc code path. lappend encInvalidBytes {*}{ - ascii 80 default \u20AC -1 {knownBug} {map to cp1252} ascii 80 tcl8 \u20AC -1 {knownBug} {map to cp1252} ascii 80 replace \uFFFD -1 {} {Smallest invalid byte} ascii 80 strict {} 0 {} {Smallest invalid byte} - ascii 81 default \u0081 -1 {knownBug} {map to cp1252} - ascii 82 default \u201A -1 {knownBug} {map to cp1252} - ascii 83 default \u0192 -1 {knownBug} {map to cp1252} - ascii 84 default \u201E -1 {knownBug} {map to cp1252} - ascii 85 default \u2026 -1 {knownBug} {map to cp1252} - ascii 86 default \u2020 -1 {knownBug} {map to cp1252} - ascii 87 default \u2021 -1 {knownBug} {map to cp1252} - ascii 88 default \u0276 -1 {knownBug} {map to cp1252} - ascii 89 default \u2030 -1 {knownBug} {map to cp1252} - ascii 8A default \u0160 -1 {knownBug} {map to cp1252} - ascii 8B default \u2039 -1 {knownBug} {map to cp1252} - ascii 8C default \u0152 -1 {knownBug} {map to cp1252} - ascii 8D default \u008D -1 {knownBug} {map to cp1252} - ascii 8E default \u017D -1 {knownBug} {map to cp1252} - ascii 8F default \u008F -1 {knownBug} {map to cp1252} - ascii 90 default \u0090 -1 {knownBug} {map to cp1252} - ascii 91 default \u2018 -1 {knownBug} {map to cp1252} - ascii 92 default \u2019 -1 {knownBug} {map to cp1252} - ascii 93 default \u201C -1 {knownBug} {map to cp1252} - ascii 94 default \u201D -1 {knownBug} {map to cp1252} - ascii 95 default \u2022 -1 {knownBug} {map to cp1252} - ascii 96 default \u2013 -1 {knownBug} {map to cp1252} - ascii 97 default \u2014 -1 {knownBug} {map to cp1252} - ascii 98 default \u02DC -1 {knownBug} {map to cp1252} - ascii 99 default \u2122 -1 {knownBug} {map to cp1252} - ascii 9A default \u0161 -1 {knownBug} {map to cp1252} - ascii 9B default \u203A -1 {knownBug} {map to cp1252} - ascii 9C default \u0153 -1 {knownBug} {map to cp1252} - ascii 9D default \u009D -1 {knownBug} {map to cp1252} - ascii 9E default \u017E -1 {knownBug} {map to cp1252} - ascii 9F default \u0178 -1 {knownBug} {map to cp1252} - - ascii FF default \u00FF -1 {} {Largest invalid byte} + ascii 81 tcl8 \u0081 -1 {knownBug} {map to cp1252} + ascii 82 tcl8 \u201A -1 {knownBug} {map to cp1252} + ascii 83 tcl8 \u0192 -1 {knownBug} {map to cp1252} + ascii 84 tcl8 \u201E -1 {knownBug} {map to cp1252} + ascii 85 tcl8 \u2026 -1 {knownBug} {map to cp1252} + ascii 86 tcl8 \u2020 -1 {knownBug} {map to cp1252} + ascii 87 tcl8 \u2021 -1 {knownBug} {map to cp1252} + ascii 88 tcl8 \u0276 -1 {knownBug} {map to cp1252} + ascii 89 tcl8 \u2030 -1 {knownBug} {map to cp1252} + ascii 8A tcl8 \u0160 -1 {knownBug} {map to cp1252} + ascii 8B tcl8 \u2039 -1 {knownBug} {map to cp1252} + ascii 8C tcl8 \u0152 -1 {knownBug} {map to cp1252} + ascii 8D tcl8 \u008D -1 {knownBug} {map to cp1252} + ascii 8E tcl8 \u017D -1 {knownBug} {map to cp1252} + ascii 8F tcl8 \u008F -1 {knownBug} {map to cp1252} + ascii 90 tcl8 \u0090 -1 {knownBug} {map to cp1252} + ascii 91 tcl8 \u2018 -1 {knownBug} {map to cp1252} + ascii 92 tcl8 \u2019 -1 {knownBug} {map to cp1252} + ascii 93 tcl8 \u201C -1 {knownBug} {map to cp1252} + ascii 94 tcl8 \u201D -1 {knownBug} {map to cp1252} + ascii 95 tcl8 \u2022 -1 {knownBug} {map to cp1252} + ascii 96 tcl8 \u2013 -1 {knownBug} {map to cp1252} + ascii 97 tcl8 \u2014 -1 {knownBug} {map to cp1252} + ascii 98 tcl8 \u02DC -1 {knownBug} {map to cp1252} + ascii 99 tcl8 \u2122 -1 {knownBug} {map to cp1252} + ascii 9A tcl8 \u0161 -1 {knownBug} {map to cp1252} + ascii 9B tcl8 \u203A -1 {knownBug} {map to cp1252} + ascii 9C tcl8 \u0153 -1 {knownBug} {map to cp1252} + ascii 9D tcl8 \u009D -1 {knownBug} {map to cp1252} + ascii 9E tcl8 \u017E -1 {knownBug} {map to cp1252} + ascii 9F tcl8 \u0178 -1 {knownBug} {map to cp1252} + ascii FF tcl8 \u00FF -1 {} {Largest invalid byte} ascii FF replace \uFFFD -1 {} {Largest invalid byte} ascii FF strict {} 0 {} {Largest invalid byte} @@ -279,121 +278,188 @@ lappend encInvalidBytes {*}{ # (UtfToUtfProc). # Note C0, C1, F5:FF are invalid bytes ANYWHERE. Exception is C080 lappend encInvalidBytes {*}{ - utf-8 80 default \u20AC -1 {knownBug} {map to cp1252} + utf-8 80 tcl8 \u20AC -1 {knownBug} {map to cp1252} utf-8 80 tcl8 \u20AC -1 {knownBug} {map to cp1252} utf-8 80 replace \uFFFD -1 {} {Smallest invalid byte} utf-8 80 strict {} 0 {} {Smallest invalid byte} - utf-8 81 default \u0081 -1 {knownBug} {map to cp1252} - utf-8 82 default \u201A -1 {knownBug} {map to cp1252} - utf-8 83 default \u0192 -1 {knownBug} {map to cp1252} - utf-8 84 default \u201E -1 {knownBug} {map to cp1252} - utf-8 85 default \u2026 -1 {knownBug} {map to cp1252} - utf-8 86 default \u2020 -1 {knownBug} {map to cp1252} - utf-8 87 default \u2021 -1 {knownBug} {map to cp1252} - utf-8 88 default \u0276 -1 {knownBug} {map to cp1252} - utf-8 89 default \u2030 -1 {knownBug} {map to cp1252} - utf-8 8A default \u0160 -1 {knownBug} {map to cp1252} - utf-8 8B default \u2039 -1 {knownBug} {map to cp1252} - utf-8 8C default \u0152 -1 {knownBug} {map to cp1252} - utf-8 8D default \u008D -1 {knownBug} {map to cp1252} - utf-8 8E default \u017D -1 {knownBug} {map to cp1252} - utf-8 8F default \u008F -1 {knownBug} {map to cp1252} - utf-8 90 default \u0090 -1 {knownBug} {map to cp1252} - utf-8 91 default \u2018 -1 {knownBug} {map to cp1252} - utf-8 92 default \u2019 -1 {knownBug} {map to cp1252} - utf-8 93 default \u201C -1 {knownBug} {map to cp1252} - utf-8 94 default \u201D -1 {knownBug} {map to cp1252} - utf-8 95 default \u2022 -1 {knownBug} {map to cp1252} - utf-8 96 default \u2013 -1 {knownBug} {map to cp1252} - utf-8 97 default \u2014 -1 {knownBug} {map to cp1252} - utf-8 98 default \u02DC -1 {knownBug} {map to cp1252} - utf-8 99 default \u2122 -1 {knownBug} {map to cp1252} - utf-8 9A default \u0161 -1 {knownBug} {map to cp1252} - utf-8 9B default \u203A -1 {knownBug} {map to cp1252} - utf-8 9C default \u0153 -1 {knownBug} {map to cp1252} - utf-8 9D default \u009D -1 {knownBug} {map to cp1252} - utf-8 9E default \u017E -1 {knownBug} {map to cp1252} - utf-8 9F default \u0178 -1 {knownBug} {map to cp1252} - - utf-8 C0 default \u00C0 -1 {} {C0 is invalid anywhere} + utf-8 81 tcl8 \u0081 -1 {knownBug} {map to cp1252} + utf-8 82 tcl8 \u201A -1 {knownBug} {map to cp1252} + utf-8 83 tcl8 \u0192 -1 {knownBug} {map to cp1252} + utf-8 84 tcl8 \u201E -1 {knownBug} {map to cp1252} + utf-8 85 tcl8 \u2026 -1 {knownBug} {map to cp1252} + utf-8 86 tcl8 \u2020 -1 {knownBug} {map to cp1252} + utf-8 87 tcl8 \u2021 -1 {knownBug} {map to cp1252} + utf-8 88 tcl8 \u0276 -1 {knownBug} {map to cp1252} + utf-8 89 tcl8 \u2030 -1 {knownBug} {map to cp1252} + utf-8 8A tcl8 \u0160 -1 {knownBug} {map to cp1252} + utf-8 8B tcl8 \u2039 -1 {knownBug} {map to cp1252} + utf-8 8C tcl8 \u0152 -1 {knownBug} {map to cp1252} + utf-8 8D tcl8 \u008D -1 {knownBug} {map to cp1252} + utf-8 8E tcl8 \u017D -1 {knownBug} {map to cp1252} + utf-8 8F tcl8 \u008F -1 {knownBug} {map to cp1252} + utf-8 90 tcl8 \u0090 -1 {knownBug} {map to cp1252} + utf-8 91 tcl8 \u2018 -1 {knownBug} {map to cp1252} + utf-8 92 tcl8 \u2019 -1 {knownBug} {map to cp1252} + utf-8 93 tcl8 \u201C -1 {knownBug} {map to cp1252} + utf-8 94 tcl8 \u201D -1 {knownBug} {map to cp1252} + utf-8 95 tcl8 \u2022 -1 {knownBug} {map to cp1252} + utf-8 96 tcl8 \u2013 -1 {knownBug} {map to cp1252} + utf-8 97 tcl8 \u2014 -1 {knownBug} {map to cp1252} + utf-8 98 tcl8 \u02DC -1 {knownBug} {map to cp1252} + utf-8 99 tcl8 \u2122 -1 {knownBug} {map to cp1252} + utf-8 9A tcl8 \u0161 -1 {knownBug} {map to cp1252} + utf-8 9B tcl8 \u203A -1 {knownBug} {map to cp1252} + utf-8 9C tcl8 \u0153 -1 {knownBug} {map to cp1252} + utf-8 9D tcl8 \u009D -1 {knownBug} {map to cp1252} + utf-8 9E tcl8 \u017E -1 {knownBug} {map to cp1252} + utf-8 9F tcl8 \u0178 -1 {knownBug} {map to cp1252} + utf-8 C0 tcl8 \u00C0 -1 {} {C0 is invalid anywhere} utf-8 C0 strict {} 0 {} {C0 is invalid anywhere} utf-8 C0 replace \uFFFD -1 {} {C0 is invalid anywhere} - utf-8 C080 default \u0000 -1 {} {C080 -> U+0 in Tcl's internal modified UTF8} utf-8 C080 tcl8 \u0000 -1 {} {C080 -> U+0 in Tcl's internal modified UTF8} utf-8 C080 strict {} 0 {} {C080 -> invalid} utf-8 C080 replace \uFFFD -1 {} {C080 -> single replacement char} - utf-8 C1 default \u00C1 -1 {} {C1 is invalid everywhere} utf-8 C1 tcl8 \u00C1 -1 {} {C1 is invalid everywhere} utf-8 C1 replace \uFFFD -1 {} {C1 is invalid everywhere} utf-8 C1 strict {} 0 {} {C1 is invalid everywhere} - utf-8 C1 default \u00C1 -1 {} {Require valid trail byte} - utf-8 C1 tcl8 \u00C1 -1 {} {Require valid trail byte} - utf-8 C1 replace \uFFFD -1 {} {Require valid trail byte} - utf-8 C1 strict {} 0 {} {Require valid trail byte} - + utf-8 C2 tcl8 \u00C2 -1 {} {Missing trail byte} + utf-8 C2 replace \uFFFD -1 {} {Missing trail byte} + utf-8 C2 strict {} 0 {} {Missing trail byte} + utf-8 C27F tcl8 \u00C2\x7F -1 {} {Trail byte must be 80:BF} + utf-8 C27F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} + utf-8 C27F strict {} 0 {} {Trail byte must be 80:BF} + utf-8 DF tcl8 \u00DF -1 {} {Missing trail byte} + utf-8 DF replace \uFFFD -1 {} {Missing trail byte} + utf-8 DF strict {} 0 {} {Missing trail byte} + utf-8 DF7F tcl8 \u00DF\x7F -1 {} {Trail byte must be 80:BF} + utf-8 DF7F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} + utf-8 DF7F strict {} 0 {} {Trail byte must be 80:BF} + utf-8 DFE0A080 tcl8 \u00DF\u0800 -1 {} {Invalid trail byte is start of valid sequence} + utf-8 DFE0A080 replace \uFFFD\u0800 -1 {} {Invalid trail byte is start of valid sequence} + utf-8 DFE0A080 strict {} 0 {} {Invalid trail byte is start of valid sequence} + + utf-8 E0 tcl8 \u00E0 -1 {} {Missing trail byte} + utf-8 E0 replace \uFFFD -1 {} {Missing trail byte} + utf-8 E0 strict {} 0 {} {Missing trail byte} + utf-8 E080 tcl8 \u00E0\u20AC -1 {knownBug} {First trail byte must be A0:BF} + utf-8 E080 replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF} + utf-8 E080 strict {} 0 {} {First trail byte must be A0:BF} + utf-8 E09F tcl8 \u00E0\u0178 -1 {knownBug} {First trail byte must be A0:BF} + utf-8 E09F replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF} + utf-8 E09F strict {} 0 {} {First trail byte must be A0:BF} + utf-8 E0A07F tcl8 \u00E0\u00A0\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 E0A07F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 E0A07F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 E0BF7F tcl8 \u00E0\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 E0BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 E0BF7F strict {} 0 {} {Second trail byte must be 80:BF} + + utf-8 E1 tcl8 \u00E1 -1 {} {Missing trail byte} + utf-8 E1 replace \uFFFD -1 {} {Missing trail byte} + utf-8 E1 strict {} 0 {} {Missing trail byte} + utf-8 E17F tcl8 \u00E1\x7F -1 {} {Trail byte must be 80:BF} + utf-8 E17F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} + utf-8 E17F strict {} 0 {} {Trail byte must be 80:BF} + utf-8 E1807F tcl8 \u00E1\u20AC\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 E1807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 E1807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 E1BF7F tcl8 \u00E1\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 E1BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 E1BF7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 EC tcl8 \u00EC -1 {} {Missing trail byte} + utf-8 EC replace \uFFFD -1 {} {Missing trail byte} + utf-8 EC strict {} 0 {} {Missing trail byte} + utf-8 EC7F tcl8 \u00EC\x7F -1 {} {Trail byte must be 80:BF} + utf-8 EC7F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} + utf-8 EC7F strict {} 0 {} {Trail byte must be 80:BF} + utf-8 EC807F tcl8 \u00EC\u20AC\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 EC807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 EC807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 ECBF7F tcl8 \u00EC\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 ECBF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 ECBF7F strict {} 0 {} {Second trail byte must be 80:BF} + + utf-8 ED tcl8 \u00ED -1 {} {Missing trail byte} + utf-8 ED replace \uFFFD -1 {} {Missing trail byte} + utf-8 ED strict {} 0 {} {Missing trail byte} + utf-8 ED7F tcl8 \u00ED\u7F -1 {knownBug} {First trail byte must be 80:9F} + utf-8 ED7F replace \uFFFD\u7F -1 {} {First trail byte must be 80:9F} + utf-8 ED7F strict {} 0 {} {First trail byte must be 80:9F} + utf-8 EDA0 tcl8 \u00ED\u00A0 -1 {knownBug} {First trail byte must be 80:9F} + utf-8 EDA0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:9F} + utf-8 EDA0 strict {} 0 {} {First trail byte must be 80:9F} + utf-8 ED807F tcl8 \u00ED\u20AC\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 ED807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 ED807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 ED9F7F tcl8 \u00ED\u0178\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 ED9F7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 ED9F7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 EDA080 tcl8 \uD800 -1 {} {High surrogate} + utf-8 EDA080 replace \uFFFD -1 {} {High surrogate} + utf-8 EDA080 strict {} 0 {} {High surrogate} + utf-8 EDAFBF tcl8 \uDBFF -1 {} {High surrogate} + utf-8 EDAFBF replace \uFFFD -1 {} {High surrogate} + utf-8 EDAFBF strict {} 0 {} {High surrogate} + utf-8 EDB080 tcl8 \uDC00 -1 {} {Low surrogate} + utf-8 EDB080 replace \uFFFD -1 {} {Low surrogate} + utf-8 EDB080 strict {} 0 {} {Low surrogate} + utf-8 EDBFBF tcl8 \uDFFF -1 {} {Low surrogate} + utf-8 EDBFBF replace \uFFFD -1 {} {Low surrogate} + utf-8 EDBFBF strict {} 0 {} {Low surrogate} + utf-8 EDA080EDB080 tcl8 \U00010000 -1 {} {High low surrogate pair} + utf-8 EDA080EDB080 replace \uFFFD\uFFFD -1 {} {High low surrogate pair} + utf-8 EDA080EDB080 strict {} 0 {} {High low surrogate pair} + utf-8 EDAFBFEDBFBF tcl8 \U0010FFFF -1 {} {High low surrogate pair} + utf-8 EDAFBFEDBFBF replace \uFFFD\uFFFD -1 {} {High low surrogate pair} + utf-8 EDAFBFEDBFBF strict {} 0 {} {High low surrogate pair} - utf-8 F5 default \u00F5 -1 {} {F5:FF are invalid everywhere} utf-8 F5 tcl8 \u00F5 -1 {} {F5:FF are invalid everywhere} utf-8 F5 replace \uFFFD -1 {} {F5:FF are invalid everywhere} utf-8 F5 strict {} 0 {} {F5:FF are invalid everywhere} - utf-8 FF default \u00FF -1 {} {F5:FF are invalid everywhere} utf-8 FF tcl8 \u00FF -1 {} {F5:FF are invalid everywhere} utf-8 FF replace \uFFFD -1 {} {F5:FF are invalid everywhere} utf-8 FF strict {} 0 {} {F5:FF are invalid everywhere} utf-8 C0AFE080BFF0818130 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {} {Unicode Table 3-8} - utf-8 EDA080EDBFBFEDAF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {knownBug} {Unicode Table 3-9} + utf-8 EDA080EDBFBFEDAF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {knownW3C} {Unicode Table 3-9} utf-8 F4919293FF4180BF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\u0041\uFFFD\uFFFD\x30 -1 {} {Unicode Table 3-10} - utf-8 E180E2F09192F1BF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {knownBug} {Unicode Table 3.11} + utf-8 E180E2F09192F1BF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {knownW3C} {Unicode Table 3.11} } set xxencInvalidBytes { - utf-8 \x41\x80\x42 default A\u0080B -1 80 utf-8 \x41\x80\x42 tcl8 A\u0080B -1 80 utf-8 \x41\x80\x42 replace A\uFFFDB -1 80 utf-8 \x41\x80\x42 strict A 1 80 - utf-8 \x41\xC0\x80\x42 default A\u0000B -1 C080 utf-8 \x41\xC0\x80\x42 tcl8 A\u0000B -1 C080 utf-8 \x41\xC0\x80\x42 strict A 1 C080 - utf-8 \x41\xC1\x42 default A\u00C1B -1 C1 utf-8 \x41\xC1\x42 tcl8 A\u00C1B -1 C1 utf-8 \x41\xC1\x42 replace A\uFFFDB -1 C1 utf-8 \x41\xC1\x42 strict A 1 C1 - utf-8 \x41\xC2\x42 default A\u00C2B -1 C2-nontrail utf-8 \x41\xC2\x42 tcl8 A\u00C2B -1 C2-nontrail utf-8 \x41\xC2\x42 replace A\uFFFDB -1 C2-nontrail utf-8 \x41\xC2\x42 strict A 1 C2-nontrail - utf-8 \x41\xC2 default A\u00C2 -1 C2-incomplete utf-8 \x41\xC2 tcl8 A\u00C2 -1 C2-incomplete utf-8 \x41\xC2 replace A\uFFFD -1 C2-incomplete utf-8 \x41\xC2 strict A 1 C2-incomplete - utf-8 A\xed\xa0\x80B default A\uD800B -1 High-surrogate utf-8 A\xed\xa0\x80B tcl8 A\uD800B -1 High-surrogate utf-8 A\xed\xa0\x80B strict A 1 High-surrogate - utf-8 A\xed\xb0\x80B default A\uDC00B -1 Low-surrogate utf-8 A\xed\xb0\x80B tcl8 A\uDC00B -1 Low-surrogate utf-8 A\xed\xb0\x80B strict A 1 Low-surrogate - utf-8 \xed\xa0\x80\xed\xb0\x80 default \U00010000 -1 High-low-surrogate utf-8 \xed\xa0\x80\xed\xb0\x80 tcl8 \U00010000 -1 High-low-surrogate utf-8 \xed\xa0\x80\xed\xb0\x80 strict {} 0 High-low-surrogate } set utf32-le-TODO { - utf-32le \x00\xD8\x00\x00 default \uD800 -1 {High-surrogate} utf-32le \x00\xD8\x00\x00 tcl8 \uD800 -1 {High-surrogate} utf-32le \x00\xD8\x00\x00 strict "" 0 {High-surrogate} - utf-32le \x00\xDC\x00\x00 default \uDC00 -1 {Low-surrogate} utf-32le \x00\xDC\x00\x00 tcl8 \uDC00 -1 {Low-surrogate} utf-32le \x00\xDC\x00\x00 strict "" 0 {Low-surrogate} - utf-32le \x00\xD8\x00\x00\x00\xDC\x00\x00 default \uD800\uDC00 -1 {High-low-surrogate} utf-32le \x00\xD8\x00\x00\x00\xDC\x00\x00 tcl8 \uD800\uDC00 -1 {High-low-surrogate} utf-32le \x00\xD8\x00\x00\x00\xDC\x00\x00 strict "" 0 {High-low-surrogate} - utf-32le \x00\xDC\x00\x00\x00\xD8\x00\x00 default \uDC00\uD800 -1 {High-low-surrogate} utf-32le \x00\xDC\x00\x00\x00\xD8\x00\x00 tcl8 \uDC00\uD800 -1 {High-low-surrogate} utf-32le \x00\xDC\x00\x00\x00\xD8\x00\x00 strict "" 0 {High-low-surrogate} - utf-32le \x41\x00\x00\x00\x00\xD8\x00\x00\x42\x00\x00\x00 default A\uD800B -1 {High-surrogate-middle} utf-32le \x41\x00\x00\x00\x00\xD8\x00\x00\x42\x00\x00\x00 tcl8 A\uD800B -1 {High-surrogate-middle} utf-32le \x41\x00\x00\x00\x00\xD8\x00\x00\x42\x00\x00\x00 strict A 4 {High-surrogate-middle} } @@ -416,18 +482,14 @@ set utf32-le-TODO { # TODO - other encodings and test cases # TODO - out of range code point (note cannot be generated by \U notation) set encUnencodableStrings { - ascii \u00e0 default 3f -1 {} {unencodable} ascii \u00e0 tcl8 3f -1 {} {unencodable} ascii \u00e0 strict {} 0 {} {unencodable} - iso8859-1 \u0141 default 3f -1 {} unencodable iso8859-1 \u0141 tcl8 3f -1 {} unencodable iso8859-1 \u0141 strict {} 0 {} unencodable - utf-8 \uD800 default eda080 -1 {} High-surrogate utf-8 \uD800 tcl8 eda080 -1 {} High-surrogate utf-8 \uD800 strict {} 0 {} High-surrogate - utf-8 \uDC00 default edb080 -1 {} High-surrogate utf-8 \uDC00 tcl8 edb080 -1 {} High-surrogate utf-8 \uDC00 strict {} 0 {} High-surrogate } @@ -453,6 +515,24 @@ proc endianUtf {enc} { return "" } +# Map arbitrary strings to printable form in ASCII. +proc printable {s} { + set print "" + foreach c [split $s ""] { + set i [scan $c %c] + if {[string is print $c] && ($i <= 127)} { + append print $c + } elseif {$i <= 0xff} { + append print \\x[format %02X $i] + } elseif {$i <= 0xffff} { + append print \\u[format %04X $i] + } else { + append print \\U[format %08X $i] + } + } + return $print +} + # # Check errors for invalid number of arguments proc badnumargs {id cmd cmdargs} { @@ -501,36 +581,45 @@ proc testconvert {id body result args} { {*}$args } +# Wrapper to verify encoding convert{to,from} ?-profile? +# Generates tests for compiled and uncompiled implementation. +# Also generates utf-{16,32} tests if passed encoding is utf-{16,32}{le,be} +# The enc and profile are appended to id to generate the test id proc testprofile {id converter enc profile data result args} { - if {$profile eq "default"} { - testconvert $id.$enc.$profile [list encoding $converter $enc $data] $result {*}$args - if {[set enc [endianUtf $enc]] ne ""} { - # If utf{16,32}-{le,be}, also do utf{16,32} - testconvert $id.$enc.$profile [list encoding $converter $enc $data] $result {*}$args - } - } else { - testconvert $id.$enc.$profile [list encoding $converter -profile $profile $enc $data] $result {*}$args - if {[set enc [endianUtf $enc]] ne ""} { + testconvert $id.$enc.$profile [list encoding $converter -profile $profile $enc $data] $result {*}$args + if {[set enc2 [endianUtf $enc]] ne ""} { + # If utf{16,32}-{le,be}, also do utf{16,32} + testconvert $id.$enc2.$profile [list encoding $converter -profile $profile $enc2 $data] $result {*}$args + } + + # If this is the default profile, generate a test without specifying profile + if {$profile eq $::encDefaultProfile} { + testconvert $id.$enc.default [list encoding $converter $enc $data] $result {*}$args + if {[set enc2 [endianUtf $enc]] ne ""} { # If utf{16,32}-{le,be}, also do utf{16,32} - testconvert $id.$enc.$profile [list encoding $converter -profile $profile $enc $data] $result {*}$args + testconvert $id.$enc2.default [list encoding $converter $enc2 $data] $result {*}$args } } } -# Wrapper for verifying -failindex +# Wrapper to verify encoding convert{to,from} -failindex ?-profile? +# Generates tests for compiled and uncompiled implementation. +# Also generates utf-{16,32} tests if passed encoding is utf-{16,32}{le,be} +# The enc and profile are appended to id to generate the test id proc testfailindex {id converter enc data result {profile default}} { - if {$profile eq "default"} { - testconvert $id.$enc.$profile "list \[encoding $converter -failindex idx $enc $data] \[set idx]" $result - if {[set enc [endianUtf $enc]] ne ""} { - # If utf{16,32}-{le,be}, also do utf{16,32} - testconvert $id.$enc.$profile "list \[encoding $converter -failindex idx $enc $data] \[set idx]" $result - } - } else { - testconvert $id.$enc.$profile "list \[encoding $converter -profile $profile -failindex idx $enc $data] \[set idx]" $result - if {[set enc [endianUtf $enc]] ne ""} { + testconvert $id.$enc.$profile "list \[encoding $converter -profile $profile -failindex idx $enc $data] \[set idx]" $result + if {[set enc2 [endianUtf $enc]] ne ""} { + # If utf{16,32}-{le,be}, also do utf{16,32} + testconvert $id.$enc2.$profile "list \[encoding $converter -profile $profile -failindex idx $enc2 $data] \[set idx]" $result + } + + # If this is the default profile, generate a test without specifying profile + if {$profile eq $::encDefaultProfile} { + testconvert $id.$enc.default "list \[encoding $converter -failindex idx $enc $data] \[set idx]" $result + if {[set enc2 [endianUtf $enc]] ne ""} { # If utf{16,32}-{le,be}, also do utf{16,32} - testconvert $id.$enc.$profile "list \[encoding $converter -profile $profile -failindex idx $enc $data] \[set idx]" $result + testconvert $id.$enc2.default "list \[encoding $converter -failindex idx $enc2 $data] \[set idx]" $result } } } @@ -590,9 +679,7 @@ testconvert cmdAH-4.3.12 { encoding system $system } -# convertfrom, convertfrom -profile - -# convertfrom ?-profile? : All valid byte sequences should be accepted by all profiles +# convertfrom ?-profile? : valid byte sequences foreach {enc str hex} $encValidStrings { set bytes [binary decode hex $hex] set prefix A @@ -612,7 +699,9 @@ foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { set bytes [binary format H* $hex] set prefix A set suffix B - set prefixLen [string length [encoding convertto $enc $prefix]] + set prefix_bytes [encoding convertto $enc $prefix] + set suffix_bytes [encoding convertto $enc $suffix] + set prefixLen [string length $prefix_bytes] set result [list $str] # TODO - if the bad byte is unprintable, tcltest errors out when printing a mismatch # so glob it out in error message pattern for now. @@ -624,7 +713,7 @@ foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { } else { set result $errorWithoutPrefix } - testprofile cmdAH-4.3.15.$hex.solo convertfrom $enc $profile $bytes {*}$result + testprofile cmdAH-4.3.13.$hex.solo convertfrom $enc $profile $bytes {*}$result } if {$ctrl eq {} || "lead" in $ctrl} { if {$failidx == -1} { @@ -632,7 +721,7 @@ foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { } else { set result $errorWithoutPrefix } - testprofile cmdAH-4.3.15.$hex.lead convertfrom $enc $profile $bytes$suffix {*}$result + testprofile cmdAH-4.3.13.$hex.lead convertfrom $enc $profile $bytes$suffix_bytes {*}$result } if {$ctrl eq {} || "tail" in $ctrl} { if {$failidx == -1} { @@ -640,7 +729,7 @@ foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { } else { set result $errorWithPrefix } - testprofile cmdAH-4.3.15.$hex.tail convertfrom $enc $profile $prefix$bytes {*}$result + testprofile cmdAH-4.3.13.$hex.tail convertfrom $enc $profile $prefix_bytes$bytes {*}$result } if {$ctrl eq {} || "middle" in $ctrl} { if {$failidx == -1} { @@ -648,28 +737,11 @@ foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { } else { set result $errorWithPrefix } - testprofile cmdAH-4.3.15.$hex.middle convertfrom $enc $profile $prefix$bytes$suffix {*}$result + testprofile cmdAH-4.3.13.$hex.middle convertfrom $enc $profile $prefix_bytes$bytes$suffix_bytes {*}$result } } -proc printable {s} { - set print "" - foreach c [split $s ""] { - set i [scan $c %c] - if {[string is print $c] && ($i <= 127)} { - append print $c - } elseif {$i <= 0xff} { - append print \\x[format %02X $i] - } elseif {$i <= 0xffff} { - append print \\u[format %04X $i] - } else { - append print \\U[format %08X $i] - } - } - return $print -} - -# convertfrom -failindex - valid data +# convertfrom -failindex ?-profile? - valid data foreach {enc str hex} $encValidStrings { set bytes [binary decode hex $hex] set prefix A @@ -677,15 +749,14 @@ foreach {enc str hex} $encValidStrings { set prefix_bytes [encoding convertto $enc A] set suffix_bytes [encoding convertto $enc B] foreach profile $encProfiles { - testfailindex cmdAH-4.3.13.$hex.solo convertfrom $enc $bytes [list $str -1] $profile - testfailindex cmdAH-4.3.13.$hex.lead convertfrom $enc $bytes$suffix_bytes [list $str$suffix -1] $profile - testfailindex cmdAH-4.3.13.$hex.tail convertfrom $enc $prefix_bytes$bytes [list $prefix$str -1] $profile - testfailindex cmdAH-4.3.13.$hex.middle convertfrom $enc $prefix_bytes$bytes$suffix_bytes [list $prefix$str$suffix -1] $profile + testfailindex cmdAH-4.3.14.$hex.solo convertfrom $enc $bytes [list $str -1] $profile + testfailindex cmdAH-4.3.14.$hex.lead convertfrom $enc $bytes$suffix_bytes [list $str$suffix -1] $profile + testfailindex cmdAH-4.3.14.$hex.tail convertfrom $enc $prefix_bytes$bytes [list $prefix$str -1] $profile + testfailindex cmdAH-4.3.14.$hex.middle convertfrom $enc $prefix_bytes$bytes$suffix_bytes [list $prefix$str$suffix -1] $profile } } - -# convertfrom -failindex, convertfrom -failindex -profile, invalid data +# convertfrom -failindex ?-profile? - invalid data foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { # There are multiple test cases based on location of invalid bytes set bytes [binary decode hex $hex] @@ -765,19 +836,96 @@ testconvert cmdAH-4.4.12 { encoding system $system } -# -failindex - valid data -foreach {enc string bytes} $encValidStrings { - testfailindex cmdAH-4.4.13.$enc convertto $enc $string [list $bytes -1] +# convertto ?-profile? : valid byte sequences + +foreach {enc str hex} $encValidStrings { + set bytes [binary decode hex $hex] + set printable [printable $str] + set prefix A + set suffix B + set prefix_bytes [encoding convertto $enc A] + set suffix_bytes [encoding convertto $enc B] + foreach profile $encProfiles { + testprofile cmdAH-4.4.13.$printable.solo convertto $enc $profile $str $bytes + testprofile cmdAH-4.4.13.$printable.lead convertto $enc $profile $str$suffix $bytes$suffix_bytes + testprofile cmdAH-4.4.13.$printable.tail convertto $enc $profile $prefix$str $prefix_bytes$bytes + testprofile cmdAH-4.4.13.$printable.middle convertto $enc $profile $prefix$str$suffix $prefix_bytes$bytes$suffix_bytes + } +} + +# convertto ?-profile? : invalid byte sequences +foreach {enc str profile hex failidx ctrl comment} $encUnencodableStrings { + set bytes [binary decode hex $hex] + set printable [printable $str] + set prefix A + set suffix B + set prefix_bytes [encoding convertto $enc $prefix] + set suffix_bytes [encoding convertto $enc $suffix] + set prefixLen [string length $prefix_bytes] + set result [list $bytes] + # TODO - if the bad byte is unprintable, tcltest errors out when printing a mismatch + # so glob it out in error message pattern for now. + set errorWithoutPrefix [list "unexpected character at index $failidx: *" -returnCodes error -match glob] + set errorWithPrefix [list "unexpected character at index [expr {$failidx+$prefixLen}]: *" -returnCodes error -match glob] + if {$ctrl eq {} || "solo" in $ctrl} { + if {$failidx == -1} { + set result [list $bytes] + } else { + set result $errorWithoutPrefix + } + testprofile cmdAH-4.4.13.$printable.solo convertto $enc $profile $str {*}$result + } + if {$ctrl eq {} || "lead" in $ctrl} { + if {$failidx == -1} { + set result [list $bytes$suffix_bytes] + } else { + set result $errorWithoutPrefix + } + testprofile cmdAH-4.4.13.$printable.lead convertto $enc $profile $str$suffix {*}$result + } + if {$ctrl eq {} || "tail" in $ctrl} { + if {$failidx == -1} { + set result [list $prefix_bytes$bytes] + } else { + set result $errorWithPrefix + } + testprofile cmdAH-4.4.13.$printable.tail convertto $enc $profile $prefix$str {*}$result + } + if {$ctrl eq {} || "middle" in $ctrl} { + if {$failidx == -1} { + set result [list $prefix_bytes$bytes$suffix_bytes] + } else { + set result $errorWithPrefix + } + testprofile cmdAH-4.4.13.$printable.middle convertto $enc $profile $prefix$str$suffix {*}$result + } } -# -failindex - invalid data -foreach {enc string profile hex failidx ctrl comment} $encUnencodableStrings { +# convertto -failindex ?-profile? - valid data +foreach {enc str hex} $encValidStrings { set bytes [binary decode hex $hex] + set printable [printable $str] + set prefix A + set suffix B + set prefix_bytes [encoding convertto $enc A] + set suffix_bytes [encoding convertto $enc B] + foreach profile $encProfiles { + testfailindex cmdAH-4.4.14.$enc.$printable.solo convertto $enc $str [list $bytes -1] $profile + testfailindex cmdAH-4.4.14.$enc.$printable.lead convertto $enc $str$suffix [list $bytes$suffix_bytes -1] $profile + testfailindex cmdAH-4.4.14.$enc.$printable.tail convertto $enc $prefix$str [list $prefix_bytes$bytes -1] $profile + testfailindex cmdAH-4.4.14.$enc.$printable.middle convertto $enc $prefix$str$suffix [list $prefix_bytes$bytes$suffix_bytes -1] $profile + } +} + +# convertto -failindex ?-profile? - invalid data +foreach {enc str profile hex failidx ctrl comment} $encUnencodableStrings { + set bytes [binary decode hex $hex] + set printable [printable $str] set prefix A set suffix B set prefixLen [string length [encoding convertto $enc $prefix]] if {$ctrl eq {} || "solo" in $ctrl} { - testfailindex cmdAH-4.4.14.$string.solo convertto $enc $string [list $bytes $failidx] $profile + testfailindex cmdAH-4.4.14.$printable.solo convertto $enc $str [list $bytes $failidx] $profile } if {$ctrl eq {} || "lead" in $ctrl} { if {$failidx == -1} { @@ -787,7 +935,7 @@ foreach {enc string profile hex failidx ctrl comment} $encUnencodableStrings { # Failure expected set result "" } - testfailindex cmdAH-4.4.14.$string.lead convertto $enc $string$suffix [list $result $failidx] $profile + testfailindex cmdAH-4.4.14.$printable.lead convertto $enc $str$suffix [list $result $failidx] $profile } if {$ctrl eq {} || "tail" in $ctrl} { set expected_failidx $failidx @@ -799,7 +947,7 @@ foreach {enc string profile hex failidx ctrl comment} $encUnencodableStrings { set result $prefix incr expected_failidx $prefixLen } - testfailindex cmdAH-4.4.14.$string.tail convertto $enc $prefix$string [list $result $expected_failidx] $profile + testfailindex cmdAH-4.4.14.$printable.tail convertto $enc $prefix$str [list $result $expected_failidx] $profile } if {$ctrl eq {} || "middle" in $ctrl} { set expected_failidx $failidx @@ -811,46 +959,7 @@ foreach {enc string profile hex failidx ctrl comment} $encUnencodableStrings { set result $prefix incr expected_failidx $prefixLen } - testfailindex cmdAH-4.4.14.$string.middle convertto $enc $prefix$string$suffix [list $result $expected_failidx] $profile - } -} - -# convertto -profile - -# All valid byte sequences should be accepted by all profiles -foreach profile $encProfiles { - set i 0 - foreach {enc string bytes} $encValidStrings { - testprofile cmdAH-4.4.15 convertto $enc $profile $string $bytes - } -} - -# Cycle through the various combinations of encodings and profiles -# for invalid byte sequences -foreach {enc string profile hex failidx ctrl comment} $encUnencodableStrings { - set bytes [binary decode hex $hex] - if {$failidx eq -1} { - set result [list $bytes] - } else { - # TODO - if the bad char is unprintable, tcltest errors out when printing a mismatch - # so glob it out for now. - set result [list "unexpected character at index $failidx: *" -returnCodes error -match glob] - } - #testprofile xx convertto $enc $profile $string {*}$result - if {$profile eq "default"} { - # testconvert cmdAH-4.4.15.$enc.$profile.$tag [list encoding convertto $enc $string] {*}$result - if {"utf-16$endian" eq $enc} { - # utf-16le ->utf-16, utf-32be -> utf32 etc. - set enc [string range $enc 0 5] - # xxtestconvert cmdAH-4.4.15.$enc.$profile.$tag [list encoding convertto $enc $string] {*}$result - } - } else { - # testconvert cmdAH-4.4.15.$enc.$profile.$tag [list encoding convertto -profile $profile $enc $string] {*}$result - if {"utf-16$endian" eq $enc} { - # utf-16le ->utf-16, utf-32be -> utf32 etc. - set enc [string range $enc 0 5] - # testconvert cmdAH-4.4.15.$enc.$profile.$tag [list encoding convertto -profile $profile $enc $string] {*}$result - } + testfailindex cmdAH-4.4.14.$printable.middle convertto $enc $prefix$str$suffix [list $result $expected_failidx] $profile } } -- cgit v0.12 From 3d2dc708451191d04cca00561cbed0295a407b11 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 18 Feb 2023 16:25:57 +0000 Subject: Done with invalid utf-8 table --- tests/cmdAH.test | 278 +++++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 241 insertions(+), 37 deletions(-) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index df28b2e..ad315d2 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -344,11 +344,17 @@ lappend encInvalidBytes {*}{ utf-8 E0 replace \uFFFD -1 {} {Missing trail byte} utf-8 E0 strict {} 0 {} {Missing trail byte} utf-8 E080 tcl8 \u00E0\u20AC -1 {knownBug} {First trail byte must be A0:BF} - utf-8 E080 replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF} - utf-8 E080 strict {} 0 {} {First trail byte must be A0:BF} + utf-8 E080 replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF} + utf-8 E080 strict {} 0 {} {First trail byte must be A0:BF} utf-8 E09F tcl8 \u00E0\u0178 -1 {knownBug} {First trail byte must be A0:BF} - utf-8 E09F replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF} - utf-8 E09F strict {} 0 {} {First trail byte must be A0:BF} + utf-8 E09F replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF} + utf-8 E09F strict {} 0 {} {First trail byte must be A0:BF} + utf-8 E0A0 tcl8 \u00E0\u00A0 -1 {} {Missing second trail byte} + utf-8 E0A0 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 E0A0 strict {} 0 {} {Missing second trail byte} + utf-8 E0BF tcl8 \u00E0\u00BF -1 {} {Missing second trail byte} + utf-8 E0BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 E0BF strict {} 0 {} {Missing second trail byte} utf-8 E0A07F tcl8 \u00E0\u00A0\x7F -1 {} {Second trail byte must be 80:BF} utf-8 E0A07F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 E0A07F strict {} 0 {} {Second trail byte must be 80:BF} @@ -362,6 +368,12 @@ lappend encInvalidBytes {*}{ utf-8 E17F tcl8 \u00E1\x7F -1 {} {Trail byte must be 80:BF} utf-8 E17F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} utf-8 E17F strict {} 0 {} {Trail byte must be 80:BF} + utf-8 E181 tcl8 \u00E1\u0081 -1 {} {Missing second trail byte} + utf-8 E181 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 E181 strict {} 0 {} {Missing second trail byte} + utf-8 E1BF tcl8 \u00E1\u00BF -1 {} {Missing second trail byte} + utf-8 E1BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 E1BF strict {} 0 {} {Missing second trail byte} utf-8 E1807F tcl8 \u00E1\u20AC\x7F -1 {knownBug} {Second trail byte must be 80:BF} utf-8 E1807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 E1807F strict {} 0 {} {Second trail byte must be 80:BF} @@ -374,6 +386,12 @@ lappend encInvalidBytes {*}{ utf-8 EC7F tcl8 \u00EC\x7F -1 {} {Trail byte must be 80:BF} utf-8 EC7F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} utf-8 EC7F strict {} 0 {} {Trail byte must be 80:BF} + utf-8 EC81 tcl8 \u00EC\u0081 -1 {} {Missing second trail byte} + utf-8 EC81 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 EC81 strict {} 0 {} {Missing second trail byte} + utf-8 ECBF tcl8 \u00EC\u00BF -1 {} {Missing second trail byte} + utf-8 ECBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 ECBF strict {} 0 {} {Missing second trail byte} utf-8 EC807F tcl8 \u00EC\u20AC\x7F -1 {knownBug} {Second trail byte must be 80:BF} utf-8 EC807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 EC807F strict {} 0 {} {Second trail byte must be 80:BF} @@ -381,39 +399,225 @@ lappend encInvalidBytes {*}{ utf-8 ECBF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 ECBF7F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 ED tcl8 \u00ED -1 {} {Missing trail byte} - utf-8 ED replace \uFFFD -1 {} {Missing trail byte} - utf-8 ED strict {} 0 {} {Missing trail byte} - utf-8 ED7F tcl8 \u00ED\u7F -1 {knownBug} {First trail byte must be 80:9F} - utf-8 ED7F replace \uFFFD\u7F -1 {} {First trail byte must be 80:9F} - utf-8 ED7F strict {} 0 {} {First trail byte must be 80:9F} - utf-8 EDA0 tcl8 \u00ED\u00A0 -1 {knownBug} {First trail byte must be 80:9F} - utf-8 EDA0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:9F} - utf-8 EDA0 strict {} 0 {} {First trail byte must be 80:9F} - utf-8 ED807F tcl8 \u00ED\u20AC\x7F -1 {knownBug} {Second trail byte must be 80:BF} - utf-8 ED807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 ED807F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 ED9F7F tcl8 \u00ED\u0178\x7F -1 {knownBug} {Second trail byte must be 80:BF} - utf-8 ED9F7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 ED9F7F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 EDA080 tcl8 \uD800 -1 {} {High surrogate} - utf-8 EDA080 replace \uFFFD -1 {} {High surrogate} - utf-8 EDA080 strict {} 0 {} {High surrogate} - utf-8 EDAFBF tcl8 \uDBFF -1 {} {High surrogate} - utf-8 EDAFBF replace \uFFFD -1 {} {High surrogate} - utf-8 EDAFBF strict {} 0 {} {High surrogate} - utf-8 EDB080 tcl8 \uDC00 -1 {} {Low surrogate} - utf-8 EDB080 replace \uFFFD -1 {} {Low surrogate} - utf-8 EDB080 strict {} 0 {} {Low surrogate} - utf-8 EDBFBF tcl8 \uDFFF -1 {} {Low surrogate} - utf-8 EDBFBF replace \uFFFD -1 {} {Low surrogate} - utf-8 EDBFBF strict {} 0 {} {Low surrogate} - utf-8 EDA080EDB080 tcl8 \U00010000 -1 {} {High low surrogate pair} - utf-8 EDA080EDB080 replace \uFFFD\uFFFD -1 {} {High low surrogate pair} - utf-8 EDA080EDB080 strict {} 0 {} {High low surrogate pair} - utf-8 EDAFBFEDBFBF tcl8 \U0010FFFF -1 {} {High low surrogate pair} - utf-8 EDAFBFEDBFBF replace \uFFFD\uFFFD -1 {} {High low surrogate pair} - utf-8 EDAFBFEDBFBF strict {} 0 {} {High low surrogate pair} + utf-8 ED tcl8 \u00ED -1 {} {Missing trail byte} + utf-8 ED replace \uFFFD -1 {} {Missing trail byte} + utf-8 ED strict {} 0 {} {Missing trail byte} + utf-8 ED7F tcl8 \u00ED\u7F -1 {knownBug} {First trail byte must be 80:9F} + utf-8 ED7F replace \uFFFD\u7F -1 {} {First trail byte must be 80:9F} + utf-8 ED7F strict {} 0 {} {First trail byte must be 80:9F} + utf-8 EDA0 tcl8 \u00ED\u00A0 -1 {knownBug} {First trail byte must be 80:9F} + utf-8 EDA0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:9F} + utf-8 EDA0 strict {} 0 {} {First trail byte must be 80:9F} + utf-8 ED81 tcl8 \u00ED\u0081 -1 {} {Missing second trail byte} + utf-8 ED81 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 ED81 strict {} 0 {} {Missing second trail byte} + utf-8 EDBF tcl8 \u00ED\u00BF -1 {} {Missing second trail byte} + utf-8 EDBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 EDBF strict {} 0 {} {Missing second trail byte} + utf-8 ED807F tcl8 \u00ED\u20AC\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 ED807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 ED807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 ED9F7F tcl8 \u00ED\u0178\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 ED9F7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 ED9F7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 EDA080 tcl8 \uD800 -1 {} {High surrogate} + utf-8 EDA080 replace \uFFFD -1 {} {High surrogate} + utf-8 EDA080 strict {} 0 {} {High surrogate} + utf-8 EDAFBF tcl8 \uDBFF -1 {} {High surrogate} + utf-8 EDAFBF replace \uFFFD -1 {} {High surrogate} + utf-8 EDAFBF strict {} 0 {} {High surrogate} + utf-8 EDB080 tcl8 \uDC00 -1 {} {Low surrogate} + utf-8 EDB080 replace \uFFFD -1 {} {Low surrogate} + utf-8 EDB080 strict {} 0 {} {Low surrogate} + utf-8 EDBFBF tcl8 \uDFFF -1 {} {Low surrogate} + utf-8 EDBFBF replace \uFFFD -1 {} {Low surrogate} + utf-8 EDBFBF strict {} 0 {} {Low surrogate} + utf-8 EDA080EDB080 tcl8 \U00010000 -1 {} {High low surrogate pair} + utf-8 EDA080EDB080 replace \uFFFD\uFFFD -1 {} {High low surrogate pair} + utf-8 EDA080EDB080 strict {} 0 {} {High low surrogate pair} + utf-8 EDAFBFEDBFBF tcl8 \U0010FFFF -1 {} {High low surrogate pair} + utf-8 EDAFBFEDBFBF replace \uFFFD\uFFFD -1 {} {High low surrogate pair} + utf-8 EDAFBFEDBFBF strict {} 0 {} {High low surrogate pair} + + utf-8 EE tcl8 \u00EE -1 {} {Missing trail byte} + utf-8 EE replace \uFFFD -1 {} {Missing trail byte} + utf-8 EE strict {} 0 {} {Missing trail byte} + utf-8 EE7F tcl8 \u00EE\u7F -1 {knownBug} {First trail byte must be 80:BF} + utf-8 EE7F replace \uFFFD\u7F -1 {} {First trail byte must be 80:BF} + utf-8 EE7F strict {} 0 {} {First trail byte must be 80:BF} + utf-8 EED0 tcl8 \u00EE\u00D0 -1 {knownBug} {First trail byte must be 80:BF} + utf-8 EED0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} + utf-8 EED0 strict {} 0 {} {First trail byte must be 80:BF} + utf-8 EE81 tcl8 \u00EE\u0081 -1 {} {Missing second trail byte} + utf-8 EE81 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 EE81 strict {} 0 {} {Missing second trail byte} + utf-8 EEBF tcl8 \u00EE\u00BF -1 {} {Missing second trail byte} + utf-8 EEBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 EEBF strict {} 0 {} {Missing second trail byte} + utf-8 EE807F tcl8 \u00EE\u20AC\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 EE807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 EE807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 EEBF7F tcl8 \u00EE\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 EEBF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 EEBF7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 EF tcl8 \u00EF -1 {} {Missing trail byte} + utf-8 EF replace \uFFFD -1 {} {Missing trail byte} + utf-8 EF strict {} 0 {} {Missing trail byte} + utf-8 EF7F tcl8 \u00EF\u7F -1 {knownBug} {First trail byte must be 80:BF} + utf-8 EF7F replace \uFFFD\u7F -1 {} {First trail byte must be 80:BF} + utf-8 EF7F strict {} 0 {} {First trail byte must be 80:BF} + utf-8 EFD0 tcl8 \u00EF\u00D0 -1 {knownBug} {First trail byte must be 80:BF} + utf-8 EFD0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} + utf-8 EFD0 strict {} 0 {} {First trail byte must be 80:BF} + utf-8 EF81 tcl8 \u00EF\u0081 -1 {} {Missing second trail byte} + utf-8 EF81 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 EF81 strict {} 0 {} {Missing second trail byte} + utf-8 EFBF tcl8 \u00EF\u00BF -1 {} {Missing second trail byte} + utf-8 EFBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 EFBF strict {} 0 {} {Missing second trail byte} + utf-8 EF807F tcl8 \u00EF\u20AC\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 EF807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 EF807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 EFBF7F tcl8 \u00EF\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 EFBF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 EFBF7F strict {} 0 {} {Second trail byte must be 80:BF} + + utf-8 F0 tcl8 \u00F0 -1 {} {Missing trail byte} + utf-8 F0 replace \uFFFD -1 {} {Missing trail byte} + utf-8 F0 strict {} 0 {} {Missing trail byte} + utf-8 F08F tcl8 \u00F0\u8F -1 {knownBug} {First trail byte must be 90:BF} + utf-8 F08F replace \uFFFD -1 {knownW3C} {First trail byte must be 90:BF} + utf-8 F08F strict {} 0 {} {First trail byte must be 90:BF} + utf-8 F0D0 tcl8 \u00F0\u00D0 -1 {knownBug} {First trail byte must be 90:BF} + utf-8 F0D0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 90:BF} + utf-8 F0D0 strict {} 0 {} {First trail byte must be 90:BF} + utf-8 F090 tcl8 \u00F0\u0090 -1 {} {Missing second trail byte} + utf-8 F090 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F090 strict {} 0 {} {Missing second trail byte} + utf-8 F0BF tcl8 \u00F0\u00BF -1 {} {Missing second trail byte} + utf-8 F0BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F0BF strict {} 0 {} {Missing second trail byte} + utf-8 F0907F tcl8 \u00F0\u0090\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 F0907F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F0907F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F0BF7F tcl8 \u00F0\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 F0BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F0BF7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F090BF tcl8 \u00F0\u0090\u00BF -1 {} {Missing third trail byte} + utf-8 F090BF replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F090BF strict {} 0 {} {Missing third trail byte} + utf-8 F0BF81 tcl8 \u00F0\u00BF\u0081 -1 {} {Missing third trail byte} + utf-8 F0BF81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F0BF81 strict {} 0 {} {Missing third trail byte} + utf-8 F0BF807F tcl8 \u00F0\u00BF\u20AC\x7F -1 {knownBug} {Third trail byte must be 80:BF} + utf-8 F0BF817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F0BF817F strict {} 0 {} {Third trail byte must be 80:BF} + utf-8 F090BFD0 tcl8 \u00F0\u0090\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} + utf-8 F090BFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F090BFD0 strict {} 0 {} {Third trail byte must be 80:BF} + + utf-8 F1 tcl8 \u00F1 -1 {} {Missing trail byte} + utf-8 F1 replace \uFFFD -1 {} {Missing trail byte} + utf-8 F1 strict {} 0 {} {Missing trail byte} + utf-8 F17F tcl8 \u00F1\u8F -1 {knownBug} {First trail byte must be 80:BF} + utf-8 F17F replace \uFFFD -1 {knownW3C} {First trail byte must be 80:BF} + utf-8 F17F strict {} 0 {} {First trail byte must be 80:BF} + utf-8 F1D0 tcl8 \u00F1\u00D0 -1 {knownBug} {First trail byte must be 80:BF} + utf-8 F1D0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} + utf-8 F1D0 strict {} 0 {} {First trail byte must be 80:BF} + utf-8 F180 tcl8 \u00F1\u0080 -1 {} {Missing second trail byte} + utf-8 F180 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F180 strict {} 0 {} {Missing second trail byte} + utf-8 F1BF tcl8 \u00F1\u00BF -1 {} {Missing second trail byte} + utf-8 F1BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F1BF strict {} 0 {} {Missing second trail byte} + utf-8 F1807F tcl8 \u00F1\u20AC\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 F1807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F1807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F1BF7F tcl8 \u00F1\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 F1BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F1BF7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F180BF tcl8 \u00F1\u20AC\u00BF -1 {knownBug} {Missing third trail byte} + utf-8 F180BF replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F180BF strict {} 0 {} {Missing third trail byte} + utf-8 F1BF81 tcl8 \u00F1\u00BF\u0081 -1 {} {Missing third trail byte} + utf-8 F1BF81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F1BF81 strict {} 0 {} {Missing third trail byte} + utf-8 F1BF807F tcl8 \u00F1\u00BF\u20AC\x7F -1 {knownBug} {Third trail byte must be 80:BF} + utf-8 F1BF817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F1BF817F strict {} 0 {} {Third trail byte must be 80:BF} + utf-8 F180BFD0 tcl8 \u00F1\u20AC\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} + utf-8 F180BFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F180BFD0 strict {} 0 {} {Third trail byte must be 80:BF} + utf-8 F3 tcl8 \u00F3 -1 {} {Missing trail byte} + utf-8 F3 replace \uFFFD -1 {} {Missing trail byte} + utf-8 F3 strict {} 0 {} {Missing trail byte} + utf-8 F37F tcl8 \u00F3\u8F -1 {knownBug} {First trail byte must be 80:BF} + utf-8 F37F replace \uFFFD -1 {knownW3C} {First trail byte must be 80:BF} + utf-8 F37F strict {} 0 {} {First trail byte must be 80:BF} + utf-8 F3D0 tcl8 \u00F3\u00D0 -1 {knownBug} {First trail byte must be 80:BF} + utf-8 F3D0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} + utf-8 F3D0 strict {} 0 {} {First trail byte must be 80:BF} + utf-8 F380 tcl8 \u00F3\u0080 -1 {} {Missing second trail byte} + utf-8 F380 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F380 strict {} 0 {} {Missing second trail byte} + utf-8 F3BF tcl8 \u00F3\u00BF -1 {} {Missing second trail byte} + utf-8 F3BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F3BF strict {} 0 {} {Missing second trail byte} + utf-8 F3807F tcl8 \u00F3\u20AC\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 F3807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F3807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F3BF7F tcl8 \u00F3\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 F3BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F3BF7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F380BF tcl8 \u00F3\u20AC\u00BF -1 {knownBug} {Missing third trail byte} + utf-8 F380BF replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F380BF strict {} 0 {} {Missing third trail byte} + utf-8 F3BF81 tcl8 \u00F3\u00BF\u0081 -1 {} {Missing third trail byte} + utf-8 F3BF81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F3BF81 strict {} 0 {} {Missing third trail byte} + utf-8 F3BF807F tcl8 \u00F3\u00BF\u20AC\x7F -1 {knownBug} {Third trail byte must be 80:BF} + utf-8 F3BF817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F3BF817F strict {} 0 {} {Third trail byte must be 80:BF} + utf-8 F380BFD0 tcl8 \u00F3\u20AC\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} + utf-8 F380BFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F380BFD0 strict {} 0 {} {Third trail byte must be 80:BF} + + utf-8 F4 tcl8 \u00F4 -1 {} {Missing trail byte} + utf-8 F4 replace \uFFFD -1 {} {Missing trail byte} + utf-8 F4 strict {} 0 {} {Missing trail byte} + utf-8 F47F tcl8 \u00F4\u7F -1 {knownBug} {First trail byte must be 80:8F} + utf-8 F47F replace \uFFFD\u7F -1 {knownW3C} {First trail byte must be 80:8F} + utf-8 F47F strict {} 0 {} {First trail byte must be 80:8F} + utf-8 F490 tcl8 \u00F4\u0090 -1 {knownBug} {First trail byte must be 80:8F} + utf-8 F490 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:8F} + utf-8 F490 strict {} 0 {} {First trail byte must be 80:8F} + utf-8 F480 tcl8 \u00F4\u0080 -1 {} {Missing second trail byte} + utf-8 F480 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F480 strict {} 0 {} {Missing second trail byte} + utf-8 F48F tcl8 \u00F4\u008F -1 {} {Missing second trail byte} + utf-8 F48F replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F48F strict {} 0 {} {Missing second trail byte} + utf-8 F4807F tcl8 \u00F4\u20AC\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 F4807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F4807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F48F7F tcl8 \u00F4\u008F\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 F48F7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F48F7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F48081 tcl8 \u00F4\u20AC\u0081 -1 {knownBug} {Missing third trail byte} + utf-8 F48081 replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F48081 strict {} 0 {} {Missing third trail byte} + utf-8 F48F81 tcl8 \u00F4\u008F\u0081 -1 {} {Missing third trail byte} + utf-8 F48F81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F48F81 strict {} 0 {} {Missing third trail byte} + utf-8 F481817F tcl8 \u00F4\u0081\u0081\x7F -1 {knownBug} {Third trail byte must be 80:BF} + utf-8 F480817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F480817F strict {} 0 {} {Third trail byte must be 80:BF} + utf-8 F48FBFD0 tcl8 \u00F4\u008F\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} + utf-8 F48FBFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F48FBFD0 strict {} 0 {} {Third trail byte must be 80:BF} + + utf-8 F5 tcl8 \u00F5 -1 {} {F5:FF are invalid everywhere} utf-8 F5 replace \uFFFD -1 {} {F5:FF are invalid everywhere} -- cgit v0.12 From 41c5d1cd91756ac3614489931ebe22a4095a6cf9 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 18 Feb 2023 17:41:44 +0000 Subject: Minor refactoring/fixes after merge --- generic/tclEncoding.c | 42 ++++++++++-------------------------------- tests/encoding.test | 4 ++-- 2 files changed, 12 insertions(+), 34 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 2095b4c..7e5ec22 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2452,38 +2452,16 @@ UtfToUtfProc( : TCL_CONVERT_SYNTAX; break; } - if (PROFILE_REPLACE(profile)) { - ch = UNICODE_REPLACE_CHAR; - ++src; - } else { - /* TCL_ENCODING_PROFILE_TCL8 */ - ch = UCHAR(*src); - char chbuf[2]; - chbuf[0] = UCHAR(*src++); chbuf[1] = 0; - TclUtfToUCS4(chbuf, &ch); - } - } - else { - /* - * Incomplete bytes for real UTF-8 target. - * TODO - no profile check here because did not have any - * checks in the pre-profile code. Why? Is it because on - * output a valid internal utf-8 stream is assumed? - */ - char chbuf[2]; - /* - * TODO - this code seems broken to me. - * - it does not check profiles - * - generates invalid output for real UTF-8 target - * (consider \xC2) - * A possible explanation is this behavior matches the - * Tcl8 decoding behavior of mapping invalid bytes to the same - * code point value. Still, at least strictness checks should - * be made. - */ - chbuf[0] = UCHAR(*src++); chbuf[1] = 0; - TclUtfToUCS4(chbuf, &ch); - } + } + if (PROFILE_REPLACE(profile)) { + ch = UNICODE_REPLACE_CHAR; + ++src; + } else { + /* TCL_ENCODING_PROFILE_TCL8 */ + char chbuf[2]; + chbuf[0] = UCHAR(*src++); chbuf[1] = 0; + TclUtfToUCS4(chbuf, &ch); + } dst += Tcl_UniCharToUtf(ch, dst); } else { diff --git a/tests/encoding.test b/tests/encoding.test index 36728d1..7199138 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -848,10 +848,10 @@ test encoding-24.41 {Parse invalid utf-8 with -profile strict} -body { encoding convertfrom -profile strict utf-8 \xED\xA0\x80\xED\xB0\x80 } -returnCodes 1 -result {unexpected byte sequence starting at index 0: '\xED'} test encoding-24.42 {Parse invalid utf-8, fallback to cp1252 [885c86a9a0]} -body { - encoding convertfrom -nocomplain utf-8 \xF0\x80\x80\x80 + encoding convertfrom -profile tcl8 utf-8 \xF0\x80\x80\x80 } -result \xF0\u20AC\u20AC\u20AC test encoding-24.43 {Parse invalid utf-8, fallback to cp1252 [885c86a9a0]} -body { - encoding convertfrom -nocomplain utf-8 \x80 + encoding convertfrom -profile tcl8 utf-8 \x80 } -result \u20AC file delete [file join [temporaryDirectory] iso2022.txt] -- cgit v0.12 From 9f595d2fa36d13395f1bfb16559f7519c08e873f Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sun, 19 Feb 2023 07:40:29 +0000 Subject: Remove knownBug test constraints now that fix has been merged from core-8-branch --- tests/cmdAH.test | 131 +++++++++++++++++++++++++++---------------------------- 1 file changed, 65 insertions(+), 66 deletions(-) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 11a8188..faa604a 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -278,41 +278,40 @@ lappend encInvalidBytes {*}{ # (UtfToUtfProc). # Note C0, C1, F5:FF are invalid bytes ANYWHERE. Exception is C080 lappend encInvalidBytes {*}{ - utf-8 80 tcl8 \u20AC -1 {knownBug} {map to cp1252} - utf-8 80 tcl8 \u20AC -1 {knownBug} {map to cp1252} + utf-8 80 tcl8 \u20AC -1 {} {map to cp1252} utf-8 80 replace \uFFFD -1 {} {Smallest invalid byte} utf-8 80 strict {} 0 {} {Smallest invalid byte} - utf-8 81 tcl8 \u0081 -1 {knownBug} {map to cp1252} - utf-8 82 tcl8 \u201A -1 {knownBug} {map to cp1252} - utf-8 83 tcl8 \u0192 -1 {knownBug} {map to cp1252} - utf-8 84 tcl8 \u201E -1 {knownBug} {map to cp1252} - utf-8 85 tcl8 \u2026 -1 {knownBug} {map to cp1252} - utf-8 86 tcl8 \u2020 -1 {knownBug} {map to cp1252} - utf-8 87 tcl8 \u2021 -1 {knownBug} {map to cp1252} - utf-8 88 tcl8 \u0276 -1 {knownBug} {map to cp1252} - utf-8 89 tcl8 \u2030 -1 {knownBug} {map to cp1252} - utf-8 8A tcl8 \u0160 -1 {knownBug} {map to cp1252} - utf-8 8B tcl8 \u2039 -1 {knownBug} {map to cp1252} - utf-8 8C tcl8 \u0152 -1 {knownBug} {map to cp1252} - utf-8 8D tcl8 \u008D -1 {knownBug} {map to cp1252} - utf-8 8E tcl8 \u017D -1 {knownBug} {map to cp1252} - utf-8 8F tcl8 \u008F -1 {knownBug} {map to cp1252} - utf-8 90 tcl8 \u0090 -1 {knownBug} {map to cp1252} - utf-8 91 tcl8 \u2018 -1 {knownBug} {map to cp1252} - utf-8 92 tcl8 \u2019 -1 {knownBug} {map to cp1252} - utf-8 93 tcl8 \u201C -1 {knownBug} {map to cp1252} - utf-8 94 tcl8 \u201D -1 {knownBug} {map to cp1252} - utf-8 95 tcl8 \u2022 -1 {knownBug} {map to cp1252} - utf-8 96 tcl8 \u2013 -1 {knownBug} {map to cp1252} - utf-8 97 tcl8 \u2014 -1 {knownBug} {map to cp1252} - utf-8 98 tcl8 \u02DC -1 {knownBug} {map to cp1252} - utf-8 99 tcl8 \u2122 -1 {knownBug} {map to cp1252} - utf-8 9A tcl8 \u0161 -1 {knownBug} {map to cp1252} - utf-8 9B tcl8 \u203A -1 {knownBug} {map to cp1252} - utf-8 9C tcl8 \u0153 -1 {knownBug} {map to cp1252} - utf-8 9D tcl8 \u009D -1 {knownBug} {map to cp1252} - utf-8 9E tcl8 \u017E -1 {knownBug} {map to cp1252} - utf-8 9F tcl8 \u0178 -1 {knownBug} {map to cp1252} + utf-8 81 tcl8 \u0081 -1 {} {map to cp1252} + utf-8 82 tcl8 \u201A -1 {} {map to cp1252} + utf-8 83 tcl8 \u0192 -1 {} {map to cp1252} + utf-8 84 tcl8 \u201E -1 {} {map to cp1252} + utf-8 85 tcl8 \u2026 -1 {} {map to cp1252} + utf-8 86 tcl8 \u2020 -1 {} {map to cp1252} + utf-8 87 tcl8 \u2021 -1 {} {map to cp1252} + utf-8 88 tcl8 \u02C6 -1 {} {map to cp1252} + utf-8 89 tcl8 \u2030 -1 {} {map to cp1252} + utf-8 8A tcl8 \u0160 -1 {} {map to cp1252} + utf-8 8B tcl8 \u2039 -1 {} {map to cp1252} + utf-8 8C tcl8 \u0152 -1 {} {map to cp1252} + utf-8 8D tcl8 \u008D -1 {} {map to cp1252} + utf-8 8E tcl8 \u017D -1 {} {map to cp1252} + utf-8 8F tcl8 \u008F -1 {} {map to cp1252} + utf-8 90 tcl8 \u0090 -1 {} {map to cp1252} + utf-8 91 tcl8 \u2018 -1 {} {map to cp1252} + utf-8 92 tcl8 \u2019 -1 {} {map to cp1252} + utf-8 93 tcl8 \u201C -1 {} {map to cp1252} + utf-8 94 tcl8 \u201D -1 {} {map to cp1252} + utf-8 95 tcl8 \u2022 -1 {} {map to cp1252} + utf-8 96 tcl8 \u2013 -1 {} {map to cp1252} + utf-8 97 tcl8 \u2014 -1 {} {map to cp1252} + utf-8 98 tcl8 \u02DC -1 {} {map to cp1252} + utf-8 99 tcl8 \u2122 -1 {} {map to cp1252} + utf-8 9A tcl8 \u0161 -1 {} {map to cp1252} + utf-8 9B tcl8 \u203A -1 {} {map to cp1252} + utf-8 9C tcl8 \u0153 -1 {} {map to cp1252} + utf-8 9D tcl8 \u009D -1 {} {map to cp1252} + utf-8 9E tcl8 \u017E -1 {} {map to cp1252} + utf-8 9F tcl8 \u0178 -1 {} {map to cp1252} utf-8 C0 tcl8 \u00C0 -1 {} {C0 is invalid anywhere} utf-8 C0 strict {} 0 {} {C0 is invalid anywhere} @@ -343,10 +342,10 @@ lappend encInvalidBytes {*}{ utf-8 E0 tcl8 \u00E0 -1 {} {Missing trail byte} utf-8 E0 replace \uFFFD -1 {} {Missing trail byte} utf-8 E0 strict {} 0 {} {Missing trail byte} - utf-8 E080 tcl8 \u00E0\u20AC -1 {knownBug} {First trail byte must be A0:BF} + utf-8 E080 tcl8 \u00E0\u20AC -1 {} {First trail byte must be A0:BF} utf-8 E080 replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF} utf-8 E080 strict {} 0 {} {First trail byte must be A0:BF} - utf-8 E09F tcl8 \u00E0\u0178 -1 {knownBug} {First trail byte must be A0:BF} + utf-8 E09F tcl8 \u00E0\u0178 -1 {} {First trail byte must be A0:BF} utf-8 E09F replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF} utf-8 E09F strict {} 0 {} {First trail byte must be A0:BF} utf-8 E0A0 tcl8 \u00E0\u00A0 -1 {} {Missing second trail byte} @@ -374,7 +373,7 @@ lappend encInvalidBytes {*}{ utf-8 E1BF tcl8 \u00E1\u00BF -1 {} {Missing second trail byte} utf-8 E1BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 E1BF strict {} 0 {} {Missing second trail byte} - utf-8 E1807F tcl8 \u00E1\u20AC\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 E1807F tcl8 \u00E1\u20AC\x7F -1 {} {Second trail byte must be 80:BF} utf-8 E1807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 E1807F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 E1BF7F tcl8 \u00E1\u00BF\x7F -1 {} {Second trail byte must be 80:BF} @@ -392,7 +391,7 @@ lappend encInvalidBytes {*}{ utf-8 ECBF tcl8 \u00EC\u00BF -1 {} {Missing second trail byte} utf-8 ECBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 ECBF strict {} 0 {} {Missing second trail byte} - utf-8 EC807F tcl8 \u00EC\u20AC\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 EC807F tcl8 \u00EC\u20AC\x7F -1 {} {Second trail byte must be 80:BF} utf-8 EC807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 EC807F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 ECBF7F tcl8 \u00EC\u00BF\x7F -1 {} {Second trail byte must be 80:BF} @@ -402,10 +401,10 @@ lappend encInvalidBytes {*}{ utf-8 ED tcl8 \u00ED -1 {} {Missing trail byte} utf-8 ED replace \uFFFD -1 {} {Missing trail byte} utf-8 ED strict {} 0 {} {Missing trail byte} - utf-8 ED7F tcl8 \u00ED\u7F -1 {knownBug} {First trail byte must be 80:9F} + utf-8 ED7F tcl8 \u00ED\u7F -1 {} {First trail byte must be 80:9F} utf-8 ED7F replace \uFFFD\u7F -1 {} {First trail byte must be 80:9F} utf-8 ED7F strict {} 0 {} {First trail byte must be 80:9F} - utf-8 EDA0 tcl8 \u00ED\u00A0 -1 {knownBug} {First trail byte must be 80:9F} + utf-8 EDA0 tcl8 \u00ED\u00A0 -1 {} {First trail byte must be 80:9F} utf-8 EDA0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:9F} utf-8 EDA0 strict {} 0 {} {First trail byte must be 80:9F} utf-8 ED81 tcl8 \u00ED\u0081 -1 {} {Missing second trail byte} @@ -414,10 +413,10 @@ lappend encInvalidBytes {*}{ utf-8 EDBF tcl8 \u00ED\u00BF -1 {} {Missing second trail byte} utf-8 EDBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 EDBF strict {} 0 {} {Missing second trail byte} - utf-8 ED807F tcl8 \u00ED\u20AC\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 ED807F tcl8 \u00ED\u20AC\x7F -1 {} {Second trail byte must be 80:BF} utf-8 ED807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 ED807F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 ED9F7F tcl8 \u00ED\u0178\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 ED9F7F tcl8 \u00ED\u0178\x7F -1 {} {Second trail byte must be 80:BF} utf-8 ED9F7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 ED9F7F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 EDA080 tcl8 \uD800 -1 {} {High surrogate} @@ -442,10 +441,10 @@ lappend encInvalidBytes {*}{ utf-8 EE tcl8 \u00EE -1 {} {Missing trail byte} utf-8 EE replace \uFFFD -1 {} {Missing trail byte} utf-8 EE strict {} 0 {} {Missing trail byte} - utf-8 EE7F tcl8 \u00EE\u7F -1 {knownBug} {First trail byte must be 80:BF} + utf-8 EE7F tcl8 \u00EE\u7F -1 {} {First trail byte must be 80:BF} utf-8 EE7F replace \uFFFD\u7F -1 {} {First trail byte must be 80:BF} utf-8 EE7F strict {} 0 {} {First trail byte must be 80:BF} - utf-8 EED0 tcl8 \u00EE\u00D0 -1 {knownBug} {First trail byte must be 80:BF} + utf-8 EED0 tcl8 \u00EE\u00D0 -1 {} {First trail byte must be 80:BF} utf-8 EED0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} utf-8 EED0 strict {} 0 {} {First trail byte must be 80:BF} utf-8 EE81 tcl8 \u00EE\u0081 -1 {} {Missing second trail byte} @@ -454,7 +453,7 @@ lappend encInvalidBytes {*}{ utf-8 EEBF tcl8 \u00EE\u00BF -1 {} {Missing second trail byte} utf-8 EEBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 EEBF strict {} 0 {} {Missing second trail byte} - utf-8 EE807F tcl8 \u00EE\u20AC\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 EE807F tcl8 \u00EE\u20AC\x7F -1 {} {Second trail byte must be 80:BF} utf-8 EE807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 EE807F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 EEBF7F tcl8 \u00EE\u00BF\x7F -1 {} {Second trail byte must be 80:BF} @@ -463,10 +462,10 @@ lappend encInvalidBytes {*}{ utf-8 EF tcl8 \u00EF -1 {} {Missing trail byte} utf-8 EF replace \uFFFD -1 {} {Missing trail byte} utf-8 EF strict {} 0 {} {Missing trail byte} - utf-8 EF7F tcl8 \u00EF\u7F -1 {knownBug} {First trail byte must be 80:BF} + utf-8 EF7F tcl8 \u00EF\u7F -1 {} {First trail byte must be 80:BF} utf-8 EF7F replace \uFFFD\u7F -1 {} {First trail byte must be 80:BF} utf-8 EF7F strict {} 0 {} {First trail byte must be 80:BF} - utf-8 EFD0 tcl8 \u00EF\u00D0 -1 {knownBug} {First trail byte must be 80:BF} + utf-8 EFD0 tcl8 \u00EF\u00D0 -1 {} {First trail byte must be 80:BF} utf-8 EFD0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} utf-8 EFD0 strict {} 0 {} {First trail byte must be 80:BF} utf-8 EF81 tcl8 \u00EF\u0081 -1 {} {Missing second trail byte} @@ -475,7 +474,7 @@ lappend encInvalidBytes {*}{ utf-8 EFBF tcl8 \u00EF\u00BF -1 {} {Missing second trail byte} utf-8 EFBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 EFBF strict {} 0 {} {Missing second trail byte} - utf-8 EF807F tcl8 \u00EF\u20AC\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 EF807F tcl8 \u00EF\u20AC\x7F -1 {} {Second trail byte must be 80:BF} utf-8 EF807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 EF807F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 EFBF7F tcl8 \u00EF\u00BF\x7F -1 {} {Second trail byte must be 80:BF} @@ -485,10 +484,10 @@ lappend encInvalidBytes {*}{ utf-8 F0 tcl8 \u00F0 -1 {} {Missing trail byte} utf-8 F0 replace \uFFFD -1 {} {Missing trail byte} utf-8 F0 strict {} 0 {} {Missing trail byte} - utf-8 F08F tcl8 \u00F0\u8F -1 {knownBug} {First trail byte must be 90:BF} + utf-8 F08F tcl8 \u00F0\u8F -1 {} {First trail byte must be 90:BF} utf-8 F08F replace \uFFFD -1 {knownW3C} {First trail byte must be 90:BF} utf-8 F08F strict {} 0 {} {First trail byte must be 90:BF} - utf-8 F0D0 tcl8 \u00F0\u00D0 -1 {knownBug} {First trail byte must be 90:BF} + utf-8 F0D0 tcl8 \u00F0\u00D0 -1 {} {First trail byte must be 90:BF} utf-8 F0D0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 90:BF} utf-8 F0D0 strict {} 0 {} {First trail byte must be 90:BF} utf-8 F090 tcl8 \u00F0\u0090 -1 {} {Missing second trail byte} @@ -497,7 +496,7 @@ lappend encInvalidBytes {*}{ utf-8 F0BF tcl8 \u00F0\u00BF -1 {} {Missing second trail byte} utf-8 F0BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 F0BF strict {} 0 {} {Missing second trail byte} - utf-8 F0907F tcl8 \u00F0\u0090\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 F0907F tcl8 \u00F0\u0090\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F0907F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 F0907F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 F0BF7F tcl8 \u00F0\u00BF\x7F -1 {} {Second trail byte must be 80:BF} @@ -509,7 +508,7 @@ lappend encInvalidBytes {*}{ utf-8 F0BF81 tcl8 \u00F0\u00BF\u0081 -1 {} {Missing third trail byte} utf-8 F0BF81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} utf-8 F0BF81 strict {} 0 {} {Missing third trail byte} - utf-8 F0BF807F tcl8 \u00F0\u00BF\u20AC\x7F -1 {knownBug} {Third trail byte must be 80:BF} + utf-8 F0BF807F tcl8 \u00F0\u00BF\u20AC\x7F -1 {} {Third trail byte must be 80:BF} utf-8 F0BF817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} utf-8 F0BF817F strict {} 0 {} {Third trail byte must be 80:BF} utf-8 F090BFD0 tcl8 \u00F0\u0090\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} @@ -519,10 +518,10 @@ lappend encInvalidBytes {*}{ utf-8 F1 tcl8 \u00F1 -1 {} {Missing trail byte} utf-8 F1 replace \uFFFD -1 {} {Missing trail byte} utf-8 F1 strict {} 0 {} {Missing trail byte} - utf-8 F17F tcl8 \u00F1\u8F -1 {knownBug} {First trail byte must be 80:BF} + utf-8 F17F tcl8 \u00F1\u7F -1 {} {First trail byte must be 80:BF} utf-8 F17F replace \uFFFD -1 {knownW3C} {First trail byte must be 80:BF} utf-8 F17F strict {} 0 {} {First trail byte must be 80:BF} - utf-8 F1D0 tcl8 \u00F1\u00D0 -1 {knownBug} {First trail byte must be 80:BF} + utf-8 F1D0 tcl8 \u00F1\u00D0 -1 {} {First trail byte must be 80:BF} utf-8 F1D0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} utf-8 F1D0 strict {} 0 {} {First trail byte must be 80:BF} utf-8 F180 tcl8 \u00F1\u20AC -1 {} {Missing second trail byte} @@ -531,19 +530,19 @@ lappend encInvalidBytes {*}{ utf-8 F1BF tcl8 \u00F1\u00BF -1 {} {Missing second trail byte} utf-8 F1BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 F1BF strict {} 0 {} {Missing second trail byte} - utf-8 F1807F tcl8 \u00F1\u20AC\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 F1807F tcl8 \u00F1\u20AC\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F1807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 F1807F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 F1BF7F tcl8 \u00F1\u00BF\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F1BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 F1BF7F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 F180BF tcl8 \u00F1\u20AC\u00BF -1 {knownBug} {Missing third trail byte} + utf-8 F180BF tcl8 \u00F1\u20AC\u00BF -1 {} {Missing third trail byte} utf-8 F180BF replace \uFFFD -1 {knownW3C} {Missing third trail byte} utf-8 F180BF strict {} 0 {} {Missing third trail byte} utf-8 F1BF81 tcl8 \u00F1\u00BF\u0081 -1 {} {Missing third trail byte} utf-8 F1BF81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} utf-8 F1BF81 strict {} 0 {} {Missing third trail byte} - utf-8 F1BF807F tcl8 \u00F1\u00BF\u20AC\x7F -1 {knownBug} {Third trail byte must be 80:BF} + utf-8 F1BF807F tcl8 \u00F1\u00BF\u20AC\x7F -1 {} {Third trail byte must be 80:BF} utf-8 F1BF817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} utf-8 F1BF817F strict {} 0 {} {Third trail byte must be 80:BF} utf-8 F180BFD0 tcl8 \u00F1\u20AC\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} @@ -552,10 +551,10 @@ lappend encInvalidBytes {*}{ utf-8 F3 tcl8 \u00F3 -1 {} {Missing trail byte} utf-8 F3 replace \uFFFD -1 {} {Missing trail byte} utf-8 F3 strict {} 0 {} {Missing trail byte} - utf-8 F37F tcl8 \u00F3\u8F -1 {knownBug} {First trail byte must be 80:BF} + utf-8 F37F tcl8 \u00F3\x7F -1 {} {First trail byte must be 80:BF} utf-8 F37F replace \uFFFD -1 {knownW3C} {First trail byte must be 80:BF} utf-8 F37F strict {} 0 {} {First trail byte must be 80:BF} - utf-8 F3D0 tcl8 \u00F3\u00D0 -1 {knownBug} {First trail byte must be 80:BF} + utf-8 F3D0 tcl8 \u00F3\u00D0 -1 {} {First trail byte must be 80:BF} utf-8 F3D0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} utf-8 F3D0 strict {} 0 {} {First trail byte must be 80:BF} utf-8 F380 tcl8 \u00F3\u20AC -1 {} {Missing second trail byte} @@ -564,19 +563,19 @@ lappend encInvalidBytes {*}{ utf-8 F3BF tcl8 \u00F3\u00BF -1 {} {Missing second trail byte} utf-8 F3BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 F3BF strict {} 0 {} {Missing second trail byte} - utf-8 F3807F tcl8 \u00F3\u20AC\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 F3807F tcl8 \u00F3\u20AC\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F3807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 F3807F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 F3BF7F tcl8 \u00F3\u00BF\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F3BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 F3BF7F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 F380BF tcl8 \u00F3\u20AC\u00BF -1 {knownBug} {Missing third trail byte} + utf-8 F380BF tcl8 \u00F3\u20AC\u00BF -1 {} {Missing third trail byte} utf-8 F380BF replace \uFFFD -1 {knownW3C} {Missing third trail byte} utf-8 F380BF strict {} 0 {} {Missing third trail byte} utf-8 F3BF81 tcl8 \u00F3\u00BF\u0081 -1 {} {Missing third trail byte} utf-8 F3BF81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} utf-8 F3BF81 strict {} 0 {} {Missing third trail byte} - utf-8 F3BF807F tcl8 \u00F3\u00BF\u20AC\x7F -1 {knownBug} {Third trail byte must be 80:BF} + utf-8 F3BF807F tcl8 \u00F3\u00BF\u20AC\x7F -1 {} {Third trail byte must be 80:BF} utf-8 F3BF817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} utf-8 F3BF817F strict {} 0 {} {Third trail byte must be 80:BF} utf-8 F380BFD0 tcl8 \u00F3\u20AC\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} @@ -586,10 +585,10 @@ lappend encInvalidBytes {*}{ utf-8 F4 tcl8 \u00F4 -1 {} {Missing trail byte} utf-8 F4 replace \uFFFD -1 {} {Missing trail byte} utf-8 F4 strict {} 0 {} {Missing trail byte} - utf-8 F47F tcl8 \u00F4\u7F -1 {knownBug} {First trail byte must be 80:8F} + utf-8 F47F tcl8 \u00F4\u7F -1 {} {First trail byte must be 80:8F} utf-8 F47F replace \uFFFD\u7F -1 {knownW3C} {First trail byte must be 80:8F} utf-8 F47F strict {} 0 {} {First trail byte must be 80:8F} - utf-8 F490 tcl8 \u00F4\u0090 -1 {knownBug} {First trail byte must be 80:8F} + utf-8 F490 tcl8 \u00F4\u0090 -1 {} {First trail byte must be 80:8F} utf-8 F490 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:8F} utf-8 F490 strict {} 0 {} {First trail byte must be 80:8F} utf-8 F480 tcl8 \u00F4\u20AC -1 {} {Missing second trail byte} @@ -598,19 +597,19 @@ lappend encInvalidBytes {*}{ utf-8 F48F tcl8 \u00F4\u008F -1 {} {Missing second trail byte} utf-8 F48F replace \uFFFD -1 {knownW3C} {Missing second trail byte} utf-8 F48F strict {} 0 {} {Missing second trail byte} - utf-8 F4807F tcl8 \u00F4\u20AC\x7F -1 {knownBug} {Second trail byte must be 80:BF} + utf-8 F4807F tcl8 \u00F4\u20AC\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F4807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 F4807F strict {} 0 {} {Second trail byte must be 80:BF} utf-8 F48F7F tcl8 \u00F4\u008F\x7F -1 {} {Second trail byte must be 80:BF} utf-8 F48F7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} utf-8 F48F7F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 F48081 tcl8 \u00F4\u20AC\u0081 -1 {knownBug} {Missing third trail byte} + utf-8 F48081 tcl8 \u00F4\u20AC\u0081 -1 {} {Missing third trail byte} utf-8 F48081 replace \uFFFD -1 {knownW3C} {Missing third trail byte} utf-8 F48081 strict {} 0 {} {Missing third trail byte} utf-8 F48F81 tcl8 \u00F4\u008F\u0081 -1 {} {Missing third trail byte} utf-8 F48F81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} utf-8 F48F81 strict {} 0 {} {Missing third trail byte} - utf-8 F481817F tcl8 \u00F4\u0081\u0081\x7F -1 {knownBug} {Third trail byte must be 80:BF} + utf-8 F481817F tcl8 \u00F4\u0081\u0081\x7F -1 {} {Third trail byte must be 80:BF} utf-8 F480817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} utf-8 F480817F strict {} 0 {} {Third trail byte must be 80:BF} utf-8 F48FBFD0 tcl8 \u00F4\u008F\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} -- cgit v0.12 From 23d9ca0ec4772f703cd24c476d5fa485fd91e828 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sun, 19 Feb 2023 11:41:44 +0000 Subject: Proposed fix for [5607d6482c]: strict ucs-2 never implemented (TIP #346/#656) --- generic/tclEncoding.c | 36 ++++++++++++++++++++++++------------ tests/encoding.test | 8 +++++++- 2 files changed, 31 insertions(+), 13 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 1d3a3eb..d2b0efc 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -573,13 +573,13 @@ TclInitEncodingSubsystem(void) type.freeProc = NULL; type.nullSize = 2; type.encodingName = "ucs-2le"; - type.clientData = INT2PTR(TCL_ENCODING_LE|TCL_ENCODING_NOCOMPLAIN); + type.clientData = INT2PTR(TCL_ENCODING_LE); Tcl_CreateEncoding(&type); type.encodingName = "ucs-2be"; - type.clientData = INT2PTR(TCL_ENCODING_NOCOMPLAIN); + type.clientData = INT2PTR(0); Tcl_CreateEncoding(&type); type.encodingName = "ucs-2"; - type.clientData = INT2PTR(isLe.c|TCL_ENCODING_NOCOMPLAIN); + type.clientData = INT2PTR(isLe.c); Tcl_CreateEncoding(&type); type.toUtfProc = Utf32ToUtfProc; @@ -601,13 +601,13 @@ TclInitEncodingSubsystem(void) type.freeProc = NULL; type.nullSize = 2; type.encodingName = "utf-16le"; - type.clientData = INT2PTR(TCL_ENCODING_LE); + type.clientData = INT2PTR(TCL_ENCODING_LE|ENCODING_UTF); Tcl_CreateEncoding(&type); type.encodingName = "utf-16be"; - type.clientData = INT2PTR(0); + type.clientData = INT2PTR(ENCODING_UTF); Tcl_CreateEncoding(&type); type.encodingName = "utf-16"; - type.clientData = INT2PTR(isLe.c); + type.clientData = INT2PTR(isLe.c|ENCODING_UTF); Tcl_CreateEncoding(&type); #ifndef TCL_NO_DEPRECATED @@ -2984,10 +2984,7 @@ UtfToUcs2Proc( * output buffer. */ { const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd; - int result, numChars; -#if TCL_UTF_MAX < 4 - int len; -#endif + int result, numChars, len; Tcl_UniChar ch = 0; flags |= PTR2INT(clientData); @@ -3017,17 +3014,32 @@ UtfToUcs2Proc( break; } #if TCL_UTF_MAX < 4 - src += (len = TclUtfToUniChar(src, &ch)); + len = TclUtfToUniChar(src, &ch); if ((ch >= 0xD800) && (len < 3)) { + if (STOPONERROR) { + result = TCL_CONVERT_UNKNOWN; + break; + } + src += len; src += TclUtfToUniChar(src, &ch); ch = 0xFFFD; } #else - src += TclUtfToUniChar(src, &ch); + len = TclUtfToUniChar(src, &ch); if (ch > 0xFFFF) { + if (STOPONERROR) { + result = TCL_CONVERT_UNKNOWN; + break; + } ch = 0xFFFD; } #endif + if (STOPONERROR && ((ch & ~0x7FF) == 0xD800)) { + result = TCL_CONVERT_SYNTAX; + break; + } + + src += len; /* * Need to handle this in a way that won't cause misalignment by diff --git a/tests/encoding.test b/tests/encoding.test index 03f0273..83e75be 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -561,7 +561,7 @@ test encoding-16.9 { test encoding-17.1 {UtfToUtf16Proc} -body { encoding convertto utf-16 "\U460DC" } -result "\xD8\xD8\xDC\xDC" -test encoding-17.2 {UtfToUcs2Proc} -body { +test encoding-17.2 {UtfToUcs2Proc, invalid testcase, see [5607d6482c]} -constraints deprecated -body { encoding convertfrom utf-16 [encoding convertto ucs-2 "\U460DC"] } -result "\uFFFD" test encoding-17.3 {UtfToUtf16Proc} -body { @@ -853,6 +853,12 @@ test encoding-24.42 {Parse invalid utf-8, fallback to cp1252 [885c86a9a0]} -body test encoding-24.43 {Parse invalid utf-8, fallback to cp1252 [885c86a9a0]} -body { encoding convertfrom -nocomplain utf-8 \x80 } -result \u20AC +test encoding-24.44 {Try to generate invalid ucs-2 with -strict} -body { + encoding convertto -strict ucs-2 \uD800 +} -returnCodes 1 -result {unexpected character at index 0: 'U+00D800'} +test encoding-24.45 {Try to generate invalid ucs-2 with -strict} -body { + encoding convertto -strict ucs-2 \U10000 +} -returnCodes 1 -result {unexpected character at index 0: 'U+010000'} file delete [file join [temporaryDirectory] iso2022.txt] -- cgit v0.12 From 41af9f9e84d0b6cee2116ff08e297db05786e6ce Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 20 Feb 2023 15:08:58 +0000 Subject: Add UTF16 and UTF32 tests --- tests/cmdAH.test | 193 +++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 137 insertions(+), 56 deletions(-) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index faa604a..1fbe6d2 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -185,15 +185,58 @@ set encDefaultProfile tcl8; # Should reflect the default from implementation # TODO - valid sequences for different encodings - shiftjis etc. # Note utf-16, utf-32 missing because they are automatically -# generated based on le/be versions. Also add all ranges from Unicode standard -# Table 3.7 +# generated based on le/be versions. set encValidStrings { - ascii ABC 414243 - utf-8 A\u0000\u03A9\u8A9E\U00010384 4100CEA9E8AA9EF0908E84 - utf-16le A\u0000\u03A9\u8A9E\U00010384 41000000A9039E8A00D884DF - utf-16be A\u0000\u03A9\u8A9E\U00010384 0041000003A98A9ED800DF84 - utf-32le A\u0000\u03A9\u8A9E\U00010384 4100000000000000A90300009E8A000084030100 - utf-32be A\u0000\u03A9\u8A9E\U00010384 0000004100000000000003A900008A9E00010384 + ascii \u0000 00 {} {Lowest ASCII} + ascii \u007F 7F knownBug {Highest ASCII} + + utf-8 \u0000 00 {} {Unicode Table 3.7 Row 1} + utf-8 \u007F 7F {} {Unicode Table 3.7 Row 1} + utf-8 \u0080 C280 {} {Unicode Table 3.7 Row 2} + utf-8 \u07FF DFBF {} {Unicode Table 3.7 Row 2} + utf-8 \u0800 E0A080 {} {Unicode Table 3.7 Row 3} + utf-8 \u0FFF E0BFBF {} {Unicode Table 3.7 Row 3} + utf-8 \u1000 E18080 {} {Unicode Table 3.7 Row 4} + utf-8 \uCFFF ECBFBF {} {Unicode Table 3.7 Row 4} + utf-8 \uD000 ED8080 {} {Unicode Table 3.7 Row 5} + utf-8 \uD7FF ED9FBF {} {Unicode Table 3.7 Row 5} + utf-8 \uE000 EE8080 {} {Unicode Table 3.7 Row 6} + utf-8 \uFFFF EFBFBF {} {Unicode Table 3.7 Row 6} + utf-8 \U10000 F0908080 {} {Unicode Table 3.7 Row 7} + utf-8 \U3FFFF F0BFBFBF {} {Unicode Table 3.7 Row 7} + utf-8 \U40000 F1808080 {} {Unicode Table 3.7 Row 8} + utf-8 \UFFFFF F3BFBFBF {} {Unicode Table 3.7 Row 8} + utf-8 \U100000 F4808080 {} {Unicode Table 3.7 Row 9} + utf-8 \U10FFFF F48FBFBF {} {Unicode Table 3.7 Row 9} + utf-8 A\u03A9\u8A9E\U00010384 41CEA9E8AA9EF0908E84 {} {Unicode 2.5} + + utf-16le \u0000 0000 {} {Lowest code unit} + utf-16le \uD7FF FFD7 {} {Below high surrogate range} + utf-16le \uE000 00E0 {} {Above low surrogate range} + utf-16le \uFFFF FFFF {} {Highest code unit} + utf-16le \U010000 00D800DC {} {First surrogate pair} + utf-16le \U10FFFF FFDBFFDF {} {First surrogate pair} + utf-16le A\u03A9\u8A9E\U00010384 4100A9039E8A00D884DF {} {Unicode 2.5} + + utf-16be \u0000 0000 {} {Lowest code unit} + utf-16be \uD7FF D7FF {} {Below high surrogate range} + utf-16be \uE000 E000 {} {Above low surrogate range} + utf-16be \uFFFF FFFF {} {Highest code unit} + utf-16be \U010000 D800DC00 {} {First surrogate pair} + utf-16be \U10FFFF DBFFDFFF {} {First surrogate pair} + utf-16be A\u03A9\u8A9E\U00010384 004103A98A9ED800DF84 {} {Unicode 2.5} + + utf-32le \u0000 00000000 {} {Lowest code unit} + utf-32le \uFFFF FFFF0000 {} {Highest BMP} + utf-32le \U010000 00000100 {} {First supplementary} + utf-32le \U10FFFF ffff1000 {} {Last supplementary} + utf-32le A\u03A9\u8A9E\U00010384 41000000A90300009E8A000084030100 {} {Unicode 2.5} + + utf-32be \u0000 00000000 {} {Lowest code unit} + utf-32be \uFFFF 0000FFFF {} {Highest BMP} + utf-32be \U010000 00010000 {} {First supplementary} + utf-32be \U10FFFF 0010FFFF {} {Last supplementary} + utf-32be A\u03A9\u8A9E\U00010384 00000041000003A900008A9E00010384 {} {Unicode 2.5} } # Invalid byte sequences. These are driven from a table with format @@ -211,8 +254,7 @@ set encValidStrings { # If the ctrl field is empty it is treated as all of the above # Note if there is any other value by itself, it will cause the test to # be skipped. This is intentional to skip known bugs. - -# TODO - other encodings and test cases +# TODO - non-UTF encodings # ascii - Any byte above 127 is invalid and is mapped # to the same numeric code point except for the range @@ -616,8 +658,6 @@ lappend encInvalidBytes {*}{ utf-8 F48FBFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF} utf-8 F48FBFD0 strict {} 0 {} {Third trail byte must be 80:BF} - - utf-8 F5 tcl8 \u00F5 -1 {} {F5:FF are invalid everywhere} utf-8 F5 replace \uFFFD -1 {} {F5:FF are invalid everywhere} utf-8 F5 strict {} 0 {} {F5:FF are invalid everywhere} @@ -631,42 +671,73 @@ lappend encInvalidBytes {*}{ utf-8 E180E2F09192F1BF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {knownW3C} {Unicode Table 3.11} } -set xxencInvalidBytes { - - utf-8 \x41\x80\x42 tcl8 A\u0080B -1 80 - utf-8 \x41\x80\x42 replace A\uFFFDB -1 80 - utf-8 \x41\x80\x42 strict A 1 80 - utf-8 \x41\xC0\x80\x42 tcl8 A\u0000B -1 C080 - utf-8 \x41\xC0\x80\x42 strict A 1 C080 - utf-8 \x41\xC1\x42 tcl8 A\u00C1B -1 C1 - utf-8 \x41\xC1\x42 replace A\uFFFDB -1 C1 - utf-8 \x41\xC1\x42 strict A 1 C1 - utf-8 \x41\xC2\x42 tcl8 A\u00C2B -1 C2-nontrail - utf-8 \x41\xC2\x42 replace A\uFFFDB -1 C2-nontrail - utf-8 \x41\xC2\x42 strict A 1 C2-nontrail - utf-8 \x41\xC2 tcl8 A\u00C2 -1 C2-incomplete - utf-8 \x41\xC2 replace A\uFFFD -1 C2-incomplete - utf-8 \x41\xC2 strict A 1 C2-incomplete - utf-8 A\xed\xa0\x80B tcl8 A\uD800B -1 High-surrogate - utf-8 A\xed\xa0\x80B strict A 1 High-surrogate - utf-8 A\xed\xb0\x80B tcl8 A\uDC00B -1 Low-surrogate - utf-8 A\xed\xb0\x80B strict A 1 Low-surrogate - utf-8 \xed\xa0\x80\xed\xb0\x80 tcl8 \U00010000 -1 High-low-surrogate - utf-8 \xed\xa0\x80\xed\xb0\x80 strict {} 0 High-low-surrogate +# utf16-le and utf16-be test cases. Note utf16 cases are automatically generated +# based on these depending on platform endianness. Note truncated tests can only +# happen when the sequence is at the end (including by itself) Thus {solo tail} +# in some cases. +lappend encInvalidBytes {*}{ + utf-16le 41 tcl8 {} -1 {solo tail} {Truncated} + utf-16le 41 replace \uFFFD -1 {solo tail} {Truncated} + utf-16le 41 strict {} 0 {solo tail} {Truncated} + utf-16le 00D8 tcl8 \uD800 -1 {} {Missing low surrogate} + utf-16le 00D8 replace \uFFFD -1 {knownBug} {Missing low surrogate} + utf-16le 00D8 strict {} 0 {knownBug} {Missing low surrogate} + utf-16le 00DC tcl8 \uDC00 -1 {} {Missing high surrogate} + utf-16le 00DC replace \uFFFD -1 {knownBug} {Missing high surrogate} + utf-16le 00DC strict {} 0 {knownBug} {Missing high surrogate} } -set utf32-le-TODO { - utf-32le \x00\xD8\x00\x00 tcl8 \uD800 -1 {High-surrogate} - utf-32le \x00\xD8\x00\x00 strict "" 0 {High-surrogate} - utf-32le \x00\xDC\x00\x00 tcl8 \uDC00 -1 {Low-surrogate} - utf-32le \x00\xDC\x00\x00 strict "" 0 {Low-surrogate} - utf-32le \x00\xD8\x00\x00\x00\xDC\x00\x00 tcl8 \uD800\uDC00 -1 {High-low-surrogate} - utf-32le \x00\xD8\x00\x00\x00\xDC\x00\x00 strict "" 0 {High-low-surrogate} - utf-32le \x00\xDC\x00\x00\x00\xD8\x00\x00 tcl8 \uDC00\uD800 -1 {High-low-surrogate} - utf-32le \x00\xDC\x00\x00\x00\xD8\x00\x00 strict "" 0 {High-low-surrogate} - utf-32le \x41\x00\x00\x00\x00\xD8\x00\x00\x42\x00\x00\x00 tcl8 A\uD800B -1 {High-surrogate-middle} - utf-32le \x41\x00\x00\x00\x00\xD8\x00\x00\x42\x00\x00\x00 strict A 4 {High-surrogate-middle} + +# utf32-le and utf32-be test cases. Note utf32 cases are automatically generated +# based on these depending on platform endianness. Note truncated tests can only +# happen when the sequence is at the end (including by itself) Thus {solo tail} +# in some cases. +lappend encInvalidBytes {*}{ + utf-32le 41 tcl8 {} -1 {solo tail} {Truncated} + utf-32le 41 replace \uFFFD -1 {solo} {Truncated} + utf-32le 41 strict {} 0 {solo tail} {Truncated} + utf-32le 4100 tcl8 {} -1 {solo tail} {Truncated} + utf-32le 4100 replace \uFFFD -1 {solo} {Truncated} + utf-32le 4100 strict {} 0 {solo tail} {Truncated} + utf-32le 410000 tcl8 {} -1 {solo tail} {Truncated} + utf-32le 410000 replace \uFFFD -1 {solo} {Truncated} + utf-32le 410000 strict {} 0 {solo tail} {Truncated} + utf-32le 00D80000 tcl8 \uD800 -1 {} {High-surrogate} + utf-32le 00D80000 replace \uFFFD -1 {} {High-surrogate} + utf-32le 00D80000 strict {} 0 {} {High-surrogate} + utf-32le 00DC0000 tcl8 \uDC00 -1 {} {Low-surrogate} + utf-32le 00DC0000 replace \uFFFD -1 {} {Low-surrogate} + utf-32le 00DC0000 strict {} 0 {} {Low-surrogate} + utf-32le 00D8000000DC0000 tcl8 \uD800\uDC00 -1 {} {High-low-surrogate-pair} + utf-32le 00D8000000DC0000 replace \uFFFD\uFFFD -1 {} {High-low-surrogate-pair} + utf-32le 00D8000000DC0000 strict {} 0 {} {High-low-surrogate-pair} + utf-32le 00001100 tcl8 \UFFFD -1 {} {Out of range} + utf-32le 00001100 replace \UFFFD -1 {} {Out of range} + utf-32le 00001100 strict {} 0 {} {Out of range} + utf-32le FFFFFFFF tcl8 \UFFFD -1 {} {Out of range} + utf-32le FFFFFFFF replace \UFFFD -1 {} {Out of range} + utf-32le FFFFFFFF strict {} 0 {} {Out of range} + + utf-32be 41 tcl8 {} -1 {solo tail} {Truncated} + utf-32be 0041 tcl8 {} -1 {solo tail} {Truncated} + utf-32be 000041 tcl8 {} -1 {solo tail} {Truncated} + utf-32be 0000D800 tcl8 \uD800 -1 {} {High-surrogate} + utf-32be 0000D800 replace \uFFFD -1 {} {High-surrogate} + utf-32be 0000D800 strict {} 0 {} {High-surrogate} + utf-32be 0000DC00 tcl8 \uDC00 -1 {} {Low-surrogate} + utf-32be 0000DC00 replace \uFFFD -1 {} {Low-surrogate} + utf-32be 0000DC00 strict {} 0 {} {Low-surrogate} + utf-32be 0000D8000000DC00 tcl8 \uD800\uDC00 -1 {} {High-low-surrogate-pair} + utf-32be 0000D8000000DC00 replace \uFFFD\uFFFD -1 {} {High-low-surrogate-pair} + utf-32be 0000D8000000DC00 strict {} 0 {} {High-low-surrogate-pair} + utf-32be 00110000 tcl8 \UFFFD -1 {} {Out of range} + utf-32be 00110000 replace \UFFFD -1 {} {Out of range} + utf-32be 00110000 strict {} 0 {} {Out of range} + utf-32be FFFFFFFF tcl8 \UFFFD -1 {} {Out of range} + utf-32be FFFFFFFF replace \UFFFD -1 {} {Out of range} + utf-32be FFFFFFFF strict {} 0 {} {Out of range} } + # Strings that cannot be encoded for specific encoding / profiles # {encoding string profile exptedresult expectedfailindex ctrl comment} # should be unique for test ids to be unique. @@ -682,7 +753,7 @@ set utf32-le-TODO { # If the ctrl field is empty it is treated as all of the above # Note if there is any other value by itself, it will cause the test to # be skipped. This is intentional to skip known bugs. -# TODO - other encodings and test cases +# TODO - other encodings # TODO - out of range code point (note cannot be generated by \U notation) set encUnencodableStrings { ascii \u00e0 tcl8 3f -1 {} {unencodable} @@ -883,7 +954,8 @@ testconvert cmdAH-4.3.12 { } # convertfrom ?-profile? : valid byte sequences -foreach {enc str hex} $encValidStrings { +foreach {enc str hex ctrl comment} $encValidStrings { + if {"knownBug" in $ctrl} continue set bytes [binary decode hex $hex] set prefix A set suffix B @@ -899,6 +971,7 @@ foreach {enc str hex} $encValidStrings { # convertfrom ?-profile? : invalid byte sequences foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { + if {"knownBug" in $ctrl} continue set bytes [binary format H* $hex] set prefix A set suffix B @@ -945,12 +1018,13 @@ foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { } # convertfrom -failindex ?-profile? - valid data -foreach {enc str hex} $encValidStrings { +foreach {enc str hex ctrl comment} $encValidStrings { + if {"knownBug" in $ctrl} continue set bytes [binary decode hex $hex] set prefix A set suffix B - set prefix_bytes [encoding convertto $enc A] - set suffix_bytes [encoding convertto $enc B] + set prefix_bytes [encoding convertto $enc $prefix] + set suffix_bytes [encoding convertto $enc $suffix] foreach profile $encProfiles { testfailindex cmdAH-4.3.14.$hex.solo convertfrom $enc $bytes [list $str -1] $profile testfailindex cmdAH-4.3.14.$hex.lead convertfrom $enc $bytes$suffix_bytes [list $str$suffix -1] $profile @@ -961,11 +1035,14 @@ foreach {enc str hex} $encValidStrings { # convertfrom -failindex ?-profile? - invalid data foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { + if {"knownBug" in $ctrl} continue # There are multiple test cases based on location of invalid bytes set bytes [binary decode hex $hex] set prefix A set suffix B - set prefixLen [string length [encoding convertto $enc $prefix]] + set prefix_bytes [encoding convertto $enc $prefix] + set suffix_bytes [encoding convertto $enc $suffix] + set prefixLen [string length $prefix_bytes] if {$ctrl eq {} || "solo" in $ctrl} { testfailindex cmdAH-4.3.14.$hex.solo convertfrom $enc $bytes [list $str $failidx] $profile } @@ -977,7 +1054,7 @@ foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { # Failure expected set result "" } - testfailindex cmdAH-4.3.14.$hex.lead convertfrom $enc $bytes$suffix [list $result $failidx] $profile + testfailindex cmdAH-4.3.14.$hex.lead convertfrom $enc $bytes$suffix_bytes [list $result $failidx] $profile } if {$ctrl eq {} || "tail" in $ctrl} { set expected_failidx $failidx @@ -989,7 +1066,7 @@ foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { set result $prefix incr expected_failidx $prefixLen } - testfailindex cmdAH-4.3.14.$hex.tail convertfrom $enc $prefix$bytes [list $result $expected_failidx] $profile + testfailindex cmdAH-4.3.14.$hex.tail convertfrom $enc $prefix_bytes$bytes [list $result $expected_failidx] $profile } if {$ctrl eq {} || "middle" in $ctrl} { set expected_failidx $failidx @@ -1001,7 +1078,7 @@ foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { set result $prefix incr expected_failidx $prefixLen } - testfailindex cmdAH-4.3.14.$hex.middle convertfrom $enc $prefix$bytes$suffix [list $result $expected_failidx] $profile + testfailindex cmdAH-4.3.14.$hex.middle convertfrom $enc $prefix_bytes$bytes$suffix_bytes [list $result $expected_failidx] $profile } } @@ -1041,7 +1118,8 @@ testconvert cmdAH-4.4.12 { # convertto ?-profile? : valid byte sequences -foreach {enc str hex} $encValidStrings { +foreach {enc str hex ctrl comment} $encValidStrings { + if {"knownBug" in $ctrl} continue set bytes [binary decode hex $hex] set printable [printable $str] set prefix A @@ -1058,6 +1136,7 @@ foreach {enc str hex} $encValidStrings { # convertto ?-profile? : invalid byte sequences foreach {enc str profile hex failidx ctrl comment} $encUnencodableStrings { + if {"knownBug" in $ctrl} continue set bytes [binary decode hex $hex] set printable [printable $str] set prefix A @@ -1105,7 +1184,8 @@ foreach {enc str profile hex failidx ctrl comment} $encUnencodableStrings { } # convertto -failindex ?-profile? - valid data -foreach {enc str hex} $encValidStrings { +foreach {enc str hex ctrl comment} $encValidStrings { + if {"knownBug" in $ctrl} continue set bytes [binary decode hex $hex] set printable [printable $str] set prefix A @@ -1122,6 +1202,7 @@ foreach {enc str hex} $encValidStrings { # convertto -failindex ?-profile? - invalid data foreach {enc str profile hex failidx ctrl comment} $encUnencodableStrings { + if {"knownBug" in $ctrl} continue set bytes [binary decode hex $hex] set printable [printable $str] set prefix A -- cgit v0.12 From fa9ac8a850701b20b6c178fdbf30b705148ffd6b Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Mon, 20 Feb 2023 15:41:15 +0000 Subject: Fix replace profile handling of truncated surrogates --- generic/tclCmdAH.c | 9 +++++---- generic/tclEncoding.c | 42 ++++++++++++++++++++++++++++++++++++------ 2 files changed, 41 insertions(+), 10 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 692c75b..4dfb541 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -695,7 +695,8 @@ EncodingConvertfromObjCmd( } result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, flags, &ds); - if (result != TCL_INDEX_NONE) { + if (result != TCL_INDEX_NONE && + TCL_ENCODING_PROFILE_GET(flags) != TCL_ENCODING_PROFILE_TCL8) { if (failVarObj != NULL) { if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; @@ -776,7 +777,8 @@ EncodingConverttoObjCmd( stringPtr = TclGetStringFromObj(data, &length); result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, flags, &ds); - if (result != TCL_INDEX_NONE) { + if (result != TCL_INDEX_NONE && + TCL_ENCODING_PROFILE_GET(flags) != TCL_ENCODING_PROFILE_TCL8) { if (failVarObj != NULL) { /* I hope, wide int will cover size_t data type */ if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) { @@ -795,8 +797,7 @@ EncodingConverttoObjCmd( Tcl_DStringFree(&ds); return TCL_ERROR; } - } - else if (failVarObj != NULL) { + } else if (failVarObj != NULL) { if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(-1), TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 7e5ec22..024570a 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2594,7 +2594,7 @@ Utf32ToUtfProc( { const char *srcStart, *srcEnd; const char *dstEnd, *dstStart; - int result, numChars, charLimit = INT_MAX; + int result, extra, numChars, charLimit = INT_MAX; int ch = 0; flags |= PTR2INT(clientData); @@ -2606,8 +2606,9 @@ Utf32ToUtfProc( /* * Check alignment with utf-32 (4 == sizeof(UTF-32)) */ - - if ((srcLen % 4) != 0) { + extra = srcLen % 4; + if (extra != 0) { + /* We have a truncated code unit */ result = TCL_CONVERT_MULTIBYTE; srcLen &= -4; } @@ -2669,13 +2670,27 @@ Utf32ToUtfProc( } else { dst += Tcl_UniCharToUtf(ch, dst); } - src += sizeof(unsigned int); + src += 4; } if ((ch & ~0x3FF) == 0xD800) { /* Bug [10c2c17c32]. If Hi surrogate, finish 3-byte UTF-8 */ dst += Tcl_UniCharToUtf(-1, dst); } + /* + * If we had a truncated code unit at the end AND this is the last + * fragment AND profile is "replace", stick FFFD in its place. + */ + if (extra && (flags & TCL_ENCODING_END) && PROFILE_REPLACE(flags)) { + src += extra; /* Go past truncated code unit */ + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + } else { + dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst); + result = TCL_OK; + } + } + *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; *dstCharsPtr = numChars; @@ -2822,7 +2837,7 @@ Utf16ToUtfProc( { const char *srcStart, *srcEnd; const char *dstEnd, *dstStart; - int result, numChars, charLimit = INT_MAX; + int result, extra, numChars, charLimit = INT_MAX; unsigned short ch = 0; flags |= PTR2INT(clientData); @@ -2835,7 +2850,8 @@ Utf16ToUtfProc( * Check alignment with utf-16 (2 == sizeof(UTF-16)) */ - if ((srcLen % 2) != 0) { + extra = srcLen % 2; + if (extra != 0) { result = TCL_CONVERT_MULTIBYTE; srcLen--; } @@ -2891,6 +2907,20 @@ Utf16ToUtfProc( /* Bug [10c2c17c32]. If Hi surrogate, finish 3-byte UTF-8 */ dst += Tcl_UniCharToUtf(-1, dst); } + /* + * If we had a truncated code unit at the end AND this is the last + * fragment AND profile is "replace", stick FFFD in its place. + */ + if (extra && (flags & TCL_ENCODING_END) && PROFILE_REPLACE(flags)) { + ++src;/* Go past the truncated code unit */ + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + } else { + dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst); + result = TCL_OK; + } + } + *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; *dstCharsPtr = numChars; -- cgit v0.12 From 280034d2ab7356da4aadf99bcade5d106a3da1b2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Feb 2023 20:41:00 +0000 Subject: Proposed fix for [4bea02e811]: encoding convertfrom -strict ascii \x7f generates exception --- library/encoding/ascii.enc | 2 +- library/encoding/cp1250.enc | 4 ++-- library/encoding/cp1251.enc | 2 +- library/encoding/cp1252.enc | 4 ++-- library/encoding/cp1253.enc | 4 ++-- library/encoding/cp1257.enc | 4 ++-- library/encoding/cp1258.enc | 4 ++-- library/encoding/cp864.enc | 2 +- library/encoding/cp869.enc | 4 ++-- library/encoding/cp874.enc | 4 ++-- library/encoding/cp932.enc | 2 +- library/encoding/cp949.enc | 2 +- library/encoding/cp950.enc | 4 ++-- library/encoding/tis-620.enc | 2 +- tools/encoding/Makefile | 7 +------ tools/encoding/ascii.txt | 1 + 16 files changed, 24 insertions(+), 28 deletions(-) diff --git a/library/encoding/ascii.enc b/library/encoding/ascii.enc index e0320b8..284a9f5 100644 --- a/library/encoding/ascii.enc +++ b/library/encoding/ascii.enc @@ -9,7 +9,7 @@ S 0040004100420043004400450046004700480049004A004B004C004D004E004F 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F -0070007100720073007400750076007700780079007A007B007C007D007E0000 +0070007100720073007400750076007700780079007A007B007C007D007E007F 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 diff --git a/library/encoding/cp1250.enc b/library/encoding/cp1250.enc index 070ad90..f40b485 100644 --- a/library/encoding/cp1250.enc +++ b/library/encoding/cp1250.enc @@ -10,8 +10,8 @@ S 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F -20AC0081201A0083201E2026202020210088203001602039015A0164017D0179 -009020182019201C201D202220132014009821220161203A015B0165017E017A +20AC0000201A0000201E2026202020210000203001602039015A0164017D0179 +000020182019201C201D202220132014000021220161203A015B0165017E017A 00A002C702D8014100A4010400A600A700A800A9015E00AB00AC00AD00AE017B 00B000B102DB014200B400B500B600B700B80105015F00BB013D02DD013E017C 015400C100C2010200C40139010600C7010C00C9011800CB011A00CD00CE010E diff --git a/library/encoding/cp1251.enc b/library/encoding/cp1251.enc index 376b1b4..f9513c2 100644 --- a/library/encoding/cp1251.enc +++ b/library/encoding/cp1251.enc @@ -11,7 +11,7 @@ S 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F 04020403201A0453201E20262020202120AC203004092039040A040C040B040F -045220182019201C201D202220132014009821220459203A045A045C045B045F +045220182019201C201D202220132014000021220459203A045A045C045B045F 00A0040E045E040800A4049000A600A7040100A9040400AB00AC00AD00AE0407 00B000B104060456049100B500B600B704512116045400BB0458040504550457 0410041104120413041404150416041704180419041A041B041C041D041E041F diff --git a/library/encoding/cp1252.enc b/library/encoding/cp1252.enc index dd525ea..b45a7f8 100644 --- a/library/encoding/cp1252.enc +++ b/library/encoding/cp1252.enc @@ -10,8 +10,8 @@ S 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F -20AC0081201A0192201E20262020202102C62030016020390152008D017D008F -009020182019201C201D20222013201402DC21220161203A0153009D017E0178 +20AC0000201A0192201E20262020202102C620300160203901520000017D0000 +000020182019201C201D20222013201402DC21220161203A01530000017E0178 00A000A100A200A300A400A500A600A700A800A900AA00AB00AC00AD00AE00AF 00B000B100B200B300B400B500B600B700B800B900BA00BB00BC00BD00BE00BF 00C000C100C200C300C400C500C600C700C800C900CA00CB00CC00CD00CE00CF diff --git a/library/encoding/cp1253.enc b/library/encoding/cp1253.enc index a8754c3..dcc8084 100644 --- a/library/encoding/cp1253.enc +++ b/library/encoding/cp1253.enc @@ -10,8 +10,8 @@ S 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F -20AC0081201A0192201E20262020202100882030008A2039008C008D008E008F -009020182019201C201D20222013201400982122009A203A009C009D009E009F +20AC0000201A0192201E20262020202100002030000020390000000000000000 +000020182019201C201D202220132014000021220000203A0000000000000000 00A00385038600A300A400A500A600A700A800A9000000AB00AC00AD00AE2015 00B000B100B200B3038400B500B600B703880389038A00BB038C00BD038E038F 0390039103920393039403950396039703980399039A039B039C039D039E039F diff --git a/library/encoding/cp1257.enc b/library/encoding/cp1257.enc index 4aa135d..42c6905 100644 --- a/library/encoding/cp1257.enc +++ b/library/encoding/cp1257.enc @@ -10,8 +10,8 @@ S 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F -20AC0081201A0083201E20262020202100882030008A2039008C00A802C700B8 -009020182019201C201D20222013201400982122009A203A009C00AF02DB009F +20AC0000201A0000201E2026202020210000203000002039000000A802C700B8 +000020182019201C201D202220132014000021220000203A000000AF02DB0000 00A0000000A200A300A4000000A600A700D800A9015600AB00AC00AD00AE00C6 00B000B100B200B300B400B500B600B700F800B9015700BB00BC00BD00BE00E6 0104012E0100010600C400C501180112010C00C90179011601220136012A013B diff --git a/library/encoding/cp1258.enc b/library/encoding/cp1258.enc index 95fdef8..bbe2b12 100644 --- a/library/encoding/cp1258.enc +++ b/library/encoding/cp1258.enc @@ -10,8 +10,8 @@ S 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F -20AC0081201A0192201E20262020202102C62030008A20390152008D008E008F -009020182019201C201D20222013201402DC2122009A203A0153009D009E0178 +20AC0000201A0192201E20262020202102C62030000020390152000000000000 +000020182019201C201D20222013201402DC21220000203A0153000000000178 00A000A100A200A300A400A500A600A700A800A900AA00AB00AC00AD00AE00AF 00B000B100B200B300B400B500B600B700B800B900BA00BB00BC00BD00BE00BF 00C000C100C2010200C400C500C600C700C800C900CA00CB030000CD00CE00CF diff --git a/library/encoding/cp864.enc b/library/encoding/cp864.enc index 71f9e62..dad7c20 100644 --- a/library/encoding/cp864.enc +++ b/library/encoding/cp864.enc @@ -11,7 +11,7 @@ S 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F 00B000B72219221A259225002502253C2524252C251C25342510250C25142518 -03B2221E03C600B100BD00BC224800AB00BBFEF7FEF8009B009CFEFBFEFC009F +03B2221E03C600B100BD00BC224800AB00BBFEF7FEF800000000FEFBFEFC0000 00A000ADFE8200A300A4FE8400000000FE8EFE8FFE95FE99060CFE9DFEA1FEA5 0660066106620663066406650666066706680669FED1061BFEB1FEB5FEB9061F 00A2FE80FE81FE83FE85FECAFE8BFE8DFE91FE93FE97FE9BFE9FFEA3FEA7FEA9 diff --git a/library/encoding/cp869.enc b/library/encoding/cp869.enc index 9fd2929..4670826 100644 --- a/library/encoding/cp869.enc +++ b/library/encoding/cp869.enc @@ -10,8 +10,8 @@ S 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F -0080008100820083008400850386008700B700AC00A620182019038820150389 -038A03AA038C00930094038E03AB00A9038F00B200B303AC00A303AD03AE03AF +0000000000000000000000000386000000B700AC00A620182019038820150389 +038A03AA038C00000000038E03AB00A9038F00B200B303AC00A303AD03AE03AF 03CA039003CC03CD039103920393039403950396039700BD0398039900AB00BB 25912592259325022524039A039B039C039D256325512557255D039E039F2510 25142534252C251C2500253C03A003A1255A25542569256625602550256C03A3 diff --git a/library/encoding/cp874.enc b/library/encoding/cp874.enc index 0487b97..e2e8433 100644 --- a/library/encoding/cp874.enc +++ b/library/encoding/cp874.enc @@ -10,8 +10,8 @@ S 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F -20AC008100820083008420260086008700880089008A008B008C008D008E008F -009020182019201C201D20222013201400980099009A009B009C009D009E009F +20AC000000000000000020260000000000000000000000000000000000000000 +000020182019201C201D20222013201400000000000000000000000000000000 00A00E010E020E030E040E050E060E070E080E090E0A0E0B0E0C0E0D0E0E0E0F 0E100E110E120E130E140E150E160E170E180E190E1A0E1B0E1C0E1D0E1E0E1F 0E200E210E220E230E240E250E260E270E280E290E2A0E2B0E2C0E2D0E2E0E2F diff --git a/library/encoding/cp932.enc b/library/encoding/cp932.enc index 8da8cd6..0699000 100644 --- a/library/encoding/cp932.enc +++ b/library/encoding/cp932.enc @@ -10,7 +10,7 @@ M 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F -0080000000000000000000850086000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000FF61FF62FF63FF64FF65FF66FF67FF68FF69FF6AFF6BFF6CFF6DFF6EFF6F FF70FF71FF72FF73FF74FF75FF76FF77FF78FF79FF7AFF7BFF7CFF7DFF7EFF7F diff --git a/library/encoding/cp949.enc b/library/encoding/cp949.enc index 2f3ec39..459dbd9 100644 --- a/library/encoding/cp949.enc +++ b/library/encoding/cp949.enc @@ -10,7 +10,7 @@ M 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F -0080000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 diff --git a/library/encoding/cp950.enc b/library/encoding/cp950.enc index f33d785..f582bd9 100644 --- a/library/encoding/cp950.enc +++ b/library/encoding/cp950.enc @@ -10,8 +10,8 @@ M 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F -0080008100820083008400850086008700880089008A008B008C008D008E008F -0090009100920093009400950096009700980099009A009B009C009D009E009F +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 diff --git a/library/encoding/tis-620.enc b/library/encoding/tis-620.enc index 2e9142a..af77326 100644 --- a/library/encoding/tis-620.enc +++ b/library/encoding/tis-620.enc @@ -9,7 +9,7 @@ S 0040004100420043004400450046004700480049004A004B004C004D004E004F 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F -0070007100720073007400750076007700780079007A007B007C007D007E0000 +0070007100720073007400750076007700780079007A007B007C007D007E007F 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00000E010E020E030E040E050E060E070E080E090E0A0E0B0E0C0E0D0E0E0E0F diff --git a/tools/encoding/Makefile b/tools/encoding/Makefile index 361239e..7235b47 100644 --- a/tools/encoding/Makefile +++ b/tools/encoding/Makefile @@ -67,15 +67,10 @@ encodings: clean txt2enc $(EUC_ENCODINGS) @for p in *.txt; do \ enc=`echo $$p | sed 's/\..*$$/\.enc/'`; \ echo $$enc; \ - ./txt2enc -e 0 -u 1 $$p > $$enc; \ + ./txt2enc -m $$p > $$enc; \ done @echo @echo Compiling special versions of encoding files. - @for p in ascii.txt; do \ - enc=`echo $$p | sed 's/\..*$$/\.enc/'`; \ - echo $$enc; \ - ./txt2enc -m $$p > $$enc; \ - done @for p in jis0208.txt; do \ enc=`echo $$p | sed 's/\..*$$/\.enc/'`; \ echo $$enc; \ diff --git a/tools/encoding/ascii.txt b/tools/encoding/ascii.txt index 66ba6f3..2afbaab 100644 --- a/tools/encoding/ascii.txt +++ b/tools/encoding/ascii.txt @@ -93,3 +93,4 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE +0x7F 0x007F # DELETE \ No newline at end of file -- cgit v0.12 From 8660fd1af23543a70d94adaec5d7b98105ad3ca3 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Feb 2023 20:52:06 +0000 Subject: Two more files, re-generated --- library/encoding/cp1254.enc | 4 ++-- library/encoding/cp1255.enc | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/library/encoding/cp1254.enc b/library/encoding/cp1254.enc index b9e3b3c..4922f3c 100644 --- a/library/encoding/cp1254.enc +++ b/library/encoding/cp1254.enc @@ -10,8 +10,8 @@ S 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F -20AC0081201A0192201E20262020202102C62030016020390152008D008E008F -009020182019201C201D20222013201402DC21220161203A0153009D009E0178 +20AC0000201A0192201E20262020202102C62030016020390152000000000000 +000020182019201C201D20222013201402DC21220161203A0153000000000178 00A000A100A200A300A400A500A600A700A800A900AA00AB00AC00AD00AE00AF 00B000B100B200B300B400B500B600B700B800B900BA00BB00BC00BD00BE00BF 00C000C100C200C300C400C500C600C700C800C900CA00CB00CC00CD00CE00CF diff --git a/library/encoding/cp1255.enc b/library/encoding/cp1255.enc index 6e78b95..74ef0c1 100644 --- a/library/encoding/cp1255.enc +++ b/library/encoding/cp1255.enc @@ -10,8 +10,8 @@ S 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F -20AC0081201A0192201E20262020202102C62030008A2039008C008D008E008F -009020182019201C201D20222013201402DC2122009A203A009C009D009E009F +20AC0000201A0192201E20262020202102C62030000020390000000000000000 +000020182019201C201D20222013201402DC21220000203A0000000000000000 00A000A100A200A320AA00A500A600A700A800A900D700AB00AC00AD00AE00AF 00B000B100B200B300B400B500B600B700B800B900F700BB00BC00BD00BE00BF 05B005B105B205B305B405B505B605B705B805B9000005BB05BC05BD05BE05BF -- cgit v0.12 From 3315012c955111ef840365ecd7cc4ff46a15e204 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 20 Feb 2023 21:43:29 +0000 Subject: re-generated 8 more encodings --- library/encoding/big5.enc | 4 ++-- library/encoding/euc-cn.enc | 4 ++-- library/encoding/euc-jp.enc | 4 ++-- library/encoding/euc-kr.enc | 4 ++-- library/encoding/gb1988.enc | 4 ++-- library/encoding/jis0201.enc | 4 ++-- library/encoding/macJapan.enc | 2 +- library/encoding/shiftjis.enc | 2 +- tools/encoding/big5.txt | 1 + 9 files changed, 15 insertions(+), 14 deletions(-) diff --git a/library/encoding/big5.enc b/library/encoding/big5.enc index 26179f4..d6ff760 100644 --- a/library/encoding/big5.enc +++ b/library/encoding/big5.enc @@ -10,8 +10,8 @@ M 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F -0080008100820083008400850086008700880089008A008B008C008D008E008F -0090009100920093009400950096009700980099009A009B009C009D009E009F +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 diff --git a/library/encoding/euc-cn.enc b/library/encoding/euc-cn.enc index 4b2f8c7..ff0f984 100644 --- a/library/encoding/euc-cn.enc +++ b/library/encoding/euc-cn.enc @@ -10,8 +10,8 @@ M 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F -0080008100820083008400850086008700880089008A008B008C008D008E008F -0090009100920093009400950096009700980099009A009B009C009D009E009F +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 diff --git a/library/encoding/euc-jp.enc b/library/encoding/euc-jp.enc index db56c88..d4337d9 100644 --- a/library/encoding/euc-jp.enc +++ b/library/encoding/euc-jp.enc @@ -10,8 +10,8 @@ M 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F -0080008100820083008400850086008700880089008A008B008C008D0000008F -0090009100920093009400950096009700980099009A009B009C009D009E009F +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 diff --git a/library/encoding/euc-kr.enc b/library/encoding/euc-kr.enc index 5e9bb93..0433260 100644 --- a/library/encoding/euc-kr.enc +++ b/library/encoding/euc-kr.enc @@ -10,8 +10,8 @@ M 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F -0080008100820083008400850086008700880089008A008B008C008D008E008F -0090009100920093009400950096009700980099009A009B009C009D009E009F +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 diff --git a/library/encoding/gb1988.enc b/library/encoding/gb1988.enc index 298732c..8254684 100644 --- a/library/encoding/gb1988.enc +++ b/library/encoding/gb1988.enc @@ -10,8 +10,8 @@ S 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D203E007F -0080008100820083008400850086008700880089008A008B008C008D008E008F -0090009100920093009400950096009700980099009A009B009C009D009E009F +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 0000FF61FF62FF63FF64FF65FF66FF67FF68FF69FF6AFF6BFF6CFF6DFF6EFF6F FF70FF71FF72FF73FF74FF75FF76FF77FF78FF79FF7AFF7BFF7CFF7DFF7EFF7F FF80FF81FF82FF83FF84FF85FF86FF87FF88FF89FF8AFF8BFF8CFF8DFF8EFF8F diff --git a/library/encoding/jis0201.enc b/library/encoding/jis0201.enc index 64f423f..70e099d 100644 --- a/library/encoding/jis0201.enc +++ b/library/encoding/jis0201.enc @@ -10,8 +10,8 @@ S 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D203E007F -0080008100820083008400850086008700880089008A008B008C008D008E008F -0090009100920093009400950096009700980099009A009B009C009D009E009F +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 0000FF61FF62FF63FF64FF65FF66FF67FF68FF69FF6AFF6BFF6CFF6DFF6EFF6F FF70FF71FF72FF73FF74FF75FF76FF77FF78FF79FF7AFF7BFF7CFF7DFF7EFF7F FF80FF81FF82FF83FF84FF85FF86FF87FF88FF89FF8AFF8BFF8CFF8DFF8EFF8F diff --git a/library/encoding/macJapan.enc b/library/encoding/macJapan.enc index dba24bd..9f3f03b 100644 --- a/library/encoding/macJapan.enc +++ b/library/encoding/macJapan.enc @@ -10,7 +10,7 @@ M 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F -0080000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00A0FF61FF62FF63FF64FF65FF66FF67FF68FF69FF6AFF6BFF6CFF6DFF6EFF6F FF70FF71FF72FF73FF74FF75FF76FF77FF78FF79FF7AFF7BFF7CFF7DFF7EFF7F diff --git a/library/encoding/shiftjis.enc b/library/encoding/shiftjis.enc index 140aec4..3ba972e 100644 --- a/library/encoding/shiftjis.enc +++ b/library/encoding/shiftjis.enc @@ -10,7 +10,7 @@ M 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F -0080000000000000000000850086008700000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000FF61FF62FF63FF64FF65FF66FF67FF68FF69FF6AFF6BFF6CFF6DFF6EFF6F FF70FF71FF72FF73FF74FF75FF76FF77FF78FF79FF7AFF7BFF7CFF7DFF7EFF7F diff --git a/tools/encoding/big5.txt b/tools/encoding/big5.txt index 58cdfe2..06b0fac 100644 --- a/tools/encoding/big5.txt +++ b/tools/encoding/big5.txt @@ -185,6 +185,7 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE +0x7F 0x007F # DELETE 0xA140 0x3000 # IDEOGRAPHIC SPACE 0xA141 0xFF0C # FULLWIDTH COMMA 0xA142 0x3001 # IDEOGRAPHIC COMMA -- cgit v0.12 From 4d644dfb73457eb3615b30550dd31d1b48bfa7d4 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 21 Feb 2023 16:03:18 +0000 Subject: Generate test data from ICU UCM data files. SBCS only for now --- tools/ucm2tests.tcl | 185 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 185 insertions(+) create mode 100644 tools/ucm2tests.tcl diff --git a/tools/ucm2tests.tcl b/tools/ucm2tests.tcl new file mode 100644 index 0000000..22ae529 --- /dev/null +++ b/tools/ucm2tests.tcl @@ -0,0 +1,185 @@ +# ucm2tests.tcl +# +# Parses given ucm files (from ICU) to generate test data +# for encodings. The generated scripts are written to stdout. +# +# tclsh ucmtotests.tcl PATH_TO_ICU_UCM_DIRECTORY +# + +namespace eval ucm { + # No means to change these currently but ... + variable outputChan stdout + variable errorChan stderr + variable verbose 0 + + # Map Tcl encoding name to ICU UCM file name + variable encNameMap + array set encNameMap { + cp1250 glibc-CP1250-2.1.2 + cp1251 glibc-CP1251-2.1.2 + cp1252 glibc-CP1252-2.1.2 + cp1253 glibc-CP1253-2.1.2 + cp1254 glibc-CP1254-2.1.2 + cp1255 glibc-CP1255-2.1.2 + cp1256 glibc-CP1256-2.1.2 + cp1257 glibc-CP1257-2.1.2 + cp1258 glibc-CP1258-2.1.2 + iso8859-1 glibc-ISO_8859_1-2.1.2 + iso8859-2 glibc-ISO_8859_2-2.1.2 + iso8859-3 glibc-ISO_8859_3-2.1.2 + iso8859-4 glibc-ISO_8859_4-2.1.2 + iso8859-5 glibc-ISO_8859_5-2.1.2 + iso8859-6 glibc-ISO_8859_6-2.1.2 + iso8859-7 glibc-ISO_8859_7-2.3.3 + iso8859-8 glibc-ISO_8859_8-2.3.3 + iso8859-9 glibc-ISO_8859_9-2.1.2 + iso8859-10 glibc-ISO_8859_10-2.1.2 + iso8859-11 glibc-ISO_8859_11-2.1.2 + iso8859-13 glibc-ISO_8859_13-2.1.2 + iso8859-14 glibc-ISO_8859_14-2.1.2 + iso8859-15 glibc-ISO_8859_15-2.1.2 + iso8859-16 glibc-ISO_8859_16-2.3.3 + } + + # Dictionary Character map for Tcl encoding + variable charMap +} + +proc ucm::abort {msg} { + variable errorChan + puts $errorChan $msg + exit 1 +} +proc ucm::warn {msg} { + variable errorChan + puts $errorChan $msg +} +proc ucm::log {msg} { + variable verbose + if {$verbose} { + variable errorChan + puts $errorChan $msg + } +} +proc ucm::print {s} { + variable outputChan + puts $outputChan $s +} + +proc ucm::parse_SBCS {fd} { + set result {} + while {[gets $fd line] >= 0} { + if {[string match #* $line]} { + continue + } + if {[string equal "END CHARMAP" [string trim $line]]} { + break + } + if {![regexp {^\s*\s*((\\x[[:xdigit:]]{2})+)\s*(\|(0|1|2|3|4))} $line -> unichar bytes - - precision]} { + error "Unexpected line parsing SBCS: $line" + } + set bytes [string map {\\x {}} $bytes]; # \xNN -> NN + if {$precision eq "" || $precision eq "0"} { + lappend result $unichar $bytes + } else { + # It is a fallback mapping - ignore + } + } + return $result +} + +proc ucm::generate_tests {} { + variable encNameMap + variable charMap + + array set tclNames {} + foreach encName [encoding names] { + set tclNames($encName) "" + } + foreach encName [lsort [array names encNameMap]] { + if {![info exists charMap($encName)]} { + warn "No character map read for $encName" + continue + } + unset tclNames($encName) + print "\n# $encName (generated from $encNameMap($encName))" + print "lappend encValidStrings {*}{" + foreach {unich hex} $charMap($encName) { + print " $encName \\u$unich $hex {} {}" + } + print "}; # $encName" + } + if {[array size tclNames]} { + warn "Missing encoding: [lsort [array names tclNames]]" + } +} + +proc ucm::parse_file {encName ucmPath} { + variable charMap + set fd [open $ucmPath] + try { + # Parse the metadata + unset -nocomplain state + while {[gets $fd line] >= 0} { + if {[regexp {<(code_set_name|mb_cur_max|mb_cur_min|uconv_class|subchar)>\s+(\S+)} $line -> key val]} { + set state($key) $val + } elseif {[regexp {^\s*CHARMAP\s*$} $line]} { + set state(charmap) "" + break + } else { + # Skip all else + } + } + if {![info exists state(charmap)]} { + abort "Error: $path has No CHARMAP line." + } + foreach key {code_set_name uconv_class} { + if {[info exists state($key)]} { + set state($key) [string trim $state($key) {"}] + } + } + if {[info exists charMap($encName)]} { + abort "Duplicate file for $encName ($path)" + } + if {![info exists state(uconv_class)]} { + abort "Error: $path has no uconv_class definition." + } + switch -exact -- $state(uconv_class) { + SBCS { + if {[catch { + set charMap($encName) [parse_SBCS $fd] + } result]} { + abort "Could not process $path. $result" + } + } + default { + log "Skipping $path -- not SBCS encoding." + return + } + } + } finally { + close $fd + } +} + +proc ucm::expand_paths {patterns} { + set expanded {} + foreach pat $patterns { + # The file join is for \ -> / + lappend expanded {*}[glob -nocomplain [file join $pat]] + } + return $expanded +} + +proc ucm::run {} { + variable encNameMap + if {[llength $::argv] != 1} { + abort "Usage: [info nameofexecutable] $::argv0 PATHTOUCMFILES" + } + foreach {encName fname} [array get encNameMap] { + ucm::parse_file $encName [file join [lindex $::argv 0] ${fname}.ucm] + } + generate_tests +} + +ucm::run -- cgit v0.12 From 417f86869302e367a498d61a8bed0aa755746517 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 21 Feb 2023 16:09:18 +0000 Subject: Proposed fix for [534172ff5b]: Crash in DeleteReflectedChannelMap (introduced via tcllib 1.21) --- generic/tclIORChan.c | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 7ea50c8..8c6f25f 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -1128,8 +1128,8 @@ ReflectClose( /* * This call comes from TclFinalizeIOSystem. There are no * interpreters, and therefore we cannot call upon the handler command - * anymore. Threading is irrelevant as well. We simply clean up all - * our C level data structures and leave the Tcl level to the other + * anymore. Threading is irrelevant as well. Simply clean up all + * the C level data structures and leave the Tcl level to the other * finalization functions. */ @@ -2697,6 +2697,7 @@ DeleteThreadReflectedChannelMap( Tcl_ThreadId self = Tcl_GetCurrentThread(); ReflectedChannelMap *rcmPtr; /* The map */ ForwardingResult *resultPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); (void)dummy; /* @@ -2777,6 +2778,7 @@ DeleteThreadReflectedChannelMap( */ rcmPtr = GetThreadReflectedChannelMap(); + tsdPtr->rcmPtr = NULL; for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch); hPtr != NULL; hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) { @@ -3083,10 +3085,10 @@ ForwardProc( (paramPtr->seek.seekMode==SEEK_SET) ? "start" : (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1); - Tcl_IncrRefCount(offObj); - Tcl_IncrRefCount(baseObj); + Tcl_IncrRefCount(offObj); + Tcl_IncrRefCount(baseObj); - Tcl_Preserve(rcPtr); + Tcl_Preserve(rcPtr); if (InvokeTclMethod(rcPtr, METH_SEEK, offObj, baseObj, &resObj)!=TCL_OK){ ForwardSetObjError(paramPtr, resObj); paramPtr->seek.offset = -1; -- cgit v0.12 From 42956f6f09023c19e2c057150f6584f0f1f40b4c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 21 Feb 2023 16:58:13 +0000 Subject: Some test-cases start failing in 9.0-compatibility-mode (-DTCL_NO_DEPRECATED), if the system encoding is one with gaps. So, better use iso8859-1 for those testcases --- tests/chanio.test | 12 ++++++------ tests/io.test | 12 ++++++------ 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/tests/chanio.test b/tests/chanio.test index fb94051..61c168f 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -6736,8 +6736,8 @@ test chan-io-52.5 {TclCopyChannel, all} -constraints {fcopy} -setup { } -body { set f1 [open $thisScript] set f2 [open $path(test1) w] - chan configure $f1 -translation lf -blocking 0 - chan configure $f2 -translation lf -blocking 0 + chan configure $f1 -translation lf -encoding iso8859-1 -blocking 0 + chan configure $f2 -translation lf -encoding iso8859-1 -blocking 0 chan copy $f1 $f2 -size -1 ;# -1 means 'copy all', same as if no -size specified. set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] chan close $f1 @@ -6752,8 +6752,8 @@ test chan-io-52.5a {TclCopyChannel, all, other negative value} -setup { } -constraints {fcopy} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] - chan configure $f1 -translation lf -blocking 0 - chan configure $f2 -translation lf -blocking 0 + chan configure $f1 -translation lf -encoding iso8859-1 -blocking 0 + chan configure $f2 -translation lf -encoding iso8859-1 -blocking 0 chan copy $f1 $f2 -size -2 ;# < 0 behaves like -1, copy all set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] chan close $f1 @@ -6768,8 +6768,8 @@ test chan-io-52.5b {TclCopyChannel, all, wrap to negative value} -setup { } -constraints {fcopy} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] - chan configure $f1 -translation lf -blocking 0 - chan configure $f2 -translation lf -blocking 0 + chan configure $f1 -translation lf -encoding iso8859-1 -blocking 0 + chan configure $f2 -translation lf -encoding iso8859-1 -blocking 0 chan copy $f1 $f2 -size 3221176172 ;# Wrapped to < 0, behaves like -1, copy all set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] chan close $f1 diff --git a/tests/io.test b/tests/io.test index 7b8182e..aed7f85 100644 --- a/tests/io.test +++ b/tests/io.test @@ -7280,8 +7280,8 @@ test io-52.5 {TclCopyChannel, all} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation lf -blocking 0 + fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0 + fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0 fcopy $f1 $f2 -size -1 ;# -1 means 'copy all', same as if no -size specified. set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] close $f1 @@ -7297,8 +7297,8 @@ test io-52.5a {TclCopyChannel, all, other negative value} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation lf -blocking 0 + fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0 + fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0 fcopy $f1 $f2 -size -2 ;# < 0 behaves like -1, copy all set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] close $f1 @@ -7314,8 +7314,8 @@ test io-52.5b {TclCopyChannel, all, wrap to negative value} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation lf -blocking 0 + fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0 + fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0 fcopy $f1 $f2 -size 3221176172 ;# Wrapped to < 0, behaves like -1, copy all set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] close $f1 -- cgit v0.12 From 9b8fa27457c97577817b8f86b0b658a04867d7c7 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 21 Feb 2023 17:27:16 +0000 Subject: Rework ICU tests to check validity of whole charmap in one test, else too many tests. --- tests/cmdAH.test | 87 +++++++++++++++++++++++++++----------------- tools/ucm2tests.tcl | 101 ++++++++++++++++++++++++++++++++++++++++++++++------ 2 files changed, 144 insertions(+), 44 deletions(-) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 1fbe6d2..3be2f14 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -186,9 +186,11 @@ set encDefaultProfile tcl8; # Should reflect the default from implementation # TODO - valid sequences for different encodings - shiftjis etc. # Note utf-16, utf-32 missing because they are automatically # generated based on le/be versions. -set encValidStrings { +lappend encValidStrings {*}{ ascii \u0000 00 {} {Lowest ASCII} ascii \u007F 7F knownBug {Highest ASCII} + ascii \u007D 7D {} {Brace - just to verify test scripts are escaped correctly} + ascii \u007B 7B {} {Terminating brace - just to verify test scripts are escaped correctly} utf-8 \u0000 00 {} {Unicode Table 3.7 Row 1} utf-8 \u007F 7F {} {Unicode Table 3.7 Row 1} @@ -361,9 +363,28 @@ lappend encInvalidBytes {*}{ utf-8 C080 tcl8 \u0000 -1 {} {C080 -> U+0 in Tcl's internal modified UTF8} utf-8 C080 strict {} 0 {} {C080 -> invalid} utf-8 C080 replace \uFFFD -1 {} {C080 -> single replacement char} + utf-8 C0A2 tcl8 \u00C0\u00A2 -1 {} {websec.github.io - A} + utf-8 C0A2 replace \uFFFD\uFFFD -1 {} {websec.github.io - A} + utf-8 C0A2 strict {} 0 {} {websec.github.io - A} + utf-8 C0A7 tcl8 \u00C0\u00A7 -1 {} {websec.github.io - double quote} + utf-8 C0A7 replace \uFFFD\uFFFD -1 {} {websec.github.io - double quote} + utf-8 C0A7 strict {} 0 {} {websec.github.io - double quote} + utf-8 C0AE tcl8 \u00C0\u00AE -1 {} {websec.github.io - full stop} + utf-8 C0AE replace \uFFFD\uFFFD -1 {} {websec.github.io - full stop} + utf-8 C0AE strict {} 0 {} {websec.github.io - full stop} + utf-8 C0AF tcl8 \u00C0\u00AF -1 {} {websec.github.io - solidus} + utf-8 C0AF replace \uFFFD\uFFFD -1 {} {websec.github.io - solidus} + utf-8 C0AF strict {} 0 {} {websec.github.io - solidus} + utf-8 C1 tcl8 \u00C1 -1 {} {C1 is invalid everywhere} utf-8 C1 replace \uFFFD -1 {} {C1 is invalid everywhere} utf-8 C1 strict {} 0 {} {C1 is invalid everywhere} + utf-8 C181 tcl8 \u00C1\u0081 -1 {} {websec.github.io - base test (A)} + utf-8 C181 replace \uFFFD\uFFFD -1 {} {websec.github.io - base test (A)} + utf-8 C181 strict {} 0 {} {websec.github.io - base test (A)} + utf-8 C19C tcl8 \u00C1\u0153 -1 {} {websec.github.io - reverse solidus} + utf-8 C19C replace \uFFFD\uFFFD -1 {} {websec.github.io - reverse solidus} + utf-8 C19C strict {} 0 {} {websec.github.io - reverse solidus} utf-8 C2 tcl8 \u00C2 -1 {} {Missing trail byte} utf-8 C2 replace \uFFFD -1 {} {Missing trail byte} @@ -387,6 +408,9 @@ lappend encInvalidBytes {*}{ utf-8 E080 tcl8 \u00E0\u20AC -1 {} {First trail byte must be A0:BF} utf-8 E080 replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF} utf-8 E080 strict {} 0 {} {First trail byte must be A0:BF} + utf-8 E0819C tcl8 \u00E0\u0081\u0153 -1 {} {websec.github.io - reverse solidus} + utf-8 E0819C replace \uFFFD\uFFFD\uFFFD -1 {} {websec.github.io - reverse solidus} + utf-8 E0819C strict {} 0 {} {websec.github.io - reverse solidus} utf-8 E09F tcl8 \u00E0\u0178 -1 {} {First trail byte must be A0:BF} utf-8 E09F replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF} utf-8 E09F strict {} 0 {} {First trail byte must be A0:BF} @@ -526,6 +550,9 @@ lappend encInvalidBytes {*}{ utf-8 F0 tcl8 \u00F0 -1 {} {Missing trail byte} utf-8 F0 replace \uFFFD -1 {} {Missing trail byte} utf-8 F0 strict {} 0 {} {Missing trail byte} + utf-8 F080 tcl8 \u00F0\u20AC -1 {} {First trail byte must be 90:BF} + utf-8 F080 replace \uFFFD -1 {knownW3C} {First trail byte must be 90:BF} + utf-8 F080 strict {} 0 {} {First trail byte must be 90:BF} utf-8 F08F tcl8 \u00F0\u8F -1 {} {First trail byte must be 90:BF} utf-8 F08F replace \uFFFD -1 {knownW3C} {First trail byte must be 90:BF} utf-8 F08F strict {} 0 {} {First trail byte must be 90:BF} @@ -755,7 +782,7 @@ lappend encInvalidBytes {*}{ # be skipped. This is intentional to skip known bugs. # TODO - other encodings # TODO - out of range code point (note cannot be generated by \U notation) -set encUnencodableStrings { +lappend encUnencodableStrings {*}{ ascii \u00e0 tcl8 3f -1 {} {unencodable} ascii \u00e0 strict {} 0 {} {unencodable} @@ -768,12 +795,6 @@ set encUnencodableStrings { utf-8 \uDC00 strict {} 0 {} High-surrogate } -if {$::tcl_platform(byteOrder) eq "littleEndian"} { - set endian le -} else { - set endian be -} - # Maps utf-{16,32}{le,be} to utf-16, utf-32 and # others to "". Used to test utf-16, utf-32 based # on system endianness @@ -881,19 +902,19 @@ proc testprofile {id converter enc profile data result args} { # Generates tests for compiled and uncompiled implementation. # Also generates utf-{16,32} tests if passed encoding is utf-{16,32}{le,be} # The enc and profile are appended to id to generate the test id -proc testfailindex {id converter enc data result {profile default}} { - testconvert $id.$enc.$profile "list \[encoding $converter -profile $profile -failindex idx $enc $data] \[set idx]" $result +proc testfailindex {id converter enc data result failidx {profile default}} { + testconvert $id.$enc.$profile "list \[encoding $converter -profile $profile -failindex idx $enc [list $data]\] \[set idx\]" [list $result $failidx] if {[set enc2 [endianUtf $enc]] ne ""} { # If utf{16,32}-{le,be}, also do utf{16,32} - testconvert $id.$enc2.$profile "list \[encoding $converter -profile $profile -failindex idx $enc2 $data] \[set idx]" $result + testconvert $id.$enc2.$profile "list \[encoding $converter -profile $profile -failindex idx $enc2 [list $data]\] \[set idx]" [list $result $failidx] } # If this is the default profile, generate a test without specifying profile if {$profile eq $::encDefaultProfile} { - testconvert $id.$enc.default "list \[encoding $converter -failindex idx $enc $data] \[set idx]" $result + testconvert $id.$enc.default "list \[encoding $converter -failindex idx $enc [list $data]\] \[set idx]" [list $result $failidx] if {[set enc2 [endianUtf $enc]] ne ""} { # If utf{16,32}-{le,be}, also do utf{16,32} - testconvert $id.$enc2.default "list \[encoding $converter -failindex idx $enc2 $data] \[set idx]" $result + testconvert $id.$enc2.default "list \[encoding $converter -failindex idx $enc2 [list $data]\] \[set idx]" [list $result $failidx] } } } @@ -962,10 +983,10 @@ foreach {enc str hex ctrl comment} $encValidStrings { set prefix_bytes [encoding convertto $enc A] set suffix_bytes [encoding convertto $enc B] foreach profile $encProfiles { - testfailindex cmdAH-4.3.13.$hex.solo convertfrom $enc $bytes [list $str -1] $profile - testfailindex cmdAH-4.3.13.$hex.lead convertfrom $enc $bytes$suffix_bytes [list $str$suffix -1] $profile - testfailindex cmdAH-4.3.13.$hex.tail convertfrom $enc $prefix_bytes$bytes [list $prefix$str -1] $profile - testfailindex cmdAH-4.3.13.$hex.middle convertfrom $enc $prefix_bytes$bytes$suffix_bytes [list $prefix$str$suffix -1] $profile + testprofile cmdAH-4.3.13.$hex.solo convertfrom $enc $profile $bytes $str + testprofile cmdAH-4.3.13.$hex.lead convertfrom $enc $profile $bytes$suffix_bytes $str$suffix + testprofile cmdAH-4.3.13.$hex.tail convertfrom $enc $profile $prefix_bytes$bytes $prefix$str + testprofile cmdAH-4.3.13.$hex.middle convertfrom $enc $profile $prefix_bytes$bytes$suffix_bytes $prefix$str$suffix } } @@ -1026,10 +1047,10 @@ foreach {enc str hex ctrl comment} $encValidStrings { set prefix_bytes [encoding convertto $enc $prefix] set suffix_bytes [encoding convertto $enc $suffix] foreach profile $encProfiles { - testfailindex cmdAH-4.3.14.$hex.solo convertfrom $enc $bytes [list $str -1] $profile - testfailindex cmdAH-4.3.14.$hex.lead convertfrom $enc $bytes$suffix_bytes [list $str$suffix -1] $profile - testfailindex cmdAH-4.3.14.$hex.tail convertfrom $enc $prefix_bytes$bytes [list $prefix$str -1] $profile - testfailindex cmdAH-4.3.14.$hex.middle convertfrom $enc $prefix_bytes$bytes$suffix_bytes [list $prefix$str$suffix -1] $profile + testfailindex cmdAH-4.3.14.$hex.solo convertfrom $enc $bytes $str -1 $profile + testfailindex cmdAH-4.3.14.$hex.lead convertfrom $enc $bytes$suffix_bytes $str$suffix -1 $profile + testfailindex cmdAH-4.3.14.$hex.tail convertfrom $enc $prefix_bytes$bytes $prefix$str -1 $profile + testfailindex cmdAH-4.3.14.$hex.middle convertfrom $enc $prefix_bytes$bytes$suffix_bytes $prefix$str$suffix -1 $profile } } @@ -1044,7 +1065,7 @@ foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { set suffix_bytes [encoding convertto $enc $suffix] set prefixLen [string length $prefix_bytes] if {$ctrl eq {} || "solo" in $ctrl} { - testfailindex cmdAH-4.3.14.$hex.solo convertfrom $enc $bytes [list $str $failidx] $profile + testfailindex cmdAH-4.3.14.$hex.solo convertfrom $enc $bytes $str $failidx $profile } if {$ctrl eq {} || "lead" in $ctrl} { if {$failidx == -1} { @@ -1054,7 +1075,7 @@ foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { # Failure expected set result "" } - testfailindex cmdAH-4.3.14.$hex.lead convertfrom $enc $bytes$suffix_bytes [list $result $failidx] $profile + testfailindex cmdAH-4.3.14.$hex.lead convertfrom $enc $bytes$suffix_bytes $result $failidx $profile } if {$ctrl eq {} || "tail" in $ctrl} { set expected_failidx $failidx @@ -1066,7 +1087,7 @@ foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { set result $prefix incr expected_failidx $prefixLen } - testfailindex cmdAH-4.3.14.$hex.tail convertfrom $enc $prefix_bytes$bytes [list $result $expected_failidx] $profile + testfailindex cmdAH-4.3.14.$hex.tail convertfrom $enc $prefix_bytes$bytes $result $expected_failidx $profile } if {$ctrl eq {} || "middle" in $ctrl} { set expected_failidx $failidx @@ -1078,7 +1099,7 @@ foreach {enc hex profile str failidx ctrl comment} $encInvalidBytes { set result $prefix incr expected_failidx $prefixLen } - testfailindex cmdAH-4.3.14.$hex.middle convertfrom $enc $prefix_bytes$bytes$suffix_bytes [list $result $expected_failidx] $profile + testfailindex cmdAH-4.3.14.$hex.middle convertfrom $enc $prefix_bytes$bytes$suffix_bytes $result $expected_failidx $profile } } @@ -1193,10 +1214,10 @@ foreach {enc str hex ctrl comment} $encValidStrings { set prefix_bytes [encoding convertto $enc A] set suffix_bytes [encoding convertto $enc B] foreach profile $encProfiles { - testfailindex cmdAH-4.4.14.$enc.$printable.solo convertto $enc $str [list $bytes -1] $profile - testfailindex cmdAH-4.4.14.$enc.$printable.lead convertto $enc $str$suffix [list $bytes$suffix_bytes -1] $profile - testfailindex cmdAH-4.4.14.$enc.$printable.tail convertto $enc $prefix$str [list $prefix_bytes$bytes -1] $profile - testfailindex cmdAH-4.4.14.$enc.$printable.middle convertto $enc $prefix$str$suffix [list $prefix_bytes$bytes$suffix_bytes -1] $profile + testfailindex cmdAH-4.4.14.$enc.$printable.solo convertto $enc $str $bytes -1 $profile + testfailindex cmdAH-4.4.14.$enc.$printable.lead convertto $enc $str$suffix $bytes$suffix_bytes -1 $profile + testfailindex cmdAH-4.4.14.$enc.$printable.tail convertto $enc $prefix$str $prefix_bytes$bytes -1 $profile + testfailindex cmdAH-4.4.14.$enc.$printable.middle convertto $enc $prefix$str$suffix $prefix_bytes$bytes$suffix_bytes -1 $profile } } @@ -1209,7 +1230,7 @@ foreach {enc str profile hex failidx ctrl comment} $encUnencodableStrings { set suffix B set prefixLen [string length [encoding convertto $enc $prefix]] if {$ctrl eq {} || "solo" in $ctrl} { - testfailindex cmdAH-4.4.14.$printable.solo convertto $enc $str [list $bytes $failidx] $profile + testfailindex cmdAH-4.4.14.$printable.solo convertto $enc $str $bytes $failidx $profile } if {$ctrl eq {} || "lead" in $ctrl} { if {$failidx == -1} { @@ -1219,7 +1240,7 @@ foreach {enc str profile hex failidx ctrl comment} $encUnencodableStrings { # Failure expected set result "" } - testfailindex cmdAH-4.4.14.$printable.lead convertto $enc $str$suffix [list $result $failidx] $profile + testfailindex cmdAH-4.4.14.$printable.lead convertto $enc $str$suffix $result $failidx $profile } if {$ctrl eq {} || "tail" in $ctrl} { set expected_failidx $failidx @@ -1231,7 +1252,7 @@ foreach {enc str profile hex failidx ctrl comment} $encUnencodableStrings { set result $prefix incr expected_failidx $prefixLen } - testfailindex cmdAH-4.4.14.$printable.tail convertto $enc $prefix$str [list $result $expected_failidx] $profile + testfailindex cmdAH-4.4.14.$printable.tail convertto $enc $prefix$str $result $expected_failidx $profile } if {$ctrl eq {} || "middle" in $ctrl} { set expected_failidx $failidx @@ -1243,7 +1264,7 @@ foreach {enc str profile hex failidx ctrl comment} $encUnencodableStrings { set result $prefix incr expected_failidx $prefixLen } - testfailindex cmdAH-4.4.14.$printable.middle convertto $enc $prefix$str$suffix [list $result $expected_failidx] $profile + testfailindex cmdAH-4.4.14.$printable.middle convertto $enc $prefix$str$suffix $result $expected_failidx $profile } } diff --git a/tools/ucm2tests.tcl b/tools/ucm2tests.tcl index 22ae529..e971631 100644 --- a/tools/ucm2tests.tcl +++ b/tools/ucm2tests.tcl @@ -1,14 +1,15 @@ # ucm2tests.tcl # # Parses given ucm files (from ICU) to generate test data -# for encodings. The generated scripts are written to stdout. +# for encodings. # -# tclsh ucmtotests.tcl PATH_TO_ICU_UCM_DIRECTORY +# tclsh ucm2tests.tcl PATH_TO_ICU_UCM_DIRECTORY ?OUTPUTPATH? # namespace eval ucm { # No means to change these currently but ... - variable outputChan stdout + variable outputPath + variable outputChan variable errorChan stderr variable verbose 0 @@ -24,6 +25,7 @@ namespace eval ucm { cp1256 glibc-CP1256-2.1.2 cp1257 glibc-CP1257-2.1.2 cp1258 glibc-CP1258-2.1.2 + gb1988 glibc-GB_1988_80-2.3.3 iso8859-1 glibc-ISO_8859_1-2.1.2 iso8859-2 glibc-ISO_8859_2-2.1.2 iso8859-3 glibc-ISO_8859_3-2.1.2 @@ -91,27 +93,99 @@ proc ucm::parse_SBCS {fd} { proc ucm::generate_tests {} { variable encNameMap variable charMap + variable outputPath + variable outputChan + + if {[info exists outputPath]} { + set outputChan [open $outputPath w] + } else { + set outputChan stdout + } array set tclNames {} foreach encName [encoding names] { set tclNames($encName) "" } - foreach encName [lsort [array names encNameMap]] { + + # Common procedures + print { +# This file is automatically generated by ucm2tests.tcl. +# Edits will be overwritten on next generation. +# +# Generates tests comparing Tcl encodings to ICU. +# The generated file is NOT standalone. It should be sourced into a test script. + +proc ucmConvertfromMismatches {enc map} { + set mismatches {} + foreach {unihex hex} $map { + set unich [subst "\\U$unihex"] + if {[encoding convertfrom -profile strict $enc [binary decode hex $hex]] ne $unich} { + lappend mismatches "<[printable $unich],$hex>" + } + } + return $mismatches +} +proc ucmConverttoMismatches {enc map} { + set mismatches {} + foreach {unihex hex} $map { + set unich [subst "\\U$unihex"] + if {[encoding convertto -profile strict $enc $unich] ne [binary decode hex $hex]} { + lappend mismatches "<[printable $unich],$hex>" + } + } + return $mismatches +} +if {[info commands printable] eq ""} { + proc printable {s} { + set print "" + foreach c [split $s ""] { + set i [scan $c %c] + if {[string is print $c] && ($i <= 127)} { + append print $c + } elseif {$i <= 0xff} { + append print \\x[format %02X $i] + } elseif {$i <= 0xffff} { + append print \\u[format %04X $i] + } else { + append print \\U[format %08X $i] + } + } + return $print + } +} + } + foreach encName [lsort -dictionary [array names encNameMap]] { if {![info exists charMap($encName)]} { warn "No character map read for $encName" continue } unset tclNames($encName) - print "\n# $encName (generated from $encNameMap($encName))" - print "lappend encValidStrings {*}{" - foreach {unich hex} $charMap($encName) { - print " $encName \\u$unich $hex {} {}" + + print "\n#\n# $encName (generated from $encNameMap($encName))" + print "\ntest encoding-convertfrom-ucmCompare-$encName {Compare against ICU UCM} -body \{" + print " ucmConvertfromMismatches $encName {$charMap($encName)}" + print "\} -result {}" + print "\ntest encoding-convertto-ucmCompare-$encName {Compare against ICU UCM} -body \{" + print " ucmConverttoMismatches $encName {$charMap($encName)}" + print "\} -result {}" + if {0} { + # This will generate individual tests for every char + # and test in lead, tail, middle, solo configurations + # but takes considerable time + print "lappend encValidStrings {*}{" + foreach {unich hex} $charMap($encName) { + print " $encName \\u$unich $hex {} {}" + } + print "}; # $encName" } - print "}; # $encName" } if {[array size tclNames]} { warn "Missing encoding: [lsort [array names tclNames]]" } + if {[info exists outputPath]} { + close $outputChan + unset outputChan + } } proc ucm::parse_file {encName ucmPath} { @@ -173,8 +247,13 @@ proc ucm::expand_paths {patterns} { proc ucm::run {} { variable encNameMap - if {[llength $::argv] != 1} { - abort "Usage: [info nameofexecutable] $::argv0 PATHTOUCMFILES" + variable outputPath + switch [llength $::argv] { + 2 {set outputPath [lindex $::argv 1]} + 1 {} + default { + abort "Usage: [info nameofexecutable] $::argv0 path/to/icu/ucm/data ?outputfile?" + } } foreach {encName fname} [array get encNameMap] { ucm::parse_file $encName [file join [lindex $::argv 0] ${fname}.ucm] -- cgit v0.12 From c606ae1574a7d66bcbf8666506e91840875f6d45 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 21 Feb 2023 17:50:36 +0000 Subject: Proposed fix for [d19fe0a5b]: Handling incomplete byte sequences for utf-16/utf-32 --- generic/tclEncoding.c | 27 ++++++++++++++++++++++++--- tests/encoding.test | 6 ++++++ 2 files changed, 30 insertions(+), 3 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index dfa7907..ecec6e9 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2457,21 +2457,27 @@ UnicodeToUtfProc( } result = TCL_OK; - /* check alignment with utf-16 (2 == sizeof(UTF-16)) */ + /* + * Check alignment with utf-16 (2 == sizeof(UTF-16)) + */ + if ((srcLen % 2) != 0) { result = TCL_CONVERT_MULTIBYTE; srcLen--; } +#if TCL_UTF_MAX > 3 /* - * If last code point is a high surrogate, we cannot handle that yet. + * If last code point is a high surrogate, we cannot handle that yet, + * unless we are at the end. */ - if ((srcLen >= 2) && + if (!(flags & TCL_ENCODING_END) && (srcLen >= 2) && ((src[srcLen - (clientData?1:2)] & 0xFC) == 0xD8)) { result = TCL_CONVERT_MULTIBYTE; srcLen-= 2; } +#endif srcStart = src; srcEnd = src + srcLen; @@ -2504,6 +2510,21 @@ UnicodeToUtfProc( src += sizeof(unsigned short); } + if ((flags & TCL_ENCODING_END) && (result == TCL_CONVERT_MULTIBYTE)) { + /* We have a single byte left-over at the end */ + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + } else { + /* destination is not full, so we really are at the end now */ + if (flags & TCL_ENCODING_STOPONERROR) { + result = TCL_CONVERT_SYNTAX; + } else { + dst += Tcl_UniCharToUtf(0xFFFD, dst); + numChars++; + src++; + } + } + } *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; *dstCharsPtr = numChars; diff --git a/tests/encoding.test b/tests/encoding.test index f558e01..f6f9abc 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -419,6 +419,12 @@ test encoding-16.3 {UnicodeToUtfProc} -body { set val [encoding convertfrom unicode "\xDC\xDC"] list $val [format %X [scan $val %c]] } -result "\uDCDC DCDC" +test encoding-16.4 {UnicodeToUtfProc, bug [d19fe0a5b]} -body { + encoding convertfrom unicode "\x41\x41\x41" +} -result \u4141\uFFFD +test encoding-16.5 {UnicodeToUtfProc, bug [d19fe0a5b]} -constraints ucs2 -body { + encoding convertfrom unicode "\xD8\xD8" +} -result \uD8D8 test encoding-17.1 {UtfToUnicodeProc} -constraints fullutf -body { encoding convertto unicode "\U460DC" -- cgit v0.12 From f95599f4d4b6e502a92971909286a8ec6533c8c2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 21 Feb 2023 23:16:14 +0000 Subject: More encoding fixes, e.g. range 0x80-0x9F for dingbats and symbol. Remove "-m" option from txt2enc.c tool, since the same is already handled in the table encoding code in Tcl itself. This was wat prevent Tcl to handle throwing exceptions correctly --- library/encoding/dingbats.enc | 4 ++-- library/encoding/ebcdic.enc | 1 + library/encoding/symbol.enc | 4 ++-- tools/encoding/Makefile | 2 +- tools/encoding/dingbats.txt | 1 + tools/encoding/gb1988.txt | 1 + tools/encoding/macTurkish.txt | 1 + tools/encoding/macUkraine.txt | 1 + tools/encoding/symbol.txt | 1 + tools/encoding/txt2enc.c | 14 +------------- 10 files changed, 12 insertions(+), 18 deletions(-) diff --git a/library/encoding/dingbats.enc b/library/encoding/dingbats.enc index 9729487..bd466b2 100644 --- a/library/encoding/dingbats.enc +++ b/library/encoding/dingbats.enc @@ -10,8 +10,8 @@ S 2730273127322733273427352736273727382739273A273B273C273D273E273F 2740274127422743274427452746274727482749274A274B25CF274D25A0274F 27502751275225B225BC25C6275625D727582759275A275B275C275D275E007F -0080008100820083008400850086008700880089008A008B008C008D008E008F -0090009100920093009400950096009700980099009A009B009C009D009E009F +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 0000276127622763276427652766276726632666266526602460246124622463 2464246524662467246824692776277727782779277A277B277C277D277E277F 2780278127822783278427852786278727882789278A278B278C278D278E278F diff --git a/library/encoding/ebcdic.enc b/library/encoding/ebcdic.enc index f451de5..f83ce7d 100644 --- a/library/encoding/ebcdic.enc +++ b/library/encoding/ebcdic.enc @@ -1,3 +1,4 @@ +# Encoding file: ebcdic, single-byte S 006F 0 1 00 diff --git a/library/encoding/symbol.enc b/library/encoding/symbol.enc index ffda9e3..ebd2f49 100644 --- a/library/encoding/symbol.enc +++ b/library/encoding/symbol.enc @@ -10,8 +10,8 @@ S 03A0039803A103A303A403A503C203A9039E03A80396005B2234005D22A5005F F8E503B103B203C703B403B503C603B303B703B903D503BA03BB03BC03BD03BF 03C003B803C103C303C403C503D603C903BE03C803B6007B007C007D223C007F -0080008100820083008400850086008700880089008A008B008C008D008E008F -0090009100920093009400950096009700980099009A009B009C009D009E009F +0000000000000000000000000000000000000000000000000000000000000000 +0000000000000000000000000000000000000000000000000000000000000000 000003D2203222642044221E0192266326662665266021942190219121922193 00B000B12033226500D7221D2202202200F72260226122482026F8E6F8E721B5 21352111211C21182297229522052229222A2283228722842282228622082209 diff --git a/tools/encoding/Makefile b/tools/encoding/Makefile index 7235b47..a2122d5 100644 --- a/tools/encoding/Makefile +++ b/tools/encoding/Makefile @@ -67,7 +67,7 @@ encodings: clean txt2enc $(EUC_ENCODINGS) @for p in *.txt; do \ enc=`echo $$p | sed 's/\..*$$/\.enc/'`; \ echo $$enc; \ - ./txt2enc -m $$p > $$enc; \ + ./txt2enc $$p > $$enc; \ done @echo @echo Compiling special versions of encoding files. diff --git a/tools/encoding/dingbats.txt b/tools/encoding/dingbats.txt index 334f8d6..93a6081 100644 --- a/tools/encoding/dingbats.txt +++ b/tools/encoding/dingbats.txt @@ -155,6 +155,7 @@ 0x7C 0x275C # HEAVY SINGLE COMMA QUOTATION MARK ORNAMENT 0x7D 0x275D # HEAVY DOUBLE TURNED COMMA QUOTATION MARK ORNAMENT 0x7E 0x275E # HEAVY DOUBLE COMMA QUOTATION MARK ORNAMENT +0x7F 0x275E # DELETE 0xA1 0x2761 # CURVED STEM PARAGRAPH SIGN ORNAMENT 0xA2 0x2762 # HEAVY EXCLAMATION MARK ORNAMENT 0xA3 0x2763 # HEAVY HEART EXCLAMATION MARK ORNAMENT diff --git a/tools/encoding/gb1988.txt b/tools/encoding/gb1988.txt index 800cd68..b9197e5 100644 --- a/tools/encoding/gb1988.txt +++ b/tools/encoding/gb1988.txt @@ -93,6 +93,7 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x203E # OVERLINE +0x7F 0x007F # DELETE 0xA1 0xFF61 # HALFWIDTH IDEOGRAPHIC FULL STOP 0xA2 0xFF62 # HALFWIDTH LEFT CORNER BRACKET 0xA3 0xFF63 # HALFWIDTH RIGHT CORNER BRACKET diff --git a/tools/encoding/macTurkish.txt b/tools/encoding/macTurkish.txt index 4a1ddab..ca3cda3 100644 --- a/tools/encoding/macTurkish.txt +++ b/tools/encoding/macTurkish.txt @@ -203,6 +203,7 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE +0x7F 0x007F # DELETE # 0x80 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS 0x81 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE diff --git a/tools/encoding/macUkraine.txt b/tools/encoding/macUkraine.txt index dba4e10..dc07cdc 100644 --- a/tools/encoding/macUkraine.txt +++ b/tools/encoding/macUkraine.txt @@ -148,6 +148,7 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE +0x7F 0x007F # DELETE # 0x80 0x0410 # CYRILLIC CAPITAL LETTER A 0x81 0x0411 # CYRILLIC CAPITAL LETTER BE diff --git a/tools/encoding/symbol.txt b/tools/encoding/symbol.txt index 12dcae6..13a3ed8 100644 --- a/tools/encoding/symbol.txt +++ b/tools/encoding/symbol.txt @@ -169,6 +169,7 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x223C # TILDE OPERATOR +0x7F 0x007F # DELETE 0xA1 0x03D2 # GREEK UPSILON WITH HOOK SYMBOL 0xA2 0x2032 # PRIME 0xA3 0x2264 # LESS-THAN OR EQUAL TO diff --git a/tools/encoding/txt2enc.c b/tools/encoding/txt2enc.c index 7ee797b..80b44b9 100644 --- a/tools/encoding/txt2enc.c +++ b/tools/encoding/txt2enc.c @@ -26,7 +26,7 @@ main(int argc, char **argv) { FILE *fp; Rune *toUnicode[256]; - int i, multiByte, enc, uni, hi, lo, fixmissing, used, maxEnc; + int i, multiByte, enc, uni, hi, lo, used, maxEnc; int ch, encColumn, uniColumn, fallbackKnown, width; char *fallbackString, *str, *rest, *dot; unsigned int magic, type, symbol, fallbackChar; @@ -43,7 +43,6 @@ main(int argc, char **argv) fallbackKnown = 0; type = -1; symbol = 0; - fixmissing = 1; opterr = 0; while (1) { @@ -89,10 +88,6 @@ main(int argc, char **argv) symbol = 1; break; - case 'm': - fixmissing = 0; - break; - default: goto usage; } @@ -207,13 +202,6 @@ main(int argc, char **argv) for (i = 0; i < 0x20; i++) { toUnicode[0][i] = i; } - if (fixmissing) { - for (i = 0x7F; i < 0xA0; i++) { - if (toUnicode[i] == NULL && toUnicode[0][i] == 0) { - toUnicode[0][i] = i; - } - } - } } printf("# Encoding file: %s, %s-byte\n", argv[argc - 1], typeString[type]); -- cgit v0.12 From a970bffd00117d4e762dfec90e21a94576da94fc Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Tue, 21 Feb 2023 23:22:45 +0000 Subject: Add 0x7F: DELETE to more mac* encodings (so re-generating doesn't remove it again) --- tools/encoding/macCentEuro.txt | 1 + tools/encoding/macCroatian.txt | 1 + tools/encoding/macCyrillic.txt | 1 + tools/encoding/macDingbats.txt | 1 + tools/encoding/macGreek.txt | 1 + tools/encoding/macIceland.txt | 1 + tools/encoding/macJapan.txt | 1 + tools/encoding/macRoman.txt | 1 + tools/encoding/macRomania.txt | 1 + tools/encoding/macThai.txt | 1 + 10 files changed, 10 insertions(+) diff --git a/tools/encoding/macCentEuro.txt b/tools/encoding/macCentEuro.txt index bf424c1..aa92908 100644 --- a/tools/encoding/macCentEuro.txt +++ b/tools/encoding/macCentEuro.txt @@ -188,6 +188,7 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE +0x7F 0x007F # DELETE # 0x80 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS 0x81 0x0100 # LATIN CAPITAL LETTER A WITH MACRON diff --git a/tools/encoding/macCroatian.txt b/tools/encoding/macCroatian.txt index 538eda3..2eef246 100644 --- a/tools/encoding/macCroatian.txt +++ b/tools/encoding/macCroatian.txt @@ -216,6 +216,7 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE +0x7F 0x007F # DELETE # 0x80 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS 0x81 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE diff --git a/tools/encoding/macCyrillic.txt b/tools/encoding/macCyrillic.txt index 695dade..2e9f8e2 100644 --- a/tools/encoding/macCyrillic.txt +++ b/tools/encoding/macCyrillic.txt @@ -213,6 +213,7 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE +0x7F 0x007F # DELETE # 0x80 0x0410 # CYRILLIC CAPITAL LETTER A 0x81 0x0411 # CYRILLIC CAPITAL LETTER BE diff --git a/tools/encoding/macDingbats.txt b/tools/encoding/macDingbats.txt index 273d526..4b815f4 100644 --- a/tools/encoding/macDingbats.txt +++ b/tools/encoding/macDingbats.txt @@ -151,6 +151,7 @@ 0x7C 0x275C # HEAVY SINGLE COMMA QUOTATION MARK ORNAMENT 0x7D 0x275D # HEAVY DOUBLE TURNED COMMA QUOTATION MARK ORNAMENT 0x7E 0x275E # HEAVY DOUBLE COMMA QUOTATION MARK ORNAMENT +0x7F 0x007F # DELETE 0x80 0xF8D7 # medium left parenthesis ornament 0x81 0xF8D8 # medium right parenthesis ornament 0x82 0xF8D9 # medium flattened left parenthesis ornament diff --git a/tools/encoding/macGreek.txt b/tools/encoding/macGreek.txt index 9783259..b960d68 100644 --- a/tools/encoding/macGreek.txt +++ b/tools/encoding/macGreek.txt @@ -207,6 +207,7 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE +0x7F 0x007F # DELETE # 0x80 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS 0x81 0x00B9 # SUPERSCRIPT ONE diff --git a/tools/encoding/macIceland.txt b/tools/encoding/macIceland.txt index 0a0b27b..c60b8d2 100644 --- a/tools/encoding/macIceland.txt +++ b/tools/encoding/macIceland.txt @@ -234,6 +234,7 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE +0x7F 0x007F # DELETE # 0x80 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS 0x81 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE diff --git a/tools/encoding/macJapan.txt b/tools/encoding/macJapan.txt index 7121b3b..3c48c4a 100644 --- a/tools/encoding/macJapan.txt +++ b/tools/encoding/macJapan.txt @@ -318,6 +318,7 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE # Apple change +0x7F 0x007F # DELETE # 0x8140 0x3000 # IDEOGRAPHIC SPACE 0x8141 0x3001 # IDEOGRAPHIC COMMA diff --git a/tools/encoding/macRoman.txt b/tools/encoding/macRoman.txt index 7ddcf8d..43ad44b 100644 --- a/tools/encoding/macRoman.txt +++ b/tools/encoding/macRoman.txt @@ -233,6 +233,7 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE +0x7F 0x007F # DELETE # 0x80 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS 0x81 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE diff --git a/tools/encoding/macRomania.txt b/tools/encoding/macRomania.txt index 2a84adc..36a0b68 100644 --- a/tools/encoding/macRomania.txt +++ b/tools/encoding/macRomania.txt @@ -154,6 +154,7 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE +0x7F 0x007F # DELETE # 0x80 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS 0x81 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE diff --git a/tools/encoding/macThai.txt b/tools/encoding/macThai.txt index b991833..2043621 100644 --- a/tools/encoding/macThai.txt +++ b/tools/encoding/macThai.txt @@ -168,6 +168,7 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE +0x7F 0x007F # DELETE # 0x80 0x00AB # LEFT-POINTING DOUBLE ANGLE QUOTATION MARK 0x81 0x00BB # RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK -- cgit v0.12 From 78db448fff66d55223a88f8225976f4324de1b95 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 22 Feb 2023 13:31:41 +0000 Subject: Make txt2enc smarter, so we don't have to add DELETE any more in all original tables, better keep them as-is. --- tools/encoding/Makefile | 2 +- tools/encoding/ascii.txt | 1 - tools/encoding/big5.txt | 1 - tools/encoding/dingbats.txt | 1 - tools/encoding/gb1988.txt | 1 - tools/encoding/macCentEuro.txt | 1 - tools/encoding/macCroatian.txt | 1 - tools/encoding/macCyrillic.txt | 1 - tools/encoding/macDingbats.txt | 1 - tools/encoding/macGreek.txt | 1 - tools/encoding/macIceland.txt | 1 - tools/encoding/macJapan.txt | 1 - tools/encoding/macRoman.txt | 1 - tools/encoding/macRomania.txt | 1 - tools/encoding/macThai.txt | 1 - tools/encoding/macTurkish.txt | 1 - tools/encoding/macUkraine.txt | 1 - tools/encoding/symbol.txt | 1 - tools/encoding/txt2enc.c | 14 ++++++++++++-- 19 files changed, 13 insertions(+), 20 deletions(-) diff --git a/tools/encoding/Makefile b/tools/encoding/Makefile index a2122d5..ff19492 100644 --- a/tools/encoding/Makefile +++ b/tools/encoding/Makefile @@ -67,7 +67,7 @@ encodings: clean txt2enc $(EUC_ENCODINGS) @for p in *.txt; do \ enc=`echo $$p | sed 's/\..*$$/\.enc/'`; \ echo $$enc; \ - ./txt2enc $$p > $$enc; \ + ./txt2enc -e 0 -u 1 $$p > $$enc; \ done @echo @echo Compiling special versions of encoding files. diff --git a/tools/encoding/ascii.txt b/tools/encoding/ascii.txt index 2afbaab..66ba6f3 100644 --- a/tools/encoding/ascii.txt +++ b/tools/encoding/ascii.txt @@ -93,4 +93,3 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE -0x7F 0x007F # DELETE \ No newline at end of file diff --git a/tools/encoding/big5.txt b/tools/encoding/big5.txt index 06b0fac..58cdfe2 100644 --- a/tools/encoding/big5.txt +++ b/tools/encoding/big5.txt @@ -185,7 +185,6 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE -0x7F 0x007F # DELETE 0xA140 0x3000 # IDEOGRAPHIC SPACE 0xA141 0xFF0C # FULLWIDTH COMMA 0xA142 0x3001 # IDEOGRAPHIC COMMA diff --git a/tools/encoding/dingbats.txt b/tools/encoding/dingbats.txt index 93a6081..334f8d6 100644 --- a/tools/encoding/dingbats.txt +++ b/tools/encoding/dingbats.txt @@ -155,7 +155,6 @@ 0x7C 0x275C # HEAVY SINGLE COMMA QUOTATION MARK ORNAMENT 0x7D 0x275D # HEAVY DOUBLE TURNED COMMA QUOTATION MARK ORNAMENT 0x7E 0x275E # HEAVY DOUBLE COMMA QUOTATION MARK ORNAMENT -0x7F 0x275E # DELETE 0xA1 0x2761 # CURVED STEM PARAGRAPH SIGN ORNAMENT 0xA2 0x2762 # HEAVY EXCLAMATION MARK ORNAMENT 0xA3 0x2763 # HEAVY HEART EXCLAMATION MARK ORNAMENT diff --git a/tools/encoding/gb1988.txt b/tools/encoding/gb1988.txt index b9197e5..800cd68 100644 --- a/tools/encoding/gb1988.txt +++ b/tools/encoding/gb1988.txt @@ -93,7 +93,6 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x203E # OVERLINE -0x7F 0x007F # DELETE 0xA1 0xFF61 # HALFWIDTH IDEOGRAPHIC FULL STOP 0xA2 0xFF62 # HALFWIDTH LEFT CORNER BRACKET 0xA3 0xFF63 # HALFWIDTH RIGHT CORNER BRACKET diff --git a/tools/encoding/macCentEuro.txt b/tools/encoding/macCentEuro.txt index aa92908..bf424c1 100644 --- a/tools/encoding/macCentEuro.txt +++ b/tools/encoding/macCentEuro.txt @@ -188,7 +188,6 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE -0x7F 0x007F # DELETE # 0x80 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS 0x81 0x0100 # LATIN CAPITAL LETTER A WITH MACRON diff --git a/tools/encoding/macCroatian.txt b/tools/encoding/macCroatian.txt index 2eef246..538eda3 100644 --- a/tools/encoding/macCroatian.txt +++ b/tools/encoding/macCroatian.txt @@ -216,7 +216,6 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE -0x7F 0x007F # DELETE # 0x80 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS 0x81 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE diff --git a/tools/encoding/macCyrillic.txt b/tools/encoding/macCyrillic.txt index 2e9f8e2..695dade 100644 --- a/tools/encoding/macCyrillic.txt +++ b/tools/encoding/macCyrillic.txt @@ -213,7 +213,6 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE -0x7F 0x007F # DELETE # 0x80 0x0410 # CYRILLIC CAPITAL LETTER A 0x81 0x0411 # CYRILLIC CAPITAL LETTER BE diff --git a/tools/encoding/macDingbats.txt b/tools/encoding/macDingbats.txt index 4b815f4..273d526 100644 --- a/tools/encoding/macDingbats.txt +++ b/tools/encoding/macDingbats.txt @@ -151,7 +151,6 @@ 0x7C 0x275C # HEAVY SINGLE COMMA QUOTATION MARK ORNAMENT 0x7D 0x275D # HEAVY DOUBLE TURNED COMMA QUOTATION MARK ORNAMENT 0x7E 0x275E # HEAVY DOUBLE COMMA QUOTATION MARK ORNAMENT -0x7F 0x007F # DELETE 0x80 0xF8D7 # medium left parenthesis ornament 0x81 0xF8D8 # medium right parenthesis ornament 0x82 0xF8D9 # medium flattened left parenthesis ornament diff --git a/tools/encoding/macGreek.txt b/tools/encoding/macGreek.txt index b960d68..9783259 100644 --- a/tools/encoding/macGreek.txt +++ b/tools/encoding/macGreek.txt @@ -207,7 +207,6 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE -0x7F 0x007F # DELETE # 0x80 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS 0x81 0x00B9 # SUPERSCRIPT ONE diff --git a/tools/encoding/macIceland.txt b/tools/encoding/macIceland.txt index c60b8d2..0a0b27b 100644 --- a/tools/encoding/macIceland.txt +++ b/tools/encoding/macIceland.txt @@ -234,7 +234,6 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE -0x7F 0x007F # DELETE # 0x80 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS 0x81 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE diff --git a/tools/encoding/macJapan.txt b/tools/encoding/macJapan.txt index 3c48c4a..7121b3b 100644 --- a/tools/encoding/macJapan.txt +++ b/tools/encoding/macJapan.txt @@ -318,7 +318,6 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE # Apple change -0x7F 0x007F # DELETE # 0x8140 0x3000 # IDEOGRAPHIC SPACE 0x8141 0x3001 # IDEOGRAPHIC COMMA diff --git a/tools/encoding/macRoman.txt b/tools/encoding/macRoman.txt index 43ad44b..7ddcf8d 100644 --- a/tools/encoding/macRoman.txt +++ b/tools/encoding/macRoman.txt @@ -233,7 +233,6 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE -0x7F 0x007F # DELETE # 0x80 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS 0x81 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE diff --git a/tools/encoding/macRomania.txt b/tools/encoding/macRomania.txt index 36a0b68..2a84adc 100644 --- a/tools/encoding/macRomania.txt +++ b/tools/encoding/macRomania.txt @@ -154,7 +154,6 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE -0x7F 0x007F # DELETE # 0x80 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS 0x81 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE diff --git a/tools/encoding/macThai.txt b/tools/encoding/macThai.txt index 2043621..b991833 100644 --- a/tools/encoding/macThai.txt +++ b/tools/encoding/macThai.txt @@ -168,7 +168,6 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE -0x7F 0x007F # DELETE # 0x80 0x00AB # LEFT-POINTING DOUBLE ANGLE QUOTATION MARK 0x81 0x00BB # RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK diff --git a/tools/encoding/macTurkish.txt b/tools/encoding/macTurkish.txt index ca3cda3..4a1ddab 100644 --- a/tools/encoding/macTurkish.txt +++ b/tools/encoding/macTurkish.txt @@ -203,7 +203,6 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE -0x7F 0x007F # DELETE # 0x80 0x00C4 # LATIN CAPITAL LETTER A WITH DIAERESIS 0x81 0x00C5 # LATIN CAPITAL LETTER A WITH RING ABOVE diff --git a/tools/encoding/macUkraine.txt b/tools/encoding/macUkraine.txt index dc07cdc..dba4e10 100644 --- a/tools/encoding/macUkraine.txt +++ b/tools/encoding/macUkraine.txt @@ -148,7 +148,6 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x007E # TILDE -0x7F 0x007F # DELETE # 0x80 0x0410 # CYRILLIC CAPITAL LETTER A 0x81 0x0411 # CYRILLIC CAPITAL LETTER BE diff --git a/tools/encoding/symbol.txt b/tools/encoding/symbol.txt index 13a3ed8..12dcae6 100644 --- a/tools/encoding/symbol.txt +++ b/tools/encoding/symbol.txt @@ -169,7 +169,6 @@ 0x7C 0x007C # VERTICAL LINE 0x7D 0x007D # RIGHT CURLY BRACKET 0x7E 0x223C # TILDE OPERATOR -0x7F 0x007F # DELETE 0xA1 0x03D2 # GREEK UPSILON WITH HOOK SYMBOL 0xA2 0x2032 # PRIME 0xA3 0x2264 # LESS-THAN OR EQUAL TO diff --git a/tools/encoding/txt2enc.c b/tools/encoding/txt2enc.c index 80b44b9..32c7344 100644 --- a/tools/encoding/txt2enc.c +++ b/tools/encoding/txt2enc.c @@ -26,7 +26,7 @@ main(int argc, char **argv) { FILE *fp; Rune *toUnicode[256]; - int i, multiByte, enc, uni, hi, lo, used, maxEnc; + int i, multiByte, enc, uni, hi, lo, fixmissing, used, maxEnc; int ch, encColumn, uniColumn, fallbackKnown, width; char *fallbackString, *str, *rest, *dot; unsigned int magic, type, symbol, fallbackChar; @@ -43,6 +43,7 @@ main(int argc, char **argv) fallbackKnown = 0; type = -1; symbol = 0; + fixmissing = 1; opterr = 0; while (1) { @@ -88,6 +89,10 @@ main(int argc, char **argv) symbol = 1; break; + case 'm': + fixmissing = 0; + break; + default: goto usage; } @@ -101,7 +106,7 @@ main(int argc, char **argv) fputs(" -f\tfallback character (default: QUESTION MARK)\n", stderr); fputs(" -t\toverride implicit type with single, double, or multi\n", stderr); fputs(" -s\tsymbol+ascii encoding\n", stderr); - fputs(" -m\tdon't implicitly include range 0080 to 00FF\n", stderr); + fputs(" -m\tdon't implicitly include 007F\n", stderr); return 1; } @@ -202,6 +207,11 @@ main(int argc, char **argv) for (i = 0; i < 0x20; i++) { toUnicode[0][i] = i; } + if (fixmissing) { + if (toUnicode[0x7F] == NULL && toUnicode[0][0x7F] == 0) { + toUnicode[0][0x7F] = 0x7F; + } + } } printf("# Encoding file: %s, %s-byte\n", argv[argc - 1], typeString[type]); -- cgit v0.12 From 12345dfed8593e385a076594f4edcc545166d9ac Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 22 Feb 2023 13:34:04 +0000 Subject: re-generate macDingbats.enc, so it can now throw exceptions for the range 0x8E-0x9F --- library/encoding/macDingbats.enc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/library/encoding/macDingbats.enc b/library/encoding/macDingbats.enc index 28449cd..9fa47b5 100644 --- a/library/encoding/macDingbats.enc +++ b/library/encoding/macDingbats.enc @@ -10,8 +10,8 @@ S 2730273127322733273427352736273727382739273A273B273C273D273E273F 2740274127422743274427452746274727482749274A274B25CF274D25A0274F 27502751275225B225BC25C6275625D727582759275A275B275C275D275E007F -F8D7F8D8F8D9F8DAF8DBF8DCF8DDF8DEF8DFF8E0F8E1F8E2F8E3F8E4008E008F -0090009100920093009400950096009700980099009A009B009C009D009E009F +F8D7F8D8F8D9F8DAF8DBF8DCF8DDF8DEF8DFF8E0F8E1F8E2F8E3F8E400000000 +0000000000000000000000000000000000000000000000000000000000000000 0000276127622763276427652766276726632666266526602460246124622463 2464246524662467246824692776277727782779277A277B277C277D277E277F 2780278127822783278427852786278727882789278A278B278C278D278E278F -- cgit v0.12 From 293504812606130380d7240fddbbdc573b9dae8c Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 22 Feb 2023 13:42:55 +0000 Subject: Add ICU tests for unmapped characters. --- tests/cmdAH.test | 4 + tests/icuUcmTests.tcl | 1891 +++++++++++++++++++++++++++++++++++++++++++++++++ tools/ucm2tests.tcl | 156 +++- 3 files changed, 2017 insertions(+), 34 deletions(-) create mode 100644 tests/icuUcmTests.tcl diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 3be2f14..cfde678 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -795,6 +795,10 @@ lappend encUnencodableStrings {*}{ utf-8 \uDC00 strict {} 0 {} High-surrogate } +# Generated tests comparing against ICU +# TODO - commented out for now as generating a lot of mismatches. +# source [file join [file dirname [info script]] icuUcmTests.tcl] + # Maps utf-{16,32}{le,be} to utf-16, utf-32 and # others to "". Used to test utf-16, utf-32 based # on system endianness diff --git a/tests/icuUcmTests.tcl b/tests/icuUcmTests.tcl new file mode 100644 index 0000000..0c4071f --- /dev/null +++ b/tests/icuUcmTests.tcl @@ -0,0 +1,1891 @@ + +# This file is automatically generated by ucm2tests.tcl. +# Edits will be overwritten on next generation. +# +# Generates tests comparing Tcl encodings to ICU. +# The generated file is NOT standalone. It should be sourced into a test script. + +proc ucmConvertfromMismatches {enc map} { + set mismatches {} + foreach {unihex hex} $map { + set unihex [string range 00000000$unihex end-7 end]; # Make 8 digits + set unich [subst "\\U$unihex"] + if {[encoding convertfrom -profile strict $enc [binary decode hex $hex]] ne $unich} { + lappend mismatches "<[printable $unich],$hex>" + } + } + return $mismatches +} +proc ucmConverttoMismatches {enc map} { + set mismatches {} + foreach {unihex hex} $map { + set unihex [string range 00000000$unihex end-7 end]; # Make 8 digits + set unich [subst "\\U$unihex"] + if {[encoding convertto -profile strict $enc $unich] ne [binary decode hex $hex]} { + lappend mismatches "<[printable $unich],$hex>" + } + } + return $mismatches +} +if {[info commands printable] eq ""} { + proc printable {s} { + set print "" + foreach c [split $s ""] { + set i [scan $c %c] + if {[string is print $c] && ($i <= 127)} { + append print $c + } elseif {$i <= 0xff} { + append print \\x[format %02X $i] + } elseif {$i <= 0xffff} { + append print \\u[format %04X $i] + } else { + append print \\U[format %08X $i] + } + } + return $print + } +} + + +# +# cp1250 (generated from glibc-CP1250-2.1.2) + +test encoding-convertfrom-ucmCompare-cp1250 {Compare against ICU UCM} -body { + ucmConvertfromMismatches cp1250 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A4 A4 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00BB BB 00C1 C1 00C2 C2 00C4 C4 00C7 C7 00C9 C9 00CB CB 00CD CD 00CE CE 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00DA DA 00DC DC 00DD DD 00DF DF 00E1 E1 00E2 E2 00E4 E4 00E7 E7 00E9 E9 00EB EB 00ED ED 00EE EE 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00FA FA 00FC FC 00FD FD 0102 C3 0103 E3 0104 A5 0105 B9 0106 C6 0107 E6 010C C8 010D E8 010E CF 010F EF 0110 D0 0111 F0 0118 CA 0119 EA 011A CC 011B EC 0139 C5 013A E5 013D BC 013E BE 0141 A3 0142 B3 0143 D1 0144 F1 0147 D2 0148 F2 0150 D5 0151 F5 0154 C0 0155 E0 0158 D8 0159 F8 015A 8C 015B 9C 015E AA 015F BA 0160 8A 0161 9A 0162 DE 0163 FE 0164 8D 0165 9D 016E D9 016F F9 0170 DB 0171 FB 0179 8F 017A 9F 017B AF 017C BF 017D 8E 017E 9E 02C7 A1 02D8 A2 02D9 FF 02DB B2 02DD BD 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +test encoding-convertto-ucmCompare-cp1250 {Compare against ICU UCM} -body { + ucmConverttoMismatches cp1250 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A4 A4 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00BB BB 00C1 C1 00C2 C2 00C4 C4 00C7 C7 00C9 C9 00CB CB 00CD CD 00CE CE 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00DA DA 00DC DC 00DD DD 00DF DF 00E1 E1 00E2 E2 00E4 E4 00E7 E7 00E9 E9 00EB EB 00ED ED 00EE EE 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00FA FA 00FC FC 00FD FD 0102 C3 0103 E3 0104 A5 0105 B9 0106 C6 0107 E6 010C C8 010D E8 010E CF 010F EF 0110 D0 0111 F0 0118 CA 0119 EA 011A CC 011B EC 0139 C5 013A E5 013D BC 013E BE 0141 A3 0142 B3 0143 D1 0144 F1 0147 D2 0148 F2 0150 D5 0151 F5 0154 C0 0155 E0 0158 D8 0159 F8 015A 8C 015B 9C 015E AA 015F BA 0160 8A 0161 9A 0162 DE 0163 FE 0164 8D 0165 9D 016E D9 016F F9 0170 DB 0171 FB 0179 8F 017A 9F 017B AF 017C BF 017D 8E 017E 9E 02C7 A1 02D8 A2 02D9 FF 02DB B2 02DD BD 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +# cp1250 - invalid byte sequences +lappend encInvalidBytes {*}{ + cp1250 81 tcl8 \U00000081 -1 {} {} + cp1250 81 replace \uFFFD -1 {} {} + cp1250 81 strict {} 0 {} {} + cp1250 83 tcl8 \U00000083 -1 {} {} + cp1250 83 replace \uFFFD -1 {} {} + cp1250 83 strict {} 0 {} {} + cp1250 88 tcl8 \U00000088 -1 {} {} + cp1250 88 replace \uFFFD -1 {} {} + cp1250 88 strict {} 0 {} {} + cp1250 90 tcl8 \U00000090 -1 {} {} + cp1250 90 replace \uFFFD -1 {} {} + cp1250 90 strict {} 0 {} {} + cp1250 98 tcl8 \U00000098 -1 {} {} + cp1250 98 replace \uFFFD -1 {} {} + cp1250 98 strict {} 0 {} {} +}; # cp1250 + +# cp1250 - invalid byte sequences +lappend encUnencodableStrings {*}{ + cp1250 \U00000080 tcl8 1A -1 {} {} + cp1250 \U00000080 replace 1A -1 {} {} + cp1250 \U00000080 strict {} 0 {} {} + cp1250 \U00000400 tcl8 1A -1 {} {} + cp1250 \U00000400 replace 1A -1 {} {} + cp1250 \U00000400 strict {} 0 {} {} + cp1250 \U0000D800 tcl8 1A -1 {} {} + cp1250 \U0000D800 replace 1A -1 {} {} + cp1250 \U0000D800 strict {} 0 {} {} + cp1250 \U0000DC00 tcl8 1A -1 {} {} + cp1250 \U0000DC00 replace 1A -1 {} {} + cp1250 \U0000DC00 strict {} 0 {} {} + cp1250 \U00010000 tcl8 1A -1 {} {} + cp1250 \U00010000 replace 1A -1 {} {} + cp1250 \U00010000 strict {} 0 {} {} + cp1250 \U0010FFFF tcl8 1A -1 {} {} + cp1250 \U0010FFFF replace 1A -1 {} {} + cp1250 \U0010FFFF strict {} 0 {} {} +}; # cp1250 + +# +# cp1251 (generated from glibc-CP1251-2.1.2) + +test encoding-convertfrom-ucmCompare-cp1251 {Compare against ICU UCM} -body { + ucmConvertfromMismatches cp1251 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A4 A4 00A6 A6 00A7 A7 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B5 B5 00B6 B6 00B7 B7 00BB BB 0401 A8 0402 80 0403 81 0404 AA 0405 BD 0406 B2 0407 AF 0408 A3 0409 8A 040A 8C 040B 8E 040C 8D 040E A1 040F 8F 0410 C0 0411 C1 0412 C2 0413 C3 0414 C4 0415 C5 0416 C6 0417 C7 0418 C8 0419 C9 041A CA 041B CB 041C CC 041D CD 041E CE 041F CF 0420 D0 0421 D1 0422 D2 0423 D3 0424 D4 0425 D5 0426 D6 0427 D7 0428 D8 0429 D9 042A DA 042B DB 042C DC 042D DD 042E DE 042F DF 0430 E0 0431 E1 0432 E2 0433 E3 0434 E4 0435 E5 0436 E6 0437 E7 0438 E8 0439 E9 043A EA 043B EB 043C EC 043D ED 043E EE 043F EF 0440 F0 0441 F1 0442 F2 0443 F3 0444 F4 0445 F5 0446 F6 0447 F7 0448 F8 0449 F9 044A FA 044B FB 044C FC 044D FD 044E FE 044F FF 0451 B8 0452 90 0453 83 0454 BA 0455 BE 0456 B3 0457 BF 0458 BC 0459 9A 045A 9C 045B 9E 045C 9D 045E A2 045F 9F 0490 A5 0491 B4 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 88 2116 B9 2122 99} +} -result {} + +test encoding-convertto-ucmCompare-cp1251 {Compare against ICU UCM} -body { + ucmConverttoMismatches cp1251 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A4 A4 00A6 A6 00A7 A7 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B5 B5 00B6 B6 00B7 B7 00BB BB 0401 A8 0402 80 0403 81 0404 AA 0405 BD 0406 B2 0407 AF 0408 A3 0409 8A 040A 8C 040B 8E 040C 8D 040E A1 040F 8F 0410 C0 0411 C1 0412 C2 0413 C3 0414 C4 0415 C5 0416 C6 0417 C7 0418 C8 0419 C9 041A CA 041B CB 041C CC 041D CD 041E CE 041F CF 0420 D0 0421 D1 0422 D2 0423 D3 0424 D4 0425 D5 0426 D6 0427 D7 0428 D8 0429 D9 042A DA 042B DB 042C DC 042D DD 042E DE 042F DF 0430 E0 0431 E1 0432 E2 0433 E3 0434 E4 0435 E5 0436 E6 0437 E7 0438 E8 0439 E9 043A EA 043B EB 043C EC 043D ED 043E EE 043F EF 0440 F0 0441 F1 0442 F2 0443 F3 0444 F4 0445 F5 0446 F6 0447 F7 0448 F8 0449 F9 044A FA 044B FB 044C FC 044D FD 044E FE 044F FF 0451 B8 0452 90 0453 83 0454 BA 0455 BE 0456 B3 0457 BF 0458 BC 0459 9A 045A 9C 045B 9E 045C 9D 045E A2 045F 9F 0490 A5 0491 B4 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 88 2116 B9 2122 99} +} -result {} + +# cp1251 - invalid byte sequences +lappend encInvalidBytes {*}{ + cp1251 98 tcl8 \U00000098 -1 {} {} + cp1251 98 replace \uFFFD -1 {} {} + cp1251 98 strict {} 0 {} {} +}; # cp1251 + +# cp1251 - invalid byte sequences +lappend encUnencodableStrings {*}{ + cp1251 \U00000080 tcl8 1A -1 {} {} + cp1251 \U00000080 replace 1A -1 {} {} + cp1251 \U00000080 strict {} 0 {} {} + cp1251 \U00000400 tcl8 1A -1 {} {} + cp1251 \U00000400 replace 1A -1 {} {} + cp1251 \U00000400 strict {} 0 {} {} + cp1251 \U0000D800 tcl8 1A -1 {} {} + cp1251 \U0000D800 replace 1A -1 {} {} + cp1251 \U0000D800 strict {} 0 {} {} + cp1251 \U0000DC00 tcl8 1A -1 {} {} + cp1251 \U0000DC00 replace 1A -1 {} {} + cp1251 \U0000DC00 strict {} 0 {} {} + cp1251 \U00010000 tcl8 1A -1 {} {} + cp1251 \U00010000 replace 1A -1 {} {} + cp1251 \U00010000 strict {} 0 {} {} + cp1251 \U0010FFFF tcl8 1A -1 {} {} + cp1251 \U0010FFFF replace 1A -1 {} {} + cp1251 \U0010FFFF strict {} 0 {} {} +}; # cp1251 + +# +# cp1252 (generated from glibc-CP1252-2.1.2) + +test encoding-convertfrom-ucmCompare-cp1252 {Compare against ICU UCM} -body { + ucmConvertfromMismatches cp1252 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D0 D0 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F0 F0 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 00FF FF 0152 8C 0153 9C 0160 8A 0161 9A 0178 9F 017D 8E 017E 9E 0192 83 02C6 88 02DC 98 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +test encoding-convertto-ucmCompare-cp1252 {Compare against ICU UCM} -body { + ucmConverttoMismatches cp1252 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D0 D0 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F0 F0 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 00FF FF 0152 8C 0153 9C 0160 8A 0161 9A 0178 9F 017D 8E 017E 9E 0192 83 02C6 88 02DC 98 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +# cp1252 - invalid byte sequences +lappend encInvalidBytes {*}{ + cp1252 81 tcl8 \U00000081 -1 {} {} + cp1252 81 replace \uFFFD -1 {} {} + cp1252 81 strict {} 0 {} {} + cp1252 8D tcl8 \U0000008D -1 {} {} + cp1252 8D replace \uFFFD -1 {} {} + cp1252 8D strict {} 0 {} {} + cp1252 8F tcl8 \U0000008F -1 {} {} + cp1252 8F replace \uFFFD -1 {} {} + cp1252 8F strict {} 0 {} {} + cp1252 90 tcl8 \U00000090 -1 {} {} + cp1252 90 replace \uFFFD -1 {} {} + cp1252 90 strict {} 0 {} {} + cp1252 9D tcl8 \U0000009D -1 {} {} + cp1252 9D replace \uFFFD -1 {} {} + cp1252 9D strict {} 0 {} {} +}; # cp1252 + +# cp1252 - invalid byte sequences +lappend encUnencodableStrings {*}{ + cp1252 \U00000080 tcl8 1A -1 {} {} + cp1252 \U00000080 replace 1A -1 {} {} + cp1252 \U00000080 strict {} 0 {} {} + cp1252 \U00000400 tcl8 1A -1 {} {} + cp1252 \U00000400 replace 1A -1 {} {} + cp1252 \U00000400 strict {} 0 {} {} + cp1252 \U0000D800 tcl8 1A -1 {} {} + cp1252 \U0000D800 replace 1A -1 {} {} + cp1252 \U0000D800 strict {} 0 {} {} + cp1252 \U0000DC00 tcl8 1A -1 {} {} + cp1252 \U0000DC00 replace 1A -1 {} {} + cp1252 \U0000DC00 strict {} 0 {} {} + cp1252 \U00010000 tcl8 1A -1 {} {} + cp1252 \U00010000 replace 1A -1 {} {} + cp1252 \U00010000 strict {} 0 {} {} + cp1252 \U0010FFFF tcl8 1A -1 {} {} + cp1252 \U0010FFFF replace 1A -1 {} {} + cp1252 \U0010FFFF strict {} 0 {} {} +}; # cp1252 + +# +# cp1253 (generated from glibc-CP1253-2.1.2) + +test encoding-convertfrom-ucmCompare-cp1253 {Compare against ICU UCM} -body { + ucmConvertfromMismatches cp1253 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B5 B5 00B6 B6 00B7 B7 00BB BB 00BD BD 0192 83 0384 B4 0385 A1 0386 A2 0388 B8 0389 B9 038A BA 038C BC 038E BE 038F BF 0390 C0 0391 C1 0392 C2 0393 C3 0394 C4 0395 C5 0396 C6 0397 C7 0398 C8 0399 C9 039A CA 039B CB 039C CC 039D CD 039E CE 039F CF 03A0 D0 03A1 D1 03A3 D3 03A4 D4 03A5 D5 03A6 D6 03A7 D7 03A8 D8 03A9 D9 03AA DA 03AB DB 03AC DC 03AD DD 03AE DE 03AF DF 03B0 E0 03B1 E1 03B2 E2 03B3 E3 03B4 E4 03B5 E5 03B6 E6 03B7 E7 03B8 E8 03B9 E9 03BA EA 03BB EB 03BC EC 03BD ED 03BE EE 03BF EF 03C0 F0 03C1 F1 03C2 F2 03C3 F3 03C4 F4 03C5 F5 03C6 F6 03C7 F7 03C8 F8 03C9 F9 03CA FA 03CB FB 03CC FC 03CD FD 03CE FE 2013 96 2014 97 2015 AF 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +test encoding-convertto-ucmCompare-cp1253 {Compare against ICU UCM} -body { + ucmConverttoMismatches cp1253 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B5 B5 00B6 B6 00B7 B7 00BB BB 00BD BD 0192 83 0384 B4 0385 A1 0386 A2 0388 B8 0389 B9 038A BA 038C BC 038E BE 038F BF 0390 C0 0391 C1 0392 C2 0393 C3 0394 C4 0395 C5 0396 C6 0397 C7 0398 C8 0399 C9 039A CA 039B CB 039C CC 039D CD 039E CE 039F CF 03A0 D0 03A1 D1 03A3 D3 03A4 D4 03A5 D5 03A6 D6 03A7 D7 03A8 D8 03A9 D9 03AA DA 03AB DB 03AC DC 03AD DD 03AE DE 03AF DF 03B0 E0 03B1 E1 03B2 E2 03B3 E3 03B4 E4 03B5 E5 03B6 E6 03B7 E7 03B8 E8 03B9 E9 03BA EA 03BB EB 03BC EC 03BD ED 03BE EE 03BF EF 03C0 F0 03C1 F1 03C2 F2 03C3 F3 03C4 F4 03C5 F5 03C6 F6 03C7 F7 03C8 F8 03C9 F9 03CA FA 03CB FB 03CC FC 03CD FD 03CE FE 2013 96 2014 97 2015 AF 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +# cp1253 - invalid byte sequences +lappend encInvalidBytes {*}{ + cp1253 81 tcl8 \U00000081 -1 {} {} + cp1253 81 replace \uFFFD -1 {} {} + cp1253 81 strict {} 0 {} {} + cp1253 88 tcl8 \U00000088 -1 {} {} + cp1253 88 replace \uFFFD -1 {} {} + cp1253 88 strict {} 0 {} {} + cp1253 8A tcl8 \U0000008A -1 {} {} + cp1253 8A replace \uFFFD -1 {} {} + cp1253 8A strict {} 0 {} {} + cp1253 8C tcl8 \U0000008C -1 {} {} + cp1253 8C replace \uFFFD -1 {} {} + cp1253 8C strict {} 0 {} {} + cp1253 8D tcl8 \U0000008D -1 {} {} + cp1253 8D replace \uFFFD -1 {} {} + cp1253 8D strict {} 0 {} {} + cp1253 8E tcl8 \U0000008E -1 {} {} + cp1253 8E replace \uFFFD -1 {} {} + cp1253 8E strict {} 0 {} {} + cp1253 8F tcl8 \U0000008F -1 {} {} + cp1253 8F replace \uFFFD -1 {} {} + cp1253 8F strict {} 0 {} {} + cp1253 90 tcl8 \U00000090 -1 {} {} + cp1253 90 replace \uFFFD -1 {} {} + cp1253 90 strict {} 0 {} {} + cp1253 98 tcl8 \U00000098 -1 {} {} + cp1253 98 replace \uFFFD -1 {} {} + cp1253 98 strict {} 0 {} {} + cp1253 9A tcl8 \U0000009A -1 {} {} + cp1253 9A replace \uFFFD -1 {} {} + cp1253 9A strict {} 0 {} {} + cp1253 9C tcl8 \U0000009C -1 {} {} + cp1253 9C replace \uFFFD -1 {} {} + cp1253 9C strict {} 0 {} {} + cp1253 9D tcl8 \U0000009D -1 {} {} + cp1253 9D replace \uFFFD -1 {} {} + cp1253 9D strict {} 0 {} {} + cp1253 9E tcl8 \U0000009E -1 {} {} + cp1253 9E replace \uFFFD -1 {} {} + cp1253 9E strict {} 0 {} {} + cp1253 9F tcl8 \U0000009F -1 {} {} + cp1253 9F replace \uFFFD -1 {} {} + cp1253 9F strict {} 0 {} {} + cp1253 AA tcl8 \U000000AA -1 {} {} + cp1253 AA replace \uFFFD -1 {} {} + cp1253 AA strict {} 0 {} {} + cp1253 D2 tcl8 \U000000D2 -1 {} {} + cp1253 D2 replace \uFFFD -1 {} {} + cp1253 D2 strict {} 0 {} {} + cp1253 FF tcl8 \U000000FF -1 {} {} + cp1253 FF replace \uFFFD -1 {} {} + cp1253 FF strict {} 0 {} {} +}; # cp1253 + +# cp1253 - invalid byte sequences +lappend encUnencodableStrings {*}{ + cp1253 \U00000080 tcl8 1A -1 {} {} + cp1253 \U00000080 replace 1A -1 {} {} + cp1253 \U00000080 strict {} 0 {} {} + cp1253 \U00000400 tcl8 1A -1 {} {} + cp1253 \U00000400 replace 1A -1 {} {} + cp1253 \U00000400 strict {} 0 {} {} + cp1253 \U0000D800 tcl8 1A -1 {} {} + cp1253 \U0000D800 replace 1A -1 {} {} + cp1253 \U0000D800 strict {} 0 {} {} + cp1253 \U0000DC00 tcl8 1A -1 {} {} + cp1253 \U0000DC00 replace 1A -1 {} {} + cp1253 \U0000DC00 strict {} 0 {} {} + cp1253 \U00010000 tcl8 1A -1 {} {} + cp1253 \U00010000 replace 1A -1 {} {} + cp1253 \U00010000 strict {} 0 {} {} + cp1253 \U0010FFFF tcl8 1A -1 {} {} + cp1253 \U0010FFFF replace 1A -1 {} {} + cp1253 \U0010FFFF strict {} 0 {} {} +}; # cp1253 + +# +# cp1254 (generated from glibc-CP1254-2.1.2) + +test encoding-convertfrom-ucmCompare-cp1254 {Compare against ICU UCM} -body { + ucmConvertfromMismatches cp1254 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 011E D0 011F F0 0130 DD 0131 FD 0152 8C 0153 9C 015E DE 015F FE 0160 8A 0161 9A 0178 9F 0192 83 02C6 88 02DC 98 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +test encoding-convertto-ucmCompare-cp1254 {Compare against ICU UCM} -body { + ucmConverttoMismatches cp1254 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 011E D0 011F F0 0130 DD 0131 FD 0152 8C 0153 9C 015E DE 015F FE 0160 8A 0161 9A 0178 9F 0192 83 02C6 88 02DC 98 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +# cp1254 - invalid byte sequences +lappend encInvalidBytes {*}{ + cp1254 81 tcl8 \U00000081 -1 {} {} + cp1254 81 replace \uFFFD -1 {} {} + cp1254 81 strict {} 0 {} {} + cp1254 8D tcl8 \U0000008D -1 {} {} + cp1254 8D replace \uFFFD -1 {} {} + cp1254 8D strict {} 0 {} {} + cp1254 8E tcl8 \U0000008E -1 {} {} + cp1254 8E replace \uFFFD -1 {} {} + cp1254 8E strict {} 0 {} {} + cp1254 8F tcl8 \U0000008F -1 {} {} + cp1254 8F replace \uFFFD -1 {} {} + cp1254 8F strict {} 0 {} {} + cp1254 90 tcl8 \U00000090 -1 {} {} + cp1254 90 replace \uFFFD -1 {} {} + cp1254 90 strict {} 0 {} {} + cp1254 9D tcl8 \U0000009D -1 {} {} + cp1254 9D replace \uFFFD -1 {} {} + cp1254 9D strict {} 0 {} {} + cp1254 9E tcl8 \U0000009E -1 {} {} + cp1254 9E replace \uFFFD -1 {} {} + cp1254 9E strict {} 0 {} {} +}; # cp1254 + +# cp1254 - invalid byte sequences +lappend encUnencodableStrings {*}{ + cp1254 \U00000080 tcl8 1A -1 {} {} + cp1254 \U00000080 replace 1A -1 {} {} + cp1254 \U00000080 strict {} 0 {} {} + cp1254 \U00000400 tcl8 1A -1 {} {} + cp1254 \U00000400 replace 1A -1 {} {} + cp1254 \U00000400 strict {} 0 {} {} + cp1254 \U0000D800 tcl8 1A -1 {} {} + cp1254 \U0000D800 replace 1A -1 {} {} + cp1254 \U0000D800 strict {} 0 {} {} + cp1254 \U0000DC00 tcl8 1A -1 {} {} + cp1254 \U0000DC00 replace 1A -1 {} {} + cp1254 \U0000DC00 strict {} 0 {} {} + cp1254 \U00010000 tcl8 1A -1 {} {} + cp1254 \U00010000 replace 1A -1 {} {} + cp1254 \U00010000 strict {} 0 {} {} + cp1254 \U0010FFFF tcl8 1A -1 {} {} + cp1254 \U0010FFFF replace 1A -1 {} {} + cp1254 \U0010FFFF strict {} 0 {} {} +}; # cp1254 + +# +# cp1255 (generated from glibc-CP1255-2.1.2) + +test encoding-convertfrom-ucmCompare-cp1255 {Compare against ICU UCM} -body { + ucmConvertfromMismatches cp1255 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00D7 AA 00F7 BA 0192 83 02C6 88 02DC 98 05B0 C0 05B1 C1 05B2 C2 05B3 C3 05B4 C4 05B5 C5 05B6 C6 05B7 C7 05B8 C8 05B9 C9 05BB CB 05BC CC 05BD CD 05BE CE 05BF CF 05C0 D0 05C1 D1 05C2 D2 05C3 D3 05D0 E0 05D1 E1 05D2 E2 05D3 E3 05D4 E4 05D5 E5 05D6 E6 05D7 E7 05D8 E8 05D9 E9 05DA EA 05DB EB 05DC EC 05DD ED 05DE EE 05DF EF 05E0 F0 05E1 F1 05E2 F2 05E3 F3 05E4 F4 05E5 F5 05E6 F6 05E7 F7 05E8 F8 05E9 F9 05EA FA 05F0 D4 05F1 D5 05F2 D6 05F3 D7 05F4 D8 200E FD 200F FE 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AA A4 20AC 80 2122 99} +} -result {} + +test encoding-convertto-ucmCompare-cp1255 {Compare against ICU UCM} -body { + ucmConverttoMismatches cp1255 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00D7 AA 00F7 BA 0192 83 02C6 88 02DC 98 05B0 C0 05B1 C1 05B2 C2 05B3 C3 05B4 C4 05B5 C5 05B6 C6 05B7 C7 05B8 C8 05B9 C9 05BB CB 05BC CC 05BD CD 05BE CE 05BF CF 05C0 D0 05C1 D1 05C2 D2 05C3 D3 05D0 E0 05D1 E1 05D2 E2 05D3 E3 05D4 E4 05D5 E5 05D6 E6 05D7 E7 05D8 E8 05D9 E9 05DA EA 05DB EB 05DC EC 05DD ED 05DE EE 05DF EF 05E0 F0 05E1 F1 05E2 F2 05E3 F3 05E4 F4 05E5 F5 05E6 F6 05E7 F7 05E8 F8 05E9 F9 05EA FA 05F0 D4 05F1 D5 05F2 D6 05F3 D7 05F4 D8 200E FD 200F FE 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AA A4 20AC 80 2122 99} +} -result {} + +# cp1255 - invalid byte sequences +lappend encInvalidBytes {*}{ + cp1255 81 tcl8 \U00000081 -1 {} {} + cp1255 81 replace \uFFFD -1 {} {} + cp1255 81 strict {} 0 {} {} + cp1255 8A tcl8 \U0000008A -1 {} {} + cp1255 8A replace \uFFFD -1 {} {} + cp1255 8A strict {} 0 {} {} + cp1255 8C tcl8 \U0000008C -1 {} {} + cp1255 8C replace \uFFFD -1 {} {} + cp1255 8C strict {} 0 {} {} + cp1255 8D tcl8 \U0000008D -1 {} {} + cp1255 8D replace \uFFFD -1 {} {} + cp1255 8D strict {} 0 {} {} + cp1255 8E tcl8 \U0000008E -1 {} {} + cp1255 8E replace \uFFFD -1 {} {} + cp1255 8E strict {} 0 {} {} + cp1255 8F tcl8 \U0000008F -1 {} {} + cp1255 8F replace \uFFFD -1 {} {} + cp1255 8F strict {} 0 {} {} + cp1255 90 tcl8 \U00000090 -1 {} {} + cp1255 90 replace \uFFFD -1 {} {} + cp1255 90 strict {} 0 {} {} + cp1255 9A tcl8 \U0000009A -1 {} {} + cp1255 9A replace \uFFFD -1 {} {} + cp1255 9A strict {} 0 {} {} + cp1255 9C tcl8 \U0000009C -1 {} {} + cp1255 9C replace \uFFFD -1 {} {} + cp1255 9C strict {} 0 {} {} + cp1255 9D tcl8 \U0000009D -1 {} {} + cp1255 9D replace \uFFFD -1 {} {} + cp1255 9D strict {} 0 {} {} + cp1255 9E tcl8 \U0000009E -1 {} {} + cp1255 9E replace \uFFFD -1 {} {} + cp1255 9E strict {} 0 {} {} + cp1255 9F tcl8 \U0000009F -1 {} {} + cp1255 9F replace \uFFFD -1 {} {} + cp1255 9F strict {} 0 {} {} + cp1255 CA tcl8 \U000000CA -1 {} {} + cp1255 CA replace \uFFFD -1 {} {} + cp1255 CA strict {} 0 {} {} + cp1255 D9 tcl8 \U000000D9 -1 {} {} + cp1255 D9 replace \uFFFD -1 {} {} + cp1255 D9 strict {} 0 {} {} + cp1255 DA tcl8 \U000000DA -1 {} {} + cp1255 DA replace \uFFFD -1 {} {} + cp1255 DA strict {} 0 {} {} + cp1255 DB tcl8 \U000000DB -1 {} {} + cp1255 DB replace \uFFFD -1 {} {} + cp1255 DB strict {} 0 {} {} + cp1255 DC tcl8 \U000000DC -1 {} {} + cp1255 DC replace \uFFFD -1 {} {} + cp1255 DC strict {} 0 {} {} + cp1255 DD tcl8 \U000000DD -1 {} {} + cp1255 DD replace \uFFFD -1 {} {} + cp1255 DD strict {} 0 {} {} + cp1255 DE tcl8 \U000000DE -1 {} {} + cp1255 DE replace \uFFFD -1 {} {} + cp1255 DE strict {} 0 {} {} + cp1255 DF tcl8 \U000000DF -1 {} {} + cp1255 DF replace \uFFFD -1 {} {} + cp1255 DF strict {} 0 {} {} + cp1255 FB tcl8 \U000000FB -1 {} {} + cp1255 FB replace \uFFFD -1 {} {} + cp1255 FB strict {} 0 {} {} + cp1255 FC tcl8 \U000000FC -1 {} {} + cp1255 FC replace \uFFFD -1 {} {} + cp1255 FC strict {} 0 {} {} + cp1255 FF tcl8 \U000000FF -1 {} {} + cp1255 FF replace \uFFFD -1 {} {} + cp1255 FF strict {} 0 {} {} +}; # cp1255 + +# cp1255 - invalid byte sequences +lappend encUnencodableStrings {*}{ + cp1255 \U00000080 tcl8 1A -1 {} {} + cp1255 \U00000080 replace 1A -1 {} {} + cp1255 \U00000080 strict {} 0 {} {} + cp1255 \U00000400 tcl8 1A -1 {} {} + cp1255 \U00000400 replace 1A -1 {} {} + cp1255 \U00000400 strict {} 0 {} {} + cp1255 \U0000D800 tcl8 1A -1 {} {} + cp1255 \U0000D800 replace 1A -1 {} {} + cp1255 \U0000D800 strict {} 0 {} {} + cp1255 \U0000DC00 tcl8 1A -1 {} {} + cp1255 \U0000DC00 replace 1A -1 {} {} + cp1255 \U0000DC00 strict {} 0 {} {} + cp1255 \U00010000 tcl8 1A -1 {} {} + cp1255 \U00010000 replace 1A -1 {} {} + cp1255 \U00010000 strict {} 0 {} {} + cp1255 \U0010FFFF tcl8 1A -1 {} {} + cp1255 \U0010FFFF replace 1A -1 {} {} + cp1255 \U0010FFFF strict {} 0 {} {} +}; # cp1255 + +# +# cp1256 (generated from glibc-CP1256-2.1.2) + +test encoding-convertfrom-ucmCompare-cp1256 {Compare against ICU UCM} -body { + ucmConvertfromMismatches cp1256 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00D7 D7 00E0 E0 00E2 E2 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EE EE 00EF EF 00F4 F4 00F7 F7 00F9 F9 00FB FB 00FC FC 0152 8C 0153 9C 0192 83 02C6 88 060C A1 061B BA 061F BF 0621 C1 0622 C2 0623 C3 0624 C4 0625 C5 0626 C6 0627 C7 0628 C8 0629 C9 062A CA 062B CB 062C CC 062D CD 062E CE 062F CF 0630 D0 0631 D1 0632 D2 0633 D3 0634 D4 0635 D5 0636 D6 0637 D8 0638 D9 0639 DA 063A DB 0640 DC 0641 DD 0642 DE 0643 DF 0644 E1 0645 E3 0646 E4 0647 E5 0648 E6 0649 EC 064A ED 064B F0 064C F1 064D F2 064E F3 064F F5 0650 F6 0651 F8 0652 FA 0679 8A 067E 81 0686 8D 0688 8F 0691 9A 0698 8E 06A9 98 06AF 90 06BA 9F 06BE AA 06C1 C0 06D2 FF 200C 9D 200D 9E 200E FD 200F FE 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +test encoding-convertto-ucmCompare-cp1256 {Compare against ICU UCM} -body { + ucmConverttoMismatches cp1256 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00D7 D7 00E0 E0 00E2 E2 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EE EE 00EF EF 00F4 F4 00F7 F7 00F9 F9 00FB FB 00FC FC 0152 8C 0153 9C 0192 83 02C6 88 060C A1 061B BA 061F BF 0621 C1 0622 C2 0623 C3 0624 C4 0625 C5 0626 C6 0627 C7 0628 C8 0629 C9 062A CA 062B CB 062C CC 062D CD 062E CE 062F CF 0630 D0 0631 D1 0632 D2 0633 D3 0634 D4 0635 D5 0636 D6 0637 D8 0638 D9 0639 DA 063A DB 0640 DC 0641 DD 0642 DE 0643 DF 0644 E1 0645 E3 0646 E4 0647 E5 0648 E6 0649 EC 064A ED 064B F0 064C F1 064D F2 064E F3 064F F5 0650 F6 0651 F8 0652 FA 0679 8A 067E 81 0686 8D 0688 8F 0691 9A 0698 8E 06A9 98 06AF 90 06BA 9F 06BE AA 06C1 C0 06D2 FF 200C 9D 200D 9E 200E FD 200F FE 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +# cp1256 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # cp1256 + +# cp1256 - invalid byte sequences +lappend encUnencodableStrings {*}{ + cp1256 \U00000080 tcl8 1A -1 {} {} + cp1256 \U00000080 replace 1A -1 {} {} + cp1256 \U00000080 strict {} 0 {} {} + cp1256 \U00000400 tcl8 1A -1 {} {} + cp1256 \U00000400 replace 1A -1 {} {} + cp1256 \U00000400 strict {} 0 {} {} + cp1256 \U0000D800 tcl8 1A -1 {} {} + cp1256 \U0000D800 replace 1A -1 {} {} + cp1256 \U0000D800 strict {} 0 {} {} + cp1256 \U0000DC00 tcl8 1A -1 {} {} + cp1256 \U0000DC00 replace 1A -1 {} {} + cp1256 \U0000DC00 strict {} 0 {} {} + cp1256 \U00010000 tcl8 1A -1 {} {} + cp1256 \U00010000 replace 1A -1 {} {} + cp1256 \U00010000 strict {} 0 {} {} + cp1256 \U0010FFFF tcl8 1A -1 {} {} + cp1256 \U0010FFFF replace 1A -1 {} {} + cp1256 \U0010FFFF strict {} 0 {} {} +}; # cp1256 + +# +# cp1257 (generated from glibc-CP1257-2.1.2) + +test encoding-convertfrom-ucmCompare-cp1257 {Compare against ICU UCM} -body { + ucmConvertfromMismatches cp1257 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A6 A6 00A7 A7 00A8 8D 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF 9D 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 8F 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00C4 C4 00C5 C5 00C6 AF 00C9 C9 00D3 D3 00D5 D5 00D6 D6 00D7 D7 00D8 A8 00DC DC 00DF DF 00E4 E4 00E5 E5 00E6 BF 00E9 E9 00F3 F3 00F5 F5 00F6 F6 00F7 F7 00F8 B8 00FC FC 0100 C2 0101 E2 0104 C0 0105 E0 0106 C3 0107 E3 010C C8 010D E8 0112 C7 0113 E7 0116 CB 0117 EB 0118 C6 0119 E6 0122 CC 0123 EC 012A CE 012B EE 012E C1 012F E1 0136 CD 0137 ED 013B CF 013C EF 0141 D9 0142 F9 0143 D1 0144 F1 0145 D2 0146 F2 014C D4 014D F4 0156 AA 0157 BA 015A DA 015B FA 0160 D0 0161 F0 016A DB 016B FB 0172 D8 0173 F8 0179 CA 017A EA 017B DD 017C FD 017D DE 017E FE 02C7 8E 02D9 FF 02DB 9E 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +test encoding-convertto-ucmCompare-cp1257 {Compare against ICU UCM} -body { + ucmConverttoMismatches cp1257 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A6 A6 00A7 A7 00A8 8D 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF 9D 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 8F 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00C4 C4 00C5 C5 00C6 AF 00C9 C9 00D3 D3 00D5 D5 00D6 D6 00D7 D7 00D8 A8 00DC DC 00DF DF 00E4 E4 00E5 E5 00E6 BF 00E9 E9 00F3 F3 00F5 F5 00F6 F6 00F7 F7 00F8 B8 00FC FC 0100 C2 0101 E2 0104 C0 0105 E0 0106 C3 0107 E3 010C C8 010D E8 0112 C7 0113 E7 0116 CB 0117 EB 0118 C6 0119 E6 0122 CC 0123 EC 012A CE 012B EE 012E C1 012F E1 0136 CD 0137 ED 013B CF 013C EF 0141 D9 0142 F9 0143 D1 0144 F1 0145 D2 0146 F2 014C D4 014D F4 0156 AA 0157 BA 015A DA 015B FA 0160 D0 0161 F0 016A DB 016B FB 0172 D8 0173 F8 0179 CA 017A EA 017B DD 017C FD 017D DE 017E FE 02C7 8E 02D9 FF 02DB 9E 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AC 80 2122 99} +} -result {} + +# cp1257 - invalid byte sequences +lappend encInvalidBytes {*}{ + cp1257 81 tcl8 \U00000081 -1 {} {} + cp1257 81 replace \uFFFD -1 {} {} + cp1257 81 strict {} 0 {} {} + cp1257 83 tcl8 \U00000083 -1 {} {} + cp1257 83 replace \uFFFD -1 {} {} + cp1257 83 strict {} 0 {} {} + cp1257 88 tcl8 \U00000088 -1 {} {} + cp1257 88 replace \uFFFD -1 {} {} + cp1257 88 strict {} 0 {} {} + cp1257 8A tcl8 \U0000008A -1 {} {} + cp1257 8A replace \uFFFD -1 {} {} + cp1257 8A strict {} 0 {} {} + cp1257 8C tcl8 \U0000008C -1 {} {} + cp1257 8C replace \uFFFD -1 {} {} + cp1257 8C strict {} 0 {} {} + cp1257 90 tcl8 \U00000090 -1 {} {} + cp1257 90 replace \uFFFD -1 {} {} + cp1257 90 strict {} 0 {} {} + cp1257 98 tcl8 \U00000098 -1 {} {} + cp1257 98 replace \uFFFD -1 {} {} + cp1257 98 strict {} 0 {} {} + cp1257 9A tcl8 \U0000009A -1 {} {} + cp1257 9A replace \uFFFD -1 {} {} + cp1257 9A strict {} 0 {} {} + cp1257 9C tcl8 \U0000009C -1 {} {} + cp1257 9C replace \uFFFD -1 {} {} + cp1257 9C strict {} 0 {} {} + cp1257 9F tcl8 \U0000009F -1 {} {} + cp1257 9F replace \uFFFD -1 {} {} + cp1257 9F strict {} 0 {} {} + cp1257 A1 tcl8 \U000000A1 -1 {} {} + cp1257 A1 replace \uFFFD -1 {} {} + cp1257 A1 strict {} 0 {} {} + cp1257 A5 tcl8 \U000000A5 -1 {} {} + cp1257 A5 replace \uFFFD -1 {} {} + cp1257 A5 strict {} 0 {} {} +}; # cp1257 + +# cp1257 - invalid byte sequences +lappend encUnencodableStrings {*}{ + cp1257 \U00000080 tcl8 1A -1 {} {} + cp1257 \U00000080 replace 1A -1 {} {} + cp1257 \U00000080 strict {} 0 {} {} + cp1257 \U00000400 tcl8 1A -1 {} {} + cp1257 \U00000400 replace 1A -1 {} {} + cp1257 \U00000400 strict {} 0 {} {} + cp1257 \U0000D800 tcl8 1A -1 {} {} + cp1257 \U0000D800 replace 1A -1 {} {} + cp1257 \U0000D800 strict {} 0 {} {} + cp1257 \U0000DC00 tcl8 1A -1 {} {} + cp1257 \U0000DC00 replace 1A -1 {} {} + cp1257 \U0000DC00 strict {} 0 {} {} + cp1257 \U00010000 tcl8 1A -1 {} {} + cp1257 \U00010000 replace 1A -1 {} {} + cp1257 \U00010000 strict {} 0 {} {} + cp1257 \U0010FFFF tcl8 1A -1 {} {} + cp1257 \U0010FFFF replace 1A -1 {} {} + cp1257 \U0010FFFF strict {} 0 {} {} +}; # cp1257 + +# +# cp1258 (generated from glibc-CP1258-2.1.2) + +test encoding-convertfrom-ucmCompare-cp1258 {Compare against ICU UCM} -body { + ucmConvertfromMismatches cp1258 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CD CD 00CE CE 00CF CF 00D1 D1 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00ED ED 00EE EE 00EF EF 00F1 F1 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 0102 C3 0103 E3 0110 D0 0111 F0 0152 8C 0153 9C 0178 9F 0192 83 01A0 D5 01A1 F5 01AF DD 01B0 FD 02C6 88 02DC 98 0300 CC 0303 DE 0309 D2 0323 F2 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AB FE 20AC 80 2122 99} +} -result {} + +test encoding-convertto-ucmCompare-cp1258 {Compare against ICU UCM} -body { + ucmConverttoMismatches cp1258 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CD CD 00CE CE 00CF CF 00D1 D1 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00ED ED 00EE EE 00EF EF 00F1 F1 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 0102 C3 0103 E3 0110 D0 0111 F0 0152 8C 0153 9C 0178 9F 0192 83 01A0 D5 01A1 F5 01AF DD 01B0 FD 02C6 88 02DC 98 0300 CC 0303 DE 0309 D2 0323 F2 2013 96 2014 97 2018 91 2019 92 201A 82 201C 93 201D 94 201E 84 2020 86 2021 87 2022 95 2026 85 2030 89 2039 8B 203A 9B 20AB FE 20AC 80 2122 99} +} -result {} + +# cp1258 - invalid byte sequences +lappend encInvalidBytes {*}{ + cp1258 81 tcl8 \U00000081 -1 {} {} + cp1258 81 replace \uFFFD -1 {} {} + cp1258 81 strict {} 0 {} {} + cp1258 8A tcl8 \U0000008A -1 {} {} + cp1258 8A replace \uFFFD -1 {} {} + cp1258 8A strict {} 0 {} {} + cp1258 8D tcl8 \U0000008D -1 {} {} + cp1258 8D replace \uFFFD -1 {} {} + cp1258 8D strict {} 0 {} {} + cp1258 8E tcl8 \U0000008E -1 {} {} + cp1258 8E replace \uFFFD -1 {} {} + cp1258 8E strict {} 0 {} {} + cp1258 8F tcl8 \U0000008F -1 {} {} + cp1258 8F replace \uFFFD -1 {} {} + cp1258 8F strict {} 0 {} {} + cp1258 90 tcl8 \U00000090 -1 {} {} + cp1258 90 replace \uFFFD -1 {} {} + cp1258 90 strict {} 0 {} {} + cp1258 9A tcl8 \U0000009A -1 {} {} + cp1258 9A replace \uFFFD -1 {} {} + cp1258 9A strict {} 0 {} {} + cp1258 9D tcl8 \U0000009D -1 {} {} + cp1258 9D replace \uFFFD -1 {} {} + cp1258 9D strict {} 0 {} {} + cp1258 9E tcl8 \U0000009E -1 {} {} + cp1258 9E replace \uFFFD -1 {} {} + cp1258 9E strict {} 0 {} {} + cp1258 EC tcl8 \U000000EC -1 {} {} + cp1258 EC replace \uFFFD -1 {} {} + cp1258 EC strict {} 0 {} {} +}; # cp1258 + +# cp1258 - invalid byte sequences +lappend encUnencodableStrings {*}{ + cp1258 \U00000080 tcl8 1A -1 {} {} + cp1258 \U00000080 replace 1A -1 {} {} + cp1258 \U00000080 strict {} 0 {} {} + cp1258 \U00000400 tcl8 1A -1 {} {} + cp1258 \U00000400 replace 1A -1 {} {} + cp1258 \U00000400 strict {} 0 {} {} + cp1258 \U0000D800 tcl8 1A -1 {} {} + cp1258 \U0000D800 replace 1A -1 {} {} + cp1258 \U0000D800 strict {} 0 {} {} + cp1258 \U0000DC00 tcl8 1A -1 {} {} + cp1258 \U0000DC00 replace 1A -1 {} {} + cp1258 \U0000DC00 strict {} 0 {} {} + cp1258 \U00010000 tcl8 1A -1 {} {} + cp1258 \U00010000 replace 1A -1 {} {} + cp1258 \U00010000 strict {} 0 {} {} + cp1258 \U0010FFFF tcl8 1A -1 {} {} + cp1258 \U0010FFFF replace 1A -1 {} {} + cp1258 \U0010FFFF strict {} 0 {} {} +}; # cp1258 + +# +# gb1988 (generated from glibc-GB_1988_80-2.3.3) + +test encoding-convertfrom-ucmCompare-gb1988 {Compare against ICU UCM} -body { + ucmConvertfromMismatches gb1988 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007F 7F 00A5 24 203E 7E} +} -result {} + +test encoding-convertto-ucmCompare-gb1988 {Compare against ICU UCM} -body { + ucmConverttoMismatches gb1988 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007F 7F 00A5 24 203E 7E} +} -result {} + +# gb1988 - invalid byte sequences +lappend encInvalidBytes {*}{ + gb1988 80 tcl8 \U00000080 -1 {} {} + gb1988 80 replace \uFFFD -1 {} {} + gb1988 80 strict {} 0 {} {} + gb1988 81 tcl8 \U00000081 -1 {} {} + gb1988 81 replace \uFFFD -1 {} {} + gb1988 81 strict {} 0 {} {} + gb1988 82 tcl8 \U00000082 -1 {} {} + gb1988 82 replace \uFFFD -1 {} {} + gb1988 82 strict {} 0 {} {} + gb1988 83 tcl8 \U00000083 -1 {} {} + gb1988 83 replace \uFFFD -1 {} {} + gb1988 83 strict {} 0 {} {} + gb1988 84 tcl8 \U00000084 -1 {} {} + gb1988 84 replace \uFFFD -1 {} {} + gb1988 84 strict {} 0 {} {} + gb1988 85 tcl8 \U00000085 -1 {} {} + gb1988 85 replace \uFFFD -1 {} {} + gb1988 85 strict {} 0 {} {} + gb1988 86 tcl8 \U00000086 -1 {} {} + gb1988 86 replace \uFFFD -1 {} {} + gb1988 86 strict {} 0 {} {} + gb1988 87 tcl8 \U00000087 -1 {} {} + gb1988 87 replace \uFFFD -1 {} {} + gb1988 87 strict {} 0 {} {} + gb1988 88 tcl8 \U00000088 -1 {} {} + gb1988 88 replace \uFFFD -1 {} {} + gb1988 88 strict {} 0 {} {} + gb1988 89 tcl8 \U00000089 -1 {} {} + gb1988 89 replace \uFFFD -1 {} {} + gb1988 89 strict {} 0 {} {} + gb1988 8A tcl8 \U0000008A -1 {} {} + gb1988 8A replace \uFFFD -1 {} {} + gb1988 8A strict {} 0 {} {} + gb1988 8B tcl8 \U0000008B -1 {} {} + gb1988 8B replace \uFFFD -1 {} {} + gb1988 8B strict {} 0 {} {} + gb1988 8C tcl8 \U0000008C -1 {} {} + gb1988 8C replace \uFFFD -1 {} {} + gb1988 8C strict {} 0 {} {} + gb1988 8D tcl8 \U0000008D -1 {} {} + gb1988 8D replace \uFFFD -1 {} {} + gb1988 8D strict {} 0 {} {} + gb1988 8E tcl8 \U0000008E -1 {} {} + gb1988 8E replace \uFFFD -1 {} {} + gb1988 8E strict {} 0 {} {} + gb1988 8F tcl8 \U0000008F -1 {} {} + gb1988 8F replace \uFFFD -1 {} {} + gb1988 8F strict {} 0 {} {} + gb1988 90 tcl8 \U00000090 -1 {} {} + gb1988 90 replace \uFFFD -1 {} {} + gb1988 90 strict {} 0 {} {} + gb1988 91 tcl8 \U00000091 -1 {} {} + gb1988 91 replace \uFFFD -1 {} {} + gb1988 91 strict {} 0 {} {} + gb1988 92 tcl8 \U00000092 -1 {} {} + gb1988 92 replace \uFFFD -1 {} {} + gb1988 92 strict {} 0 {} {} + gb1988 93 tcl8 \U00000093 -1 {} {} + gb1988 93 replace \uFFFD -1 {} {} + gb1988 93 strict {} 0 {} {} + gb1988 94 tcl8 \U00000094 -1 {} {} + gb1988 94 replace \uFFFD -1 {} {} + gb1988 94 strict {} 0 {} {} + gb1988 95 tcl8 \U00000095 -1 {} {} + gb1988 95 replace \uFFFD -1 {} {} + gb1988 95 strict {} 0 {} {} + gb1988 96 tcl8 \U00000096 -1 {} {} + gb1988 96 replace \uFFFD -1 {} {} + gb1988 96 strict {} 0 {} {} + gb1988 97 tcl8 \U00000097 -1 {} {} + gb1988 97 replace \uFFFD -1 {} {} + gb1988 97 strict {} 0 {} {} + gb1988 98 tcl8 \U00000098 -1 {} {} + gb1988 98 replace \uFFFD -1 {} {} + gb1988 98 strict {} 0 {} {} + gb1988 99 tcl8 \U00000099 -1 {} {} + gb1988 99 replace \uFFFD -1 {} {} + gb1988 99 strict {} 0 {} {} + gb1988 9A tcl8 \U0000009A -1 {} {} + gb1988 9A replace \uFFFD -1 {} {} + gb1988 9A strict {} 0 {} {} + gb1988 9B tcl8 \U0000009B -1 {} {} + gb1988 9B replace \uFFFD -1 {} {} + gb1988 9B strict {} 0 {} {} + gb1988 9C tcl8 \U0000009C -1 {} {} + gb1988 9C replace \uFFFD -1 {} {} + gb1988 9C strict {} 0 {} {} + gb1988 9D tcl8 \U0000009D -1 {} {} + gb1988 9D replace \uFFFD -1 {} {} + gb1988 9D strict {} 0 {} {} + gb1988 9E tcl8 \U0000009E -1 {} {} + gb1988 9E replace \uFFFD -1 {} {} + gb1988 9E strict {} 0 {} {} + gb1988 9F tcl8 \U0000009F -1 {} {} + gb1988 9F replace \uFFFD -1 {} {} + gb1988 9F strict {} 0 {} {} + gb1988 A0 tcl8 \U000000A0 -1 {} {} + gb1988 A0 replace \uFFFD -1 {} {} + gb1988 A0 strict {} 0 {} {} + gb1988 A1 tcl8 \U000000A1 -1 {} {} + gb1988 A1 replace \uFFFD -1 {} {} + gb1988 A1 strict {} 0 {} {} + gb1988 A2 tcl8 \U000000A2 -1 {} {} + gb1988 A2 replace \uFFFD -1 {} {} + gb1988 A2 strict {} 0 {} {} + gb1988 A3 tcl8 \U000000A3 -1 {} {} + gb1988 A3 replace \uFFFD -1 {} {} + gb1988 A3 strict {} 0 {} {} + gb1988 A4 tcl8 \U000000A4 -1 {} {} + gb1988 A4 replace \uFFFD -1 {} {} + gb1988 A4 strict {} 0 {} {} + gb1988 A5 tcl8 \U000000A5 -1 {} {} + gb1988 A5 replace \uFFFD -1 {} {} + gb1988 A5 strict {} 0 {} {} + gb1988 A6 tcl8 \U000000A6 -1 {} {} + gb1988 A6 replace \uFFFD -1 {} {} + gb1988 A6 strict {} 0 {} {} + gb1988 A7 tcl8 \U000000A7 -1 {} {} + gb1988 A7 replace \uFFFD -1 {} {} + gb1988 A7 strict {} 0 {} {} + gb1988 A8 tcl8 \U000000A8 -1 {} {} + gb1988 A8 replace \uFFFD -1 {} {} + gb1988 A8 strict {} 0 {} {} + gb1988 A9 tcl8 \U000000A9 -1 {} {} + gb1988 A9 replace \uFFFD -1 {} {} + gb1988 A9 strict {} 0 {} {} + gb1988 AA tcl8 \U000000AA -1 {} {} + gb1988 AA replace \uFFFD -1 {} {} + gb1988 AA strict {} 0 {} {} + gb1988 AB tcl8 \U000000AB -1 {} {} + gb1988 AB replace \uFFFD -1 {} {} + gb1988 AB strict {} 0 {} {} + gb1988 AC tcl8 \U000000AC -1 {} {} + gb1988 AC replace \uFFFD -1 {} {} + gb1988 AC strict {} 0 {} {} + gb1988 AD tcl8 \U000000AD -1 {} {} + gb1988 AD replace \uFFFD -1 {} {} + gb1988 AD strict {} 0 {} {} + gb1988 AE tcl8 \U000000AE -1 {} {} + gb1988 AE replace \uFFFD -1 {} {} + gb1988 AE strict {} 0 {} {} + gb1988 AF tcl8 \U000000AF -1 {} {} + gb1988 AF replace \uFFFD -1 {} {} + gb1988 AF strict {} 0 {} {} + gb1988 B0 tcl8 \U000000B0 -1 {} {} + gb1988 B0 replace \uFFFD -1 {} {} + gb1988 B0 strict {} 0 {} {} + gb1988 B1 tcl8 \U000000B1 -1 {} {} + gb1988 B1 replace \uFFFD -1 {} {} + gb1988 B1 strict {} 0 {} {} + gb1988 B2 tcl8 \U000000B2 -1 {} {} + gb1988 B2 replace \uFFFD -1 {} {} + gb1988 B2 strict {} 0 {} {} + gb1988 B3 tcl8 \U000000B3 -1 {} {} + gb1988 B3 replace \uFFFD -1 {} {} + gb1988 B3 strict {} 0 {} {} + gb1988 B4 tcl8 \U000000B4 -1 {} {} + gb1988 B4 replace \uFFFD -1 {} {} + gb1988 B4 strict {} 0 {} {} + gb1988 B5 tcl8 \U000000B5 -1 {} {} + gb1988 B5 replace \uFFFD -1 {} {} + gb1988 B5 strict {} 0 {} {} + gb1988 B6 tcl8 \U000000B6 -1 {} {} + gb1988 B6 replace \uFFFD -1 {} {} + gb1988 B6 strict {} 0 {} {} + gb1988 B7 tcl8 \U000000B7 -1 {} {} + gb1988 B7 replace \uFFFD -1 {} {} + gb1988 B7 strict {} 0 {} {} + gb1988 B8 tcl8 \U000000B8 -1 {} {} + gb1988 B8 replace \uFFFD -1 {} {} + gb1988 B8 strict {} 0 {} {} + gb1988 B9 tcl8 \U000000B9 -1 {} {} + gb1988 B9 replace \uFFFD -1 {} {} + gb1988 B9 strict {} 0 {} {} + gb1988 BA tcl8 \U000000BA -1 {} {} + gb1988 BA replace \uFFFD -1 {} {} + gb1988 BA strict {} 0 {} {} + gb1988 BB tcl8 \U000000BB -1 {} {} + gb1988 BB replace \uFFFD -1 {} {} + gb1988 BB strict {} 0 {} {} + gb1988 BC tcl8 \U000000BC -1 {} {} + gb1988 BC replace \uFFFD -1 {} {} + gb1988 BC strict {} 0 {} {} + gb1988 BD tcl8 \U000000BD -1 {} {} + gb1988 BD replace \uFFFD -1 {} {} + gb1988 BD strict {} 0 {} {} + gb1988 BE tcl8 \U000000BE -1 {} {} + gb1988 BE replace \uFFFD -1 {} {} + gb1988 BE strict {} 0 {} {} + gb1988 BF tcl8 \U000000BF -1 {} {} + gb1988 BF replace \uFFFD -1 {} {} + gb1988 BF strict {} 0 {} {} + gb1988 C0 tcl8 \U000000C0 -1 {} {} + gb1988 C0 replace \uFFFD -1 {} {} + gb1988 C0 strict {} 0 {} {} + gb1988 C1 tcl8 \U000000C1 -1 {} {} + gb1988 C1 replace \uFFFD -1 {} {} + gb1988 C1 strict {} 0 {} {} + gb1988 C2 tcl8 \U000000C2 -1 {} {} + gb1988 C2 replace \uFFFD -1 {} {} + gb1988 C2 strict {} 0 {} {} + gb1988 C3 tcl8 \U000000C3 -1 {} {} + gb1988 C3 replace \uFFFD -1 {} {} + gb1988 C3 strict {} 0 {} {} + gb1988 C4 tcl8 \U000000C4 -1 {} {} + gb1988 C4 replace \uFFFD -1 {} {} + gb1988 C4 strict {} 0 {} {} + gb1988 C5 tcl8 \U000000C5 -1 {} {} + gb1988 C5 replace \uFFFD -1 {} {} + gb1988 C5 strict {} 0 {} {} + gb1988 C6 tcl8 \U000000C6 -1 {} {} + gb1988 C6 replace \uFFFD -1 {} {} + gb1988 C6 strict {} 0 {} {} + gb1988 C7 tcl8 \U000000C7 -1 {} {} + gb1988 C7 replace \uFFFD -1 {} {} + gb1988 C7 strict {} 0 {} {} + gb1988 C8 tcl8 \U000000C8 -1 {} {} + gb1988 C8 replace \uFFFD -1 {} {} + gb1988 C8 strict {} 0 {} {} + gb1988 C9 tcl8 \U000000C9 -1 {} {} + gb1988 C9 replace \uFFFD -1 {} {} + gb1988 C9 strict {} 0 {} {} + gb1988 CA tcl8 \U000000CA -1 {} {} + gb1988 CA replace \uFFFD -1 {} {} + gb1988 CA strict {} 0 {} {} + gb1988 CB tcl8 \U000000CB -1 {} {} + gb1988 CB replace \uFFFD -1 {} {} + gb1988 CB strict {} 0 {} {} + gb1988 CC tcl8 \U000000CC -1 {} {} + gb1988 CC replace \uFFFD -1 {} {} + gb1988 CC strict {} 0 {} {} + gb1988 CD tcl8 \U000000CD -1 {} {} + gb1988 CD replace \uFFFD -1 {} {} + gb1988 CD strict {} 0 {} {} + gb1988 CE tcl8 \U000000CE -1 {} {} + gb1988 CE replace \uFFFD -1 {} {} + gb1988 CE strict {} 0 {} {} + gb1988 CF tcl8 \U000000CF -1 {} {} + gb1988 CF replace \uFFFD -1 {} {} + gb1988 CF strict {} 0 {} {} + gb1988 D0 tcl8 \U000000D0 -1 {} {} + gb1988 D0 replace \uFFFD -1 {} {} + gb1988 D0 strict {} 0 {} {} + gb1988 D1 tcl8 \U000000D1 -1 {} {} + gb1988 D1 replace \uFFFD -1 {} {} + gb1988 D1 strict {} 0 {} {} + gb1988 D2 tcl8 \U000000D2 -1 {} {} + gb1988 D2 replace \uFFFD -1 {} {} + gb1988 D2 strict {} 0 {} {} + gb1988 D3 tcl8 \U000000D3 -1 {} {} + gb1988 D3 replace \uFFFD -1 {} {} + gb1988 D3 strict {} 0 {} {} + gb1988 D4 tcl8 \U000000D4 -1 {} {} + gb1988 D4 replace \uFFFD -1 {} {} + gb1988 D4 strict {} 0 {} {} + gb1988 D5 tcl8 \U000000D5 -1 {} {} + gb1988 D5 replace \uFFFD -1 {} {} + gb1988 D5 strict {} 0 {} {} + gb1988 D6 tcl8 \U000000D6 -1 {} {} + gb1988 D6 replace \uFFFD -1 {} {} + gb1988 D6 strict {} 0 {} {} + gb1988 D7 tcl8 \U000000D7 -1 {} {} + gb1988 D7 replace \uFFFD -1 {} {} + gb1988 D7 strict {} 0 {} {} + gb1988 D8 tcl8 \U000000D8 -1 {} {} + gb1988 D8 replace \uFFFD -1 {} {} + gb1988 D8 strict {} 0 {} {} + gb1988 D9 tcl8 \U000000D9 -1 {} {} + gb1988 D9 replace \uFFFD -1 {} {} + gb1988 D9 strict {} 0 {} {} + gb1988 DA tcl8 \U000000DA -1 {} {} + gb1988 DA replace \uFFFD -1 {} {} + gb1988 DA strict {} 0 {} {} + gb1988 DB tcl8 \U000000DB -1 {} {} + gb1988 DB replace \uFFFD -1 {} {} + gb1988 DB strict {} 0 {} {} + gb1988 DC tcl8 \U000000DC -1 {} {} + gb1988 DC replace \uFFFD -1 {} {} + gb1988 DC strict {} 0 {} {} + gb1988 DD tcl8 \U000000DD -1 {} {} + gb1988 DD replace \uFFFD -1 {} {} + gb1988 DD strict {} 0 {} {} + gb1988 DE tcl8 \U000000DE -1 {} {} + gb1988 DE replace \uFFFD -1 {} {} + gb1988 DE strict {} 0 {} {} + gb1988 DF tcl8 \U000000DF -1 {} {} + gb1988 DF replace \uFFFD -1 {} {} + gb1988 DF strict {} 0 {} {} + gb1988 E0 tcl8 \U000000E0 -1 {} {} + gb1988 E0 replace \uFFFD -1 {} {} + gb1988 E0 strict {} 0 {} {} + gb1988 E1 tcl8 \U000000E1 -1 {} {} + gb1988 E1 replace \uFFFD -1 {} {} + gb1988 E1 strict {} 0 {} {} + gb1988 E2 tcl8 \U000000E2 -1 {} {} + gb1988 E2 replace \uFFFD -1 {} {} + gb1988 E2 strict {} 0 {} {} + gb1988 E3 tcl8 \U000000E3 -1 {} {} + gb1988 E3 replace \uFFFD -1 {} {} + gb1988 E3 strict {} 0 {} {} + gb1988 E4 tcl8 \U000000E4 -1 {} {} + gb1988 E4 replace \uFFFD -1 {} {} + gb1988 E4 strict {} 0 {} {} + gb1988 E5 tcl8 \U000000E5 -1 {} {} + gb1988 E5 replace \uFFFD -1 {} {} + gb1988 E5 strict {} 0 {} {} + gb1988 E6 tcl8 \U000000E6 -1 {} {} + gb1988 E6 replace \uFFFD -1 {} {} + gb1988 E6 strict {} 0 {} {} + gb1988 E7 tcl8 \U000000E7 -1 {} {} + gb1988 E7 replace \uFFFD -1 {} {} + gb1988 E7 strict {} 0 {} {} + gb1988 E8 tcl8 \U000000E8 -1 {} {} + gb1988 E8 replace \uFFFD -1 {} {} + gb1988 E8 strict {} 0 {} {} + gb1988 E9 tcl8 \U000000E9 -1 {} {} + gb1988 E9 replace \uFFFD -1 {} {} + gb1988 E9 strict {} 0 {} {} + gb1988 EA tcl8 \U000000EA -1 {} {} + gb1988 EA replace \uFFFD -1 {} {} + gb1988 EA strict {} 0 {} {} + gb1988 EB tcl8 \U000000EB -1 {} {} + gb1988 EB replace \uFFFD -1 {} {} + gb1988 EB strict {} 0 {} {} + gb1988 EC tcl8 \U000000EC -1 {} {} + gb1988 EC replace \uFFFD -1 {} {} + gb1988 EC strict {} 0 {} {} + gb1988 ED tcl8 \U000000ED -1 {} {} + gb1988 ED replace \uFFFD -1 {} {} + gb1988 ED strict {} 0 {} {} + gb1988 EE tcl8 \U000000EE -1 {} {} + gb1988 EE replace \uFFFD -1 {} {} + gb1988 EE strict {} 0 {} {} + gb1988 EF tcl8 \U000000EF -1 {} {} + gb1988 EF replace \uFFFD -1 {} {} + gb1988 EF strict {} 0 {} {} + gb1988 F0 tcl8 \U000000F0 -1 {} {} + gb1988 F0 replace \uFFFD -1 {} {} + gb1988 F0 strict {} 0 {} {} + gb1988 F1 tcl8 \U000000F1 -1 {} {} + gb1988 F1 replace \uFFFD -1 {} {} + gb1988 F1 strict {} 0 {} {} + gb1988 F2 tcl8 \U000000F2 -1 {} {} + gb1988 F2 replace \uFFFD -1 {} {} + gb1988 F2 strict {} 0 {} {} + gb1988 F3 tcl8 \U000000F3 -1 {} {} + gb1988 F3 replace \uFFFD -1 {} {} + gb1988 F3 strict {} 0 {} {} + gb1988 F4 tcl8 \U000000F4 -1 {} {} + gb1988 F4 replace \uFFFD -1 {} {} + gb1988 F4 strict {} 0 {} {} + gb1988 F5 tcl8 \U000000F5 -1 {} {} + gb1988 F5 replace \uFFFD -1 {} {} + gb1988 F5 strict {} 0 {} {} + gb1988 F6 tcl8 \U000000F6 -1 {} {} + gb1988 F6 replace \uFFFD -1 {} {} + gb1988 F6 strict {} 0 {} {} + gb1988 F7 tcl8 \U000000F7 -1 {} {} + gb1988 F7 replace \uFFFD -1 {} {} + gb1988 F7 strict {} 0 {} {} + gb1988 F8 tcl8 \U000000F8 -1 {} {} + gb1988 F8 replace \uFFFD -1 {} {} + gb1988 F8 strict {} 0 {} {} + gb1988 F9 tcl8 \U000000F9 -1 {} {} + gb1988 F9 replace \uFFFD -1 {} {} + gb1988 F9 strict {} 0 {} {} + gb1988 FA tcl8 \U000000FA -1 {} {} + gb1988 FA replace \uFFFD -1 {} {} + gb1988 FA strict {} 0 {} {} + gb1988 FB tcl8 \U000000FB -1 {} {} + gb1988 FB replace \uFFFD -1 {} {} + gb1988 FB strict {} 0 {} {} + gb1988 FC tcl8 \U000000FC -1 {} {} + gb1988 FC replace \uFFFD -1 {} {} + gb1988 FC strict {} 0 {} {} + gb1988 FD tcl8 \U000000FD -1 {} {} + gb1988 FD replace \uFFFD -1 {} {} + gb1988 FD strict {} 0 {} {} + gb1988 FE tcl8 \U000000FE -1 {} {} + gb1988 FE replace \uFFFD -1 {} {} + gb1988 FE strict {} 0 {} {} + gb1988 FF tcl8 \U000000FF -1 {} {} + gb1988 FF replace \uFFFD -1 {} {} + gb1988 FF strict {} 0 {} {} +}; # gb1988 + +# gb1988 - invalid byte sequences +lappend encUnencodableStrings {*}{ + gb1988 \U00000024 tcl8 1A -1 {} {} + gb1988 \U00000024 replace 1A -1 {} {} + gb1988 \U00000024 strict {} 0 {} {} + gb1988 \U00000400 tcl8 1A -1 {} {} + gb1988 \U00000400 replace 1A -1 {} {} + gb1988 \U00000400 strict {} 0 {} {} + gb1988 \U0000D800 tcl8 1A -1 {} {} + gb1988 \U0000D800 replace 1A -1 {} {} + gb1988 \U0000D800 strict {} 0 {} {} + gb1988 \U0000DC00 tcl8 1A -1 {} {} + gb1988 \U0000DC00 replace 1A -1 {} {} + gb1988 \U0000DC00 strict {} 0 {} {} + gb1988 \U00010000 tcl8 1A -1 {} {} + gb1988 \U00010000 replace 1A -1 {} {} + gb1988 \U00010000 strict {} 0 {} {} + gb1988 \U0010FFFF tcl8 1A -1 {} {} + gb1988 \U0010FFFF replace 1A -1 {} {} + gb1988 \U0010FFFF strict {} 0 {} {} +}; # gb1988 + +# +# iso8859-1 (generated from glibc-ISO_8859_1-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-1 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-1 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D0 D0 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F0 F0 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 00FF FF} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-1 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-1 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D0 D0 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F0 F0 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 00FF FF} +} -result {} + +# iso8859-1 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # iso8859-1 + +# iso8859-1 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-1 \U00000400 tcl8 1A -1 {} {} + iso8859-1 \U00000400 replace 1A -1 {} {} + iso8859-1 \U00000400 strict {} 0 {} {} + iso8859-1 \U0000D800 tcl8 1A -1 {} {} + iso8859-1 \U0000D800 replace 1A -1 {} {} + iso8859-1 \U0000D800 strict {} 0 {} {} + iso8859-1 \U0000DC00 tcl8 1A -1 {} {} + iso8859-1 \U0000DC00 replace 1A -1 {} {} + iso8859-1 \U0000DC00 strict {} 0 {} {} + iso8859-1 \U00010000 tcl8 1A -1 {} {} + iso8859-1 \U00010000 replace 1A -1 {} {} + iso8859-1 \U00010000 strict {} 0 {} {} + iso8859-1 \U0010FFFF tcl8 1A -1 {} {} + iso8859-1 \U0010FFFF replace 1A -1 {} {} + iso8859-1 \U0010FFFF strict {} 0 {} {} +}; # iso8859-1 + +# +# iso8859-2 (generated from glibc-ISO_8859_2-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-2 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-2 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A4 A4 00A7 A7 00A8 A8 00AD AD 00B0 B0 00B4 B4 00B8 B8 00C1 C1 00C2 C2 00C4 C4 00C7 C7 00C9 C9 00CB CB 00CD CD 00CE CE 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00DA DA 00DC DC 00DD DD 00DF DF 00E1 E1 00E2 E2 00E4 E4 00E7 E7 00E9 E9 00EB EB 00ED ED 00EE EE 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00FA FA 00FC FC 00FD FD 0102 C3 0103 E3 0104 A1 0105 B1 0106 C6 0107 E6 010C C8 010D E8 010E CF 010F EF 0110 D0 0111 F0 0118 CA 0119 EA 011A CC 011B EC 0139 C5 013A E5 013D A5 013E B5 0141 A3 0142 B3 0143 D1 0144 F1 0147 D2 0148 F2 0150 D5 0151 F5 0154 C0 0155 E0 0158 D8 0159 F8 015A A6 015B B6 015E AA 015F BA 0160 A9 0161 B9 0162 DE 0163 FE 0164 AB 0165 BB 016E D9 016F F9 0170 DB 0171 FB 0179 AC 017A BC 017B AF 017C BF 017D AE 017E BE 02C7 B7 02D8 A2 02D9 FF 02DB B2 02DD BD} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-2 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-2 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A4 A4 00A7 A7 00A8 A8 00AD AD 00B0 B0 00B4 B4 00B8 B8 00C1 C1 00C2 C2 00C4 C4 00C7 C7 00C9 C9 00CB CB 00CD CD 00CE CE 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00DA DA 00DC DC 00DD DD 00DF DF 00E1 E1 00E2 E2 00E4 E4 00E7 E7 00E9 E9 00EB EB 00ED ED 00EE EE 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00FA FA 00FC FC 00FD FD 0102 C3 0103 E3 0104 A1 0105 B1 0106 C6 0107 E6 010C C8 010D E8 010E CF 010F EF 0110 D0 0111 F0 0118 CA 0119 EA 011A CC 011B EC 0139 C5 013A E5 013D A5 013E B5 0141 A3 0142 B3 0143 D1 0144 F1 0147 D2 0148 F2 0150 D5 0151 F5 0154 C0 0155 E0 0158 D8 0159 F8 015A A6 015B B6 015E AA 015F BA 0160 A9 0161 B9 0162 DE 0163 FE 0164 AB 0165 BB 016E D9 016F F9 0170 DB 0171 FB 0179 AC 017A BC 017B AF 017C BF 017D AE 017E BE 02C7 B7 02D8 A2 02D9 FF 02DB B2 02DD BD} +} -result {} + +# iso8859-2 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # iso8859-2 + +# iso8859-2 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-2 \U000000A1 tcl8 1A -1 {} {} + iso8859-2 \U000000A1 replace 1A -1 {} {} + iso8859-2 \U000000A1 strict {} 0 {} {} + iso8859-2 \U00000400 tcl8 1A -1 {} {} + iso8859-2 \U00000400 replace 1A -1 {} {} + iso8859-2 \U00000400 strict {} 0 {} {} + iso8859-2 \U0000D800 tcl8 1A -1 {} {} + iso8859-2 \U0000D800 replace 1A -1 {} {} + iso8859-2 \U0000D800 strict {} 0 {} {} + iso8859-2 \U0000DC00 tcl8 1A -1 {} {} + iso8859-2 \U0000DC00 replace 1A -1 {} {} + iso8859-2 \U0000DC00 strict {} 0 {} {} + iso8859-2 \U00010000 tcl8 1A -1 {} {} + iso8859-2 \U00010000 replace 1A -1 {} {} + iso8859-2 \U00010000 strict {} 0 {} {} + iso8859-2 \U0010FFFF tcl8 1A -1 {} {} + iso8859-2 \U0010FFFF replace 1A -1 {} {} + iso8859-2 \U0010FFFF strict {} 0 {} {} +}; # iso8859-2 + +# +# iso8859-3 (generated from glibc-ISO_8859_3-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-3 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-3 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A3 A3 00A4 A4 00A7 A7 00A8 A8 00AD AD 00B0 B0 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B7 B7 00B8 B8 00BD BD 00C0 C0 00C1 C1 00C2 C2 00C4 C4 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E4 E4 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00F9 F9 00FA FA 00FB FB 00FC FC 0108 C6 0109 E6 010A C5 010B E5 011C D8 011D F8 011E AB 011F BB 0120 D5 0121 F5 0124 A6 0125 B6 0126 A1 0127 B1 0130 A9 0131 B9 0134 AC 0135 BC 015C DE 015D FE 015E AA 015F BA 016C DD 016D FD 017B AF 017C BF 02D8 A2 02D9 FF} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-3 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-3 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A3 A3 00A4 A4 00A7 A7 00A8 A8 00AD AD 00B0 B0 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B7 B7 00B8 B8 00BD BD 00C0 C0 00C1 C1 00C2 C2 00C4 C4 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D6 D6 00D7 D7 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E4 E4 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F6 F6 00F7 F7 00F9 F9 00FA FA 00FB FB 00FC FC 0108 C6 0109 E6 010A C5 010B E5 011C D8 011D F8 011E AB 011F BB 0120 D5 0121 F5 0124 A6 0125 B6 0126 A1 0127 B1 0130 A9 0131 B9 0134 AC 0135 BC 015C DE 015D FE 015E AA 015F BA 016C DD 016D FD 017B AF 017C BF 02D8 A2 02D9 FF} +} -result {} + +# iso8859-3 - invalid byte sequences +lappend encInvalidBytes {*}{ + iso8859-3 A5 tcl8 \U000000A5 -1 {} {} + iso8859-3 A5 replace \uFFFD -1 {} {} + iso8859-3 A5 strict {} 0 {} {} + iso8859-3 AE tcl8 \U000000AE -1 {} {} + iso8859-3 AE replace \uFFFD -1 {} {} + iso8859-3 AE strict {} 0 {} {} + iso8859-3 BE tcl8 \U000000BE -1 {} {} + iso8859-3 BE replace \uFFFD -1 {} {} + iso8859-3 BE strict {} 0 {} {} + iso8859-3 C3 tcl8 \U000000C3 -1 {} {} + iso8859-3 C3 replace \uFFFD -1 {} {} + iso8859-3 C3 strict {} 0 {} {} + iso8859-3 D0 tcl8 \U000000D0 -1 {} {} + iso8859-3 D0 replace \uFFFD -1 {} {} + iso8859-3 D0 strict {} 0 {} {} + iso8859-3 E3 tcl8 \U000000E3 -1 {} {} + iso8859-3 E3 replace \uFFFD -1 {} {} + iso8859-3 E3 strict {} 0 {} {} + iso8859-3 F0 tcl8 \U000000F0 -1 {} {} + iso8859-3 F0 replace \uFFFD -1 {} {} + iso8859-3 F0 strict {} 0 {} {} +}; # iso8859-3 + +# iso8859-3 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-3 \U000000A1 tcl8 1A -1 {} {} + iso8859-3 \U000000A1 replace 1A -1 {} {} + iso8859-3 \U000000A1 strict {} 0 {} {} + iso8859-3 \U00000400 tcl8 1A -1 {} {} + iso8859-3 \U00000400 replace 1A -1 {} {} + iso8859-3 \U00000400 strict {} 0 {} {} + iso8859-3 \U0000D800 tcl8 1A -1 {} {} + iso8859-3 \U0000D800 replace 1A -1 {} {} + iso8859-3 \U0000D800 strict {} 0 {} {} + iso8859-3 \U0000DC00 tcl8 1A -1 {} {} + iso8859-3 \U0000DC00 replace 1A -1 {} {} + iso8859-3 \U0000DC00 strict {} 0 {} {} + iso8859-3 \U00010000 tcl8 1A -1 {} {} + iso8859-3 \U00010000 replace 1A -1 {} {} + iso8859-3 \U00010000 strict {} 0 {} {} + iso8859-3 \U0010FFFF tcl8 1A -1 {} {} + iso8859-3 \U0010FFFF replace 1A -1 {} {} + iso8859-3 \U0010FFFF strict {} 0 {} {} +}; # iso8859-3 + +# +# iso8859-4 (generated from glibc-ISO_8859_4-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-4 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-4 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A4 A4 00A7 A7 00A8 A8 00AD AD 00AF AF 00B0 B0 00B4 B4 00B8 B8 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C9 C9 00CB CB 00CD CD 00CE CE 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00DA DA 00DB DB 00DC DC 00DF DF 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E9 E9 00EB EB 00ED ED 00EE EE 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00FA FA 00FB FB 00FC FC 0100 C0 0101 E0 0104 A1 0105 B1 010C C8 010D E8 0110 D0 0111 F0 0112 AA 0113 BA 0116 CC 0117 EC 0118 CA 0119 EA 0122 AB 0123 BB 0128 A5 0129 B5 012A CF 012B EF 012E C7 012F E7 0136 D3 0137 F3 0138 A2 013B A6 013C B6 0145 D1 0146 F1 014A BD 014B BF 014C D2 014D F2 0156 A3 0157 B3 0160 A9 0161 B9 0166 AC 0167 BC 0168 DD 0169 FD 016A DE 016B FE 0172 D9 0173 F9 017D AE 017E BE 02C7 B7 02D9 FF 02DB B2} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-4 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-4 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A4 A4 00A7 A7 00A8 A8 00AD AD 00AF AF 00B0 B0 00B4 B4 00B8 B8 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C9 C9 00CB CB 00CD CD 00CE CE 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00DA DA 00DB DB 00DC DC 00DF DF 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E9 E9 00EB EB 00ED ED 00EE EE 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00FA FA 00FB FB 00FC FC 0100 C0 0101 E0 0104 A1 0105 B1 010C C8 010D E8 0110 D0 0111 F0 0112 AA 0113 BA 0116 CC 0117 EC 0118 CA 0119 EA 0122 AB 0123 BB 0128 A5 0129 B5 012A CF 012B EF 012E C7 012F E7 0136 D3 0137 F3 0138 A2 013B A6 013C B6 0145 D1 0146 F1 014A BD 014B BF 014C D2 014D F2 0156 A3 0157 B3 0160 A9 0161 B9 0166 AC 0167 BC 0168 DD 0169 FD 016A DE 016B FE 0172 D9 0173 F9 017D AE 017E BE 02C7 B7 02D9 FF 02DB B2} +} -result {} + +# iso8859-4 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # iso8859-4 + +# iso8859-4 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-4 \U000000A1 tcl8 1A -1 {} {} + iso8859-4 \U000000A1 replace 1A -1 {} {} + iso8859-4 \U000000A1 strict {} 0 {} {} + iso8859-4 \U00000400 tcl8 1A -1 {} {} + iso8859-4 \U00000400 replace 1A -1 {} {} + iso8859-4 \U00000400 strict {} 0 {} {} + iso8859-4 \U0000D800 tcl8 1A -1 {} {} + iso8859-4 \U0000D800 replace 1A -1 {} {} + iso8859-4 \U0000D800 strict {} 0 {} {} + iso8859-4 \U0000DC00 tcl8 1A -1 {} {} + iso8859-4 \U0000DC00 replace 1A -1 {} {} + iso8859-4 \U0000DC00 strict {} 0 {} {} + iso8859-4 \U00010000 tcl8 1A -1 {} {} + iso8859-4 \U00010000 replace 1A -1 {} {} + iso8859-4 \U00010000 strict {} 0 {} {} + iso8859-4 \U0010FFFF tcl8 1A -1 {} {} + iso8859-4 \U0010FFFF replace 1A -1 {} {} + iso8859-4 \U0010FFFF strict {} 0 {} {} +}; # iso8859-4 + +# +# iso8859-5 (generated from glibc-ISO_8859_5-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-5 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-5 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A7 FD 00AD AD 0401 A1 0402 A2 0403 A3 0404 A4 0405 A5 0406 A6 0407 A7 0408 A8 0409 A9 040A AA 040B AB 040C AC 040E AE 040F AF 0410 B0 0411 B1 0412 B2 0413 B3 0414 B4 0415 B5 0416 B6 0417 B7 0418 B8 0419 B9 041A BA 041B BB 041C BC 041D BD 041E BE 041F BF 0420 C0 0421 C1 0422 C2 0423 C3 0424 C4 0425 C5 0426 C6 0427 C7 0428 C8 0429 C9 042A CA 042B CB 042C CC 042D CD 042E CE 042F CF 0430 D0 0431 D1 0432 D2 0433 D3 0434 D4 0435 D5 0436 D6 0437 D7 0438 D8 0439 D9 043A DA 043B DB 043C DC 043D DD 043E DE 043F DF 0440 E0 0441 E1 0442 E2 0443 E3 0444 E4 0445 E5 0446 E6 0447 E7 0448 E8 0449 E9 044A EA 044B EB 044C EC 044D ED 044E EE 044F EF 0451 F1 0452 F2 0453 F3 0454 F4 0455 F5 0456 F6 0457 F7 0458 F8 0459 F9 045A FA 045B FB 045C FC 045E FE 045F FF 2116 F0} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-5 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-5 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A7 FD 00AD AD 0401 A1 0402 A2 0403 A3 0404 A4 0405 A5 0406 A6 0407 A7 0408 A8 0409 A9 040A AA 040B AB 040C AC 040E AE 040F AF 0410 B0 0411 B1 0412 B2 0413 B3 0414 B4 0415 B5 0416 B6 0417 B7 0418 B8 0419 B9 041A BA 041B BB 041C BC 041D BD 041E BE 041F BF 0420 C0 0421 C1 0422 C2 0423 C3 0424 C4 0425 C5 0426 C6 0427 C7 0428 C8 0429 C9 042A CA 042B CB 042C CC 042D CD 042E CE 042F CF 0430 D0 0431 D1 0432 D2 0433 D3 0434 D4 0435 D5 0436 D6 0437 D7 0438 D8 0439 D9 043A DA 043B DB 043C DC 043D DD 043E DE 043F DF 0440 E0 0441 E1 0442 E2 0443 E3 0444 E4 0445 E5 0446 E6 0447 E7 0448 E8 0449 E9 044A EA 044B EB 044C EC 044D ED 044E EE 044F EF 0451 F1 0452 F2 0453 F3 0454 F4 0455 F5 0456 F6 0457 F7 0458 F8 0459 F9 045A FA 045B FB 045C FC 045E FE 045F FF 2116 F0} +} -result {} + +# iso8859-5 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # iso8859-5 + +# iso8859-5 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-5 \U000000A1 tcl8 1A -1 {} {} + iso8859-5 \U000000A1 replace 1A -1 {} {} + iso8859-5 \U000000A1 strict {} 0 {} {} + iso8859-5 \U00000400 tcl8 1A -1 {} {} + iso8859-5 \U00000400 replace 1A -1 {} {} + iso8859-5 \U00000400 strict {} 0 {} {} + iso8859-5 \U0000D800 tcl8 1A -1 {} {} + iso8859-5 \U0000D800 replace 1A -1 {} {} + iso8859-5 \U0000D800 strict {} 0 {} {} + iso8859-5 \U0000DC00 tcl8 1A -1 {} {} + iso8859-5 \U0000DC00 replace 1A -1 {} {} + iso8859-5 \U0000DC00 strict {} 0 {} {} + iso8859-5 \U00010000 tcl8 1A -1 {} {} + iso8859-5 \U00010000 replace 1A -1 {} {} + iso8859-5 \U00010000 strict {} 0 {} {} + iso8859-5 \U0010FFFF tcl8 1A -1 {} {} + iso8859-5 \U0010FFFF replace 1A -1 {} {} + iso8859-5 \U0010FFFF strict {} 0 {} {} +}; # iso8859-5 + +# +# iso8859-6 (generated from glibc-ISO_8859_6-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-6 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-6 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A4 A4 00AD AD 060C AC 061B BB 061F BF 0621 C1 0622 C2 0623 C3 0624 C4 0625 C5 0626 C6 0627 C7 0628 C8 0629 C9 062A CA 062B CB 062C CC 062D CD 062E CE 062F CF 0630 D0 0631 D1 0632 D2 0633 D3 0634 D4 0635 D5 0636 D6 0637 D7 0638 D8 0639 D9 063A DA 0640 E0 0641 E1 0642 E2 0643 E3 0644 E4 0645 E5 0646 E6 0647 E7 0648 E8 0649 E9 064A EA 064B EB 064C EC 064D ED 064E EE 064F EF 0650 F0 0651 F1 0652 F2} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-6 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-6 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A4 A4 00AD AD 060C AC 061B BB 061F BF 0621 C1 0622 C2 0623 C3 0624 C4 0625 C5 0626 C6 0627 C7 0628 C8 0629 C9 062A CA 062B CB 062C CC 062D CD 062E CE 062F CF 0630 D0 0631 D1 0632 D2 0633 D3 0634 D4 0635 D5 0636 D6 0637 D7 0638 D8 0639 D9 063A DA 0640 E0 0641 E1 0642 E2 0643 E3 0644 E4 0645 E5 0646 E6 0647 E7 0648 E8 0649 E9 064A EA 064B EB 064C EC 064D ED 064E EE 064F EF 0650 F0 0651 F1 0652 F2} +} -result {} + +# iso8859-6 - invalid byte sequences +lappend encInvalidBytes {*}{ + iso8859-6 A1 tcl8 \U000000A1 -1 {} {} + iso8859-6 A1 replace \uFFFD -1 {} {} + iso8859-6 A1 strict {} 0 {} {} + iso8859-6 A2 tcl8 \U000000A2 -1 {} {} + iso8859-6 A2 replace \uFFFD -1 {} {} + iso8859-6 A2 strict {} 0 {} {} + iso8859-6 A3 tcl8 \U000000A3 -1 {} {} + iso8859-6 A3 replace \uFFFD -1 {} {} + iso8859-6 A3 strict {} 0 {} {} + iso8859-6 A5 tcl8 \U000000A5 -1 {} {} + iso8859-6 A5 replace \uFFFD -1 {} {} + iso8859-6 A5 strict {} 0 {} {} + iso8859-6 A6 tcl8 \U000000A6 -1 {} {} + iso8859-6 A6 replace \uFFFD -1 {} {} + iso8859-6 A6 strict {} 0 {} {} + iso8859-6 A7 tcl8 \U000000A7 -1 {} {} + iso8859-6 A7 replace \uFFFD -1 {} {} + iso8859-6 A7 strict {} 0 {} {} + iso8859-6 A8 tcl8 \U000000A8 -1 {} {} + iso8859-6 A8 replace \uFFFD -1 {} {} + iso8859-6 A8 strict {} 0 {} {} + iso8859-6 A9 tcl8 \U000000A9 -1 {} {} + iso8859-6 A9 replace \uFFFD -1 {} {} + iso8859-6 A9 strict {} 0 {} {} + iso8859-6 AA tcl8 \U000000AA -1 {} {} + iso8859-6 AA replace \uFFFD -1 {} {} + iso8859-6 AA strict {} 0 {} {} + iso8859-6 AB tcl8 \U000000AB -1 {} {} + iso8859-6 AB replace \uFFFD -1 {} {} + iso8859-6 AB strict {} 0 {} {} + iso8859-6 AE tcl8 \U000000AE -1 {} {} + iso8859-6 AE replace \uFFFD -1 {} {} + iso8859-6 AE strict {} 0 {} {} + iso8859-6 AF tcl8 \U000000AF -1 {} {} + iso8859-6 AF replace \uFFFD -1 {} {} + iso8859-6 AF strict {} 0 {} {} + iso8859-6 B0 tcl8 \U000000B0 -1 {} {} + iso8859-6 B0 replace \uFFFD -1 {} {} + iso8859-6 B0 strict {} 0 {} {} + iso8859-6 B1 tcl8 \U000000B1 -1 {} {} + iso8859-6 B1 replace \uFFFD -1 {} {} + iso8859-6 B1 strict {} 0 {} {} + iso8859-6 B2 tcl8 \U000000B2 -1 {} {} + iso8859-6 B2 replace \uFFFD -1 {} {} + iso8859-6 B2 strict {} 0 {} {} + iso8859-6 B3 tcl8 \U000000B3 -1 {} {} + iso8859-6 B3 replace \uFFFD -1 {} {} + iso8859-6 B3 strict {} 0 {} {} + iso8859-6 B4 tcl8 \U000000B4 -1 {} {} + iso8859-6 B4 replace \uFFFD -1 {} {} + iso8859-6 B4 strict {} 0 {} {} + iso8859-6 B5 tcl8 \U000000B5 -1 {} {} + iso8859-6 B5 replace \uFFFD -1 {} {} + iso8859-6 B5 strict {} 0 {} {} + iso8859-6 B6 tcl8 \U000000B6 -1 {} {} + iso8859-6 B6 replace \uFFFD -1 {} {} + iso8859-6 B6 strict {} 0 {} {} + iso8859-6 B7 tcl8 \U000000B7 -1 {} {} + iso8859-6 B7 replace \uFFFD -1 {} {} + iso8859-6 B7 strict {} 0 {} {} + iso8859-6 B8 tcl8 \U000000B8 -1 {} {} + iso8859-6 B8 replace \uFFFD -1 {} {} + iso8859-6 B8 strict {} 0 {} {} + iso8859-6 B9 tcl8 \U000000B9 -1 {} {} + iso8859-6 B9 replace \uFFFD -1 {} {} + iso8859-6 B9 strict {} 0 {} {} + iso8859-6 BA tcl8 \U000000BA -1 {} {} + iso8859-6 BA replace \uFFFD -1 {} {} + iso8859-6 BA strict {} 0 {} {} + iso8859-6 BC tcl8 \U000000BC -1 {} {} + iso8859-6 BC replace \uFFFD -1 {} {} + iso8859-6 BC strict {} 0 {} {} + iso8859-6 BD tcl8 \U000000BD -1 {} {} + iso8859-6 BD replace \uFFFD -1 {} {} + iso8859-6 BD strict {} 0 {} {} + iso8859-6 BE tcl8 \U000000BE -1 {} {} + iso8859-6 BE replace \uFFFD -1 {} {} + iso8859-6 BE strict {} 0 {} {} + iso8859-6 C0 tcl8 \U000000C0 -1 {} {} + iso8859-6 C0 replace \uFFFD -1 {} {} + iso8859-6 C0 strict {} 0 {} {} + iso8859-6 DB tcl8 \U000000DB -1 {} {} + iso8859-6 DB replace \uFFFD -1 {} {} + iso8859-6 DB strict {} 0 {} {} + iso8859-6 DC tcl8 \U000000DC -1 {} {} + iso8859-6 DC replace \uFFFD -1 {} {} + iso8859-6 DC strict {} 0 {} {} + iso8859-6 DD tcl8 \U000000DD -1 {} {} + iso8859-6 DD replace \uFFFD -1 {} {} + iso8859-6 DD strict {} 0 {} {} + iso8859-6 DE tcl8 \U000000DE -1 {} {} + iso8859-6 DE replace \uFFFD -1 {} {} + iso8859-6 DE strict {} 0 {} {} + iso8859-6 DF tcl8 \U000000DF -1 {} {} + iso8859-6 DF replace \uFFFD -1 {} {} + iso8859-6 DF strict {} 0 {} {} + iso8859-6 F3 tcl8 \U000000F3 -1 {} {} + iso8859-6 F3 replace \uFFFD -1 {} {} + iso8859-6 F3 strict {} 0 {} {} + iso8859-6 F4 tcl8 \U000000F4 -1 {} {} + iso8859-6 F4 replace \uFFFD -1 {} {} + iso8859-6 F4 strict {} 0 {} {} + iso8859-6 F5 tcl8 \U000000F5 -1 {} {} + iso8859-6 F5 replace \uFFFD -1 {} {} + iso8859-6 F5 strict {} 0 {} {} + iso8859-6 F6 tcl8 \U000000F6 -1 {} {} + iso8859-6 F6 replace \uFFFD -1 {} {} + iso8859-6 F6 strict {} 0 {} {} + iso8859-6 F7 tcl8 \U000000F7 -1 {} {} + iso8859-6 F7 replace \uFFFD -1 {} {} + iso8859-6 F7 strict {} 0 {} {} + iso8859-6 F8 tcl8 \U000000F8 -1 {} {} + iso8859-6 F8 replace \uFFFD -1 {} {} + iso8859-6 F8 strict {} 0 {} {} + iso8859-6 F9 tcl8 \U000000F9 -1 {} {} + iso8859-6 F9 replace \uFFFD -1 {} {} + iso8859-6 F9 strict {} 0 {} {} + iso8859-6 FA tcl8 \U000000FA -1 {} {} + iso8859-6 FA replace \uFFFD -1 {} {} + iso8859-6 FA strict {} 0 {} {} + iso8859-6 FB tcl8 \U000000FB -1 {} {} + iso8859-6 FB replace \uFFFD -1 {} {} + iso8859-6 FB strict {} 0 {} {} + iso8859-6 FC tcl8 \U000000FC -1 {} {} + iso8859-6 FC replace \uFFFD -1 {} {} + iso8859-6 FC strict {} 0 {} {} + iso8859-6 FD tcl8 \U000000FD -1 {} {} + iso8859-6 FD replace \uFFFD -1 {} {} + iso8859-6 FD strict {} 0 {} {} + iso8859-6 FE tcl8 \U000000FE -1 {} {} + iso8859-6 FE replace \uFFFD -1 {} {} + iso8859-6 FE strict {} 0 {} {} + iso8859-6 FF tcl8 \U000000FF -1 {} {} + iso8859-6 FF replace \uFFFD -1 {} {} + iso8859-6 FF strict {} 0 {} {} +}; # iso8859-6 + +# iso8859-6 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-6 \U000000A1 tcl8 1A -1 {} {} + iso8859-6 \U000000A1 replace 1A -1 {} {} + iso8859-6 \U000000A1 strict {} 0 {} {} + iso8859-6 \U00000400 tcl8 1A -1 {} {} + iso8859-6 \U00000400 replace 1A -1 {} {} + iso8859-6 \U00000400 strict {} 0 {} {} + iso8859-6 \U0000D800 tcl8 1A -1 {} {} + iso8859-6 \U0000D800 replace 1A -1 {} {} + iso8859-6 \U0000D800 strict {} 0 {} {} + iso8859-6 \U0000DC00 tcl8 1A -1 {} {} + iso8859-6 \U0000DC00 replace 1A -1 {} {} + iso8859-6 \U0000DC00 strict {} 0 {} {} + iso8859-6 \U00010000 tcl8 1A -1 {} {} + iso8859-6 \U00010000 replace 1A -1 {} {} + iso8859-6 \U00010000 strict {} 0 {} {} + iso8859-6 \U0010FFFF tcl8 1A -1 {} {} + iso8859-6 \U0010FFFF replace 1A -1 {} {} + iso8859-6 \U0010FFFF strict {} 0 {} {} +}; # iso8859-6 + +# +# iso8859-7 (generated from glibc-ISO_8859_7-2.3.3) + +test encoding-convertfrom-ucmCompare-iso8859-7 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-7 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A3 A3 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B7 B7 00BB BB 00BD BD 037A AA 0384 B4 0385 B5 0386 B6 0388 B8 0389 B9 038A BA 038C BC 038E BE 038F BF 0390 C0 0391 C1 0392 C2 0393 C3 0394 C4 0395 C5 0396 C6 0397 C7 0398 C8 0399 C9 039A CA 039B CB 039C CC 039D CD 039E CE 039F CF 03A0 D0 03A1 D1 03A3 D3 03A4 D4 03A5 D5 03A6 D6 03A7 D7 03A8 D8 03A9 D9 03AA DA 03AB DB 03AC DC 03AD DD 03AE DE 03AF DF 03B0 E0 03B1 E1 03B2 E2 03B3 E3 03B4 E4 03B5 E5 03B6 E6 03B7 E7 03B8 E8 03B9 E9 03BA EA 03BB EB 03BC EC 03BD ED 03BE EE 03BF EF 03C0 F0 03C1 F1 03C2 F2 03C3 F3 03C4 F4 03C5 F5 03C6 F6 03C7 F7 03C8 F8 03C9 F9 03CA FA 03CB FB 03CC FC 03CD FD 03CE FE 2015 AF 2018 A1 2019 A2 20AC A4 20AF A5} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-7 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-7 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A3 A3 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B7 B7 00BB BB 00BD BD 037A AA 0384 B4 0385 B5 0386 B6 0388 B8 0389 B9 038A BA 038C BC 038E BE 038F BF 0390 C0 0391 C1 0392 C2 0393 C3 0394 C4 0395 C5 0396 C6 0397 C7 0398 C8 0399 C9 039A CA 039B CB 039C CC 039D CD 039E CE 039F CF 03A0 D0 03A1 D1 03A3 D3 03A4 D4 03A5 D5 03A6 D6 03A7 D7 03A8 D8 03A9 D9 03AA DA 03AB DB 03AC DC 03AD DD 03AE DE 03AF DF 03B0 E0 03B1 E1 03B2 E2 03B3 E3 03B4 E4 03B5 E5 03B6 E6 03B7 E7 03B8 E8 03B9 E9 03BA EA 03BB EB 03BC EC 03BD ED 03BE EE 03BF EF 03C0 F0 03C1 F1 03C2 F2 03C3 F3 03C4 F4 03C5 F5 03C6 F6 03C7 F7 03C8 F8 03C9 F9 03CA FA 03CB FB 03CC FC 03CD FD 03CE FE 2015 AF 2018 A1 2019 A2 20AC A4 20AF A5} +} -result {} + +# iso8859-7 - invalid byte sequences +lappend encInvalidBytes {*}{ + iso8859-7 AE tcl8 \U000000AE -1 {} {} + iso8859-7 AE replace \uFFFD -1 {} {} + iso8859-7 AE strict {} 0 {} {} + iso8859-7 D2 tcl8 \U000000D2 -1 {} {} + iso8859-7 D2 replace \uFFFD -1 {} {} + iso8859-7 D2 strict {} 0 {} {} + iso8859-7 FF tcl8 \U000000FF -1 {} {} + iso8859-7 FF replace \uFFFD -1 {} {} + iso8859-7 FF strict {} 0 {} {} +}; # iso8859-7 + +# iso8859-7 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-7 \U000000A1 tcl8 1A -1 {} {} + iso8859-7 \U000000A1 replace 1A -1 {} {} + iso8859-7 \U000000A1 strict {} 0 {} {} + iso8859-7 \U00000400 tcl8 1A -1 {} {} + iso8859-7 \U00000400 replace 1A -1 {} {} + iso8859-7 \U00000400 strict {} 0 {} {} + iso8859-7 \U0000D800 tcl8 1A -1 {} {} + iso8859-7 \U0000D800 replace 1A -1 {} {} + iso8859-7 \U0000D800 strict {} 0 {} {} + iso8859-7 \U0000DC00 tcl8 1A -1 {} {} + iso8859-7 \U0000DC00 replace 1A -1 {} {} + iso8859-7 \U0000DC00 strict {} 0 {} {} + iso8859-7 \U00010000 tcl8 1A -1 {} {} + iso8859-7 \U00010000 replace 1A -1 {} {} + iso8859-7 \U00010000 strict {} 0 {} {} + iso8859-7 \U0010FFFF tcl8 1A -1 {} {} + iso8859-7 \U0010FFFF replace 1A -1 {} {} + iso8859-7 \U0010FFFF strict {} 0 {} {} +}; # iso8859-7 + +# +# iso8859-8 (generated from glibc-ISO_8859_8-2.3.3) + +test encoding-convertfrom-ucmCompare-iso8859-8 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-8 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00D7 AA 00F7 BA 05D0 E0 05D1 E1 05D2 E2 05D3 E3 05D4 E4 05D5 E5 05D6 E6 05D7 E7 05D8 E8 05D9 E9 05DA EA 05DB EB 05DC EC 05DD ED 05DE EE 05DF EF 05E0 F0 05E1 F1 05E2 F2 05E3 F3 05E4 F4 05E5 F5 05E6 F6 05E7 F7 05E8 F8 05E9 F9 05EA FA 200E FD 200F FE 2017 DF} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-8 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-8 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00D7 AA 00F7 BA 05D0 E0 05D1 E1 05D2 E2 05D3 E3 05D4 E4 05D5 E5 05D6 E6 05D7 E7 05D8 E8 05D9 E9 05DA EA 05DB EB 05DC EC 05DD ED 05DE EE 05DF EF 05E0 F0 05E1 F1 05E2 F2 05E3 F3 05E4 F4 05E5 F5 05E6 F6 05E7 F7 05E8 F8 05E9 F9 05EA FA 200E FD 200F FE 2017 DF} +} -result {} + +# iso8859-8 - invalid byte sequences +lappend encInvalidBytes {*}{ + iso8859-8 A1 tcl8 \U000000A1 -1 {} {} + iso8859-8 A1 replace \uFFFD -1 {} {} + iso8859-8 A1 strict {} 0 {} {} + iso8859-8 BF tcl8 \U000000BF -1 {} {} + iso8859-8 BF replace \uFFFD -1 {} {} + iso8859-8 BF strict {} 0 {} {} + iso8859-8 C0 tcl8 \U000000C0 -1 {} {} + iso8859-8 C0 replace \uFFFD -1 {} {} + iso8859-8 C0 strict {} 0 {} {} + iso8859-8 C1 tcl8 \U000000C1 -1 {} {} + iso8859-8 C1 replace \uFFFD -1 {} {} + iso8859-8 C1 strict {} 0 {} {} + iso8859-8 C2 tcl8 \U000000C2 -1 {} {} + iso8859-8 C2 replace \uFFFD -1 {} {} + iso8859-8 C2 strict {} 0 {} {} + iso8859-8 C3 tcl8 \U000000C3 -1 {} {} + iso8859-8 C3 replace \uFFFD -1 {} {} + iso8859-8 C3 strict {} 0 {} {} + iso8859-8 C4 tcl8 \U000000C4 -1 {} {} + iso8859-8 C4 replace \uFFFD -1 {} {} + iso8859-8 C4 strict {} 0 {} {} + iso8859-8 C5 tcl8 \U000000C5 -1 {} {} + iso8859-8 C5 replace \uFFFD -1 {} {} + iso8859-8 C5 strict {} 0 {} {} + iso8859-8 C6 tcl8 \U000000C6 -1 {} {} + iso8859-8 C6 replace \uFFFD -1 {} {} + iso8859-8 C6 strict {} 0 {} {} + iso8859-8 C7 tcl8 \U000000C7 -1 {} {} + iso8859-8 C7 replace \uFFFD -1 {} {} + iso8859-8 C7 strict {} 0 {} {} + iso8859-8 C8 tcl8 \U000000C8 -1 {} {} + iso8859-8 C8 replace \uFFFD -1 {} {} + iso8859-8 C8 strict {} 0 {} {} + iso8859-8 C9 tcl8 \U000000C9 -1 {} {} + iso8859-8 C9 replace \uFFFD -1 {} {} + iso8859-8 C9 strict {} 0 {} {} + iso8859-8 CA tcl8 \U000000CA -1 {} {} + iso8859-8 CA replace \uFFFD -1 {} {} + iso8859-8 CA strict {} 0 {} {} + iso8859-8 CB tcl8 \U000000CB -1 {} {} + iso8859-8 CB replace \uFFFD -1 {} {} + iso8859-8 CB strict {} 0 {} {} + iso8859-8 CC tcl8 \U000000CC -1 {} {} + iso8859-8 CC replace \uFFFD -1 {} {} + iso8859-8 CC strict {} 0 {} {} + iso8859-8 CD tcl8 \U000000CD -1 {} {} + iso8859-8 CD replace \uFFFD -1 {} {} + iso8859-8 CD strict {} 0 {} {} + iso8859-8 CE tcl8 \U000000CE -1 {} {} + iso8859-8 CE replace \uFFFD -1 {} {} + iso8859-8 CE strict {} 0 {} {} + iso8859-8 CF tcl8 \U000000CF -1 {} {} + iso8859-8 CF replace \uFFFD -1 {} {} + iso8859-8 CF strict {} 0 {} {} + iso8859-8 D0 tcl8 \U000000D0 -1 {} {} + iso8859-8 D0 replace \uFFFD -1 {} {} + iso8859-8 D0 strict {} 0 {} {} + iso8859-8 D1 tcl8 \U000000D1 -1 {} {} + iso8859-8 D1 replace \uFFFD -1 {} {} + iso8859-8 D1 strict {} 0 {} {} + iso8859-8 D2 tcl8 \U000000D2 -1 {} {} + iso8859-8 D2 replace \uFFFD -1 {} {} + iso8859-8 D2 strict {} 0 {} {} + iso8859-8 D3 tcl8 \U000000D3 -1 {} {} + iso8859-8 D3 replace \uFFFD -1 {} {} + iso8859-8 D3 strict {} 0 {} {} + iso8859-8 D4 tcl8 \U000000D4 -1 {} {} + iso8859-8 D4 replace \uFFFD -1 {} {} + iso8859-8 D4 strict {} 0 {} {} + iso8859-8 D5 tcl8 \U000000D5 -1 {} {} + iso8859-8 D5 replace \uFFFD -1 {} {} + iso8859-8 D5 strict {} 0 {} {} + iso8859-8 D6 tcl8 \U000000D6 -1 {} {} + iso8859-8 D6 replace \uFFFD -1 {} {} + iso8859-8 D6 strict {} 0 {} {} + iso8859-8 D7 tcl8 \U000000D7 -1 {} {} + iso8859-8 D7 replace \uFFFD -1 {} {} + iso8859-8 D7 strict {} 0 {} {} + iso8859-8 D8 tcl8 \U000000D8 -1 {} {} + iso8859-8 D8 replace \uFFFD -1 {} {} + iso8859-8 D8 strict {} 0 {} {} + iso8859-8 D9 tcl8 \U000000D9 -1 {} {} + iso8859-8 D9 replace \uFFFD -1 {} {} + iso8859-8 D9 strict {} 0 {} {} + iso8859-8 DA tcl8 \U000000DA -1 {} {} + iso8859-8 DA replace \uFFFD -1 {} {} + iso8859-8 DA strict {} 0 {} {} + iso8859-8 DB tcl8 \U000000DB -1 {} {} + iso8859-8 DB replace \uFFFD -1 {} {} + iso8859-8 DB strict {} 0 {} {} + iso8859-8 DC tcl8 \U000000DC -1 {} {} + iso8859-8 DC replace \uFFFD -1 {} {} + iso8859-8 DC strict {} 0 {} {} + iso8859-8 DD tcl8 \U000000DD -1 {} {} + iso8859-8 DD replace \uFFFD -1 {} {} + iso8859-8 DD strict {} 0 {} {} + iso8859-8 DE tcl8 \U000000DE -1 {} {} + iso8859-8 DE replace \uFFFD -1 {} {} + iso8859-8 DE strict {} 0 {} {} + iso8859-8 FB tcl8 \U000000FB -1 {} {} + iso8859-8 FB replace \uFFFD -1 {} {} + iso8859-8 FB strict {} 0 {} {} + iso8859-8 FC tcl8 \U000000FC -1 {} {} + iso8859-8 FC replace \uFFFD -1 {} {} + iso8859-8 FC strict {} 0 {} {} + iso8859-8 FF tcl8 \U000000FF -1 {} {} + iso8859-8 FF replace \uFFFD -1 {} {} + iso8859-8 FF strict {} 0 {} {} +}; # iso8859-8 + +# iso8859-8 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-8 \U000000A1 tcl8 1A -1 {} {} + iso8859-8 \U000000A1 replace 1A -1 {} {} + iso8859-8 \U000000A1 strict {} 0 {} {} + iso8859-8 \U00000400 tcl8 1A -1 {} {} + iso8859-8 \U00000400 replace 1A -1 {} {} + iso8859-8 \U00000400 strict {} 0 {} {} + iso8859-8 \U0000D800 tcl8 1A -1 {} {} + iso8859-8 \U0000D800 replace 1A -1 {} {} + iso8859-8 \U0000D800 strict {} 0 {} {} + iso8859-8 \U0000DC00 tcl8 1A -1 {} {} + iso8859-8 \U0000DC00 replace 1A -1 {} {} + iso8859-8 \U0000DC00 strict {} 0 {} {} + iso8859-8 \U00010000 tcl8 1A -1 {} {} + iso8859-8 \U00010000 replace 1A -1 {} {} + iso8859-8 \U00010000 strict {} 0 {} {} + iso8859-8 \U0010FFFF tcl8 1A -1 {} {} + iso8859-8 \U0010FFFF replace 1A -1 {} {} + iso8859-8 \U0010FFFF strict {} 0 {} {} +}; # iso8859-8 + +# +# iso8859-9 (generated from glibc-ISO_8859_9-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-9 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-9 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 011E D0 011F F0 0130 DD 0131 FD 015E DE 015F FE} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-9 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-9 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A4 A4 00A5 A5 00A6 A6 00A7 A7 00A8 A8 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B4 B4 00B5 B5 00B6 B6 00B7 B7 00B8 B8 00B9 B9 00BA BA 00BB BB 00BC BC 00BD BD 00BE BE 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 011E D0 011F F0 0130 DD 0131 FD 015E DE 015F FE} +} -result {} + +# iso8859-9 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # iso8859-9 + +# iso8859-9 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-9 \U000000D0 tcl8 1A -1 {} {} + iso8859-9 \U000000D0 replace 1A -1 {} {} + iso8859-9 \U000000D0 strict {} 0 {} {} + iso8859-9 \U00000400 tcl8 1A -1 {} {} + iso8859-9 \U00000400 replace 1A -1 {} {} + iso8859-9 \U00000400 strict {} 0 {} {} + iso8859-9 \U0000D800 tcl8 1A -1 {} {} + iso8859-9 \U0000D800 replace 1A -1 {} {} + iso8859-9 \U0000D800 strict {} 0 {} {} + iso8859-9 \U0000DC00 tcl8 1A -1 {} {} + iso8859-9 \U0000DC00 replace 1A -1 {} {} + iso8859-9 \U0000DC00 strict {} 0 {} {} + iso8859-9 \U00010000 tcl8 1A -1 {} {} + iso8859-9 \U00010000 replace 1A -1 {} {} + iso8859-9 \U00010000 strict {} 0 {} {} + iso8859-9 \U0010FFFF tcl8 1A -1 {} {} + iso8859-9 \U0010FFFF replace 1A -1 {} {} + iso8859-9 \U0010FFFF strict {} 0 {} {} +}; # iso8859-9 + +# +# iso8859-10 (generated from glibc-ISO_8859_10-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-10 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-10 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A7 A7 00AD AD 00B0 B0 00B7 B7 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C9 C9 00CB CB 00CD CD 00CE CE 00CF CF 00D0 D0 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D8 D8 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E9 E9 00EB EB 00ED ED 00EE EE 00EF EF 00F0 F0 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F8 F8 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 0100 C0 0101 E0 0104 A1 0105 B1 010C C8 010D E8 0110 A9 0111 B9 0112 A2 0113 B2 0116 CC 0117 EC 0118 CA 0119 EA 0122 A3 0123 B3 0128 A5 0129 B5 012A A4 012B B4 012E C7 012F E7 0136 A6 0137 B6 0138 FF 013B A8 013C B8 0145 D1 0146 F1 014A AF 014B BF 014C D2 014D F2 0160 AA 0161 BA 0166 AB 0167 BB 0168 D7 0169 F7 016A AE 016B BE 0172 D9 0173 F9 017D AC 017E BC 2015 BD} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-10 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-10 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A7 A7 00AD AD 00B0 B0 00B7 B7 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C9 C9 00CB CB 00CD CD 00CE CE 00CF CF 00D0 D0 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D8 D8 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E9 E9 00EB EB 00ED ED 00EE EE 00EF EF 00F0 F0 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F8 F8 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 0100 C0 0101 E0 0104 A1 0105 B1 010C C8 010D E8 0110 A9 0111 B9 0112 A2 0113 B2 0116 CC 0117 EC 0118 CA 0119 EA 0122 A3 0123 B3 0128 A5 0129 B5 012A A4 012B B4 012E C7 012F E7 0136 A6 0137 B6 0138 FF 013B A8 013C B8 0145 D1 0146 F1 014A AF 014B BF 014C D2 014D F2 0160 AA 0161 BA 0166 AB 0167 BB 0168 D7 0169 F7 016A AE 016B BE 0172 D9 0173 F9 017D AC 017E BC 2015 BD} +} -result {} + +# iso8859-10 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # iso8859-10 + +# iso8859-10 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-10 \U000000A1 tcl8 1A -1 {} {} + iso8859-10 \U000000A1 replace 1A -1 {} {} + iso8859-10 \U000000A1 strict {} 0 {} {} + iso8859-10 \U00000400 tcl8 1A -1 {} {} + iso8859-10 \U00000400 replace 1A -1 {} {} + iso8859-10 \U00000400 strict {} 0 {} {} + iso8859-10 \U0000D800 tcl8 1A -1 {} {} + iso8859-10 \U0000D800 replace 1A -1 {} {} + iso8859-10 \U0000D800 strict {} 0 {} {} + iso8859-10 \U0000DC00 tcl8 1A -1 {} {} + iso8859-10 \U0000DC00 replace 1A -1 {} {} + iso8859-10 \U0000DC00 strict {} 0 {} {} + iso8859-10 \U00010000 tcl8 1A -1 {} {} + iso8859-10 \U00010000 replace 1A -1 {} {} + iso8859-10 \U00010000 strict {} 0 {} {} + iso8859-10 \U0010FFFF tcl8 1A -1 {} {} + iso8859-10 \U0010FFFF replace 1A -1 {} {} + iso8859-10 \U0010FFFF strict {} 0 {} {} +}; # iso8859-10 + +# +# iso8859-11 (generated from glibc-ISO_8859_11-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-11 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-11 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 0E01 A1 0E02 A2 0E03 A3 0E04 A4 0E05 A5 0E06 A6 0E07 A7 0E08 A8 0E09 A9 0E0A AA 0E0B AB 0E0C AC 0E0D AD 0E0E AE 0E0F AF 0E10 B0 0E11 B1 0E12 B2 0E13 B3 0E14 B4 0E15 B5 0E16 B6 0E17 B7 0E18 B8 0E19 B9 0E1A BA 0E1B BB 0E1C BC 0E1D BD 0E1E BE 0E1F BF 0E20 C0 0E21 C1 0E22 C2 0E23 C3 0E24 C4 0E25 C5 0E26 C6 0E27 C7 0E28 C8 0E29 C9 0E2A CA 0E2B CB 0E2C CC 0E2D CD 0E2E CE 0E2F CF 0E30 D0 0E31 D1 0E32 D2 0E33 D3 0E34 D4 0E35 D5 0E36 D6 0E37 D7 0E38 D8 0E39 D9 0E3A DA 0E3F DF 0E40 E0 0E41 E1 0E42 E2 0E43 E3 0E44 E4 0E45 E5 0E46 E6 0E47 E7 0E48 E8 0E49 E9 0E4A EA 0E4B EB 0E4C EC 0E4D ED 0E4E EE 0E4F EF 0E50 F0 0E51 F1 0E52 F2 0E53 F3 0E54 F4 0E55 F5 0E56 F6 0E57 F7 0E58 F8 0E59 F9 0E5A FA 0E5B FB} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-11 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-11 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 0E01 A1 0E02 A2 0E03 A3 0E04 A4 0E05 A5 0E06 A6 0E07 A7 0E08 A8 0E09 A9 0E0A AA 0E0B AB 0E0C AC 0E0D AD 0E0E AE 0E0F AF 0E10 B0 0E11 B1 0E12 B2 0E13 B3 0E14 B4 0E15 B5 0E16 B6 0E17 B7 0E18 B8 0E19 B9 0E1A BA 0E1B BB 0E1C BC 0E1D BD 0E1E BE 0E1F BF 0E20 C0 0E21 C1 0E22 C2 0E23 C3 0E24 C4 0E25 C5 0E26 C6 0E27 C7 0E28 C8 0E29 C9 0E2A CA 0E2B CB 0E2C CC 0E2D CD 0E2E CE 0E2F CF 0E30 D0 0E31 D1 0E32 D2 0E33 D3 0E34 D4 0E35 D5 0E36 D6 0E37 D7 0E38 D8 0E39 D9 0E3A DA 0E3F DF 0E40 E0 0E41 E1 0E42 E2 0E43 E3 0E44 E4 0E45 E5 0E46 E6 0E47 E7 0E48 E8 0E49 E9 0E4A EA 0E4B EB 0E4C EC 0E4D ED 0E4E EE 0E4F EF 0E50 F0 0E51 F1 0E52 F2 0E53 F3 0E54 F4 0E55 F5 0E56 F6 0E57 F7 0E58 F8 0E59 F9 0E5A FA 0E5B FB} +} -result {} + +# iso8859-11 - invalid byte sequences +lappend encInvalidBytes {*}{ + iso8859-11 DB tcl8 \U000000DB -1 {} {} + iso8859-11 DB replace \uFFFD -1 {} {} + iso8859-11 DB strict {} 0 {} {} + iso8859-11 DC tcl8 \U000000DC -1 {} {} + iso8859-11 DC replace \uFFFD -1 {} {} + iso8859-11 DC strict {} 0 {} {} + iso8859-11 DD tcl8 \U000000DD -1 {} {} + iso8859-11 DD replace \uFFFD -1 {} {} + iso8859-11 DD strict {} 0 {} {} + iso8859-11 DE tcl8 \U000000DE -1 {} {} + iso8859-11 DE replace \uFFFD -1 {} {} + iso8859-11 DE strict {} 0 {} {} + iso8859-11 FC tcl8 \U000000FC -1 {} {} + iso8859-11 FC replace \uFFFD -1 {} {} + iso8859-11 FC strict {} 0 {} {} + iso8859-11 FD tcl8 \U000000FD -1 {} {} + iso8859-11 FD replace \uFFFD -1 {} {} + iso8859-11 FD strict {} 0 {} {} + iso8859-11 FE tcl8 \U000000FE -1 {} {} + iso8859-11 FE replace \uFFFD -1 {} {} + iso8859-11 FE strict {} 0 {} {} + iso8859-11 FF tcl8 \U000000FF -1 {} {} + iso8859-11 FF replace \uFFFD -1 {} {} + iso8859-11 FF strict {} 0 {} {} +}; # iso8859-11 + +# iso8859-11 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-11 \U000000A1 tcl8 1A -1 {} {} + iso8859-11 \U000000A1 replace 1A -1 {} {} + iso8859-11 \U000000A1 strict {} 0 {} {} + iso8859-11 \U00000400 tcl8 1A -1 {} {} + iso8859-11 \U00000400 replace 1A -1 {} {} + iso8859-11 \U00000400 strict {} 0 {} {} + iso8859-11 \U0000D800 tcl8 1A -1 {} {} + iso8859-11 \U0000D800 replace 1A -1 {} {} + iso8859-11 \U0000D800 strict {} 0 {} {} + iso8859-11 \U0000DC00 tcl8 1A -1 {} {} + iso8859-11 \U0000DC00 replace 1A -1 {} {} + iso8859-11 \U0000DC00 strict {} 0 {} {} + iso8859-11 \U00010000 tcl8 1A -1 {} {} + iso8859-11 \U00010000 replace 1A -1 {} {} + iso8859-11 \U00010000 strict {} 0 {} {} + iso8859-11 \U0010FFFF tcl8 1A -1 {} {} + iso8859-11 \U0010FFFF replace 1A -1 {} {} + iso8859-11 \U0010FFFF strict {} 0 {} {} +}; # iso8859-11 + +# +# iso8859-13 (generated from glibc-ISO_8859_13-2.3.3) + +test encoding-convertfrom-ucmCompare-iso8859-13 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-13 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A6 A6 00A7 A7 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B5 B5 00B6 B6 00B7 B7 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00C4 C4 00C5 C5 00C6 AF 00C9 C9 00D3 D3 00D5 D5 00D6 D6 00D7 D7 00D8 A8 00DC DC 00DF DF 00E4 E4 00E5 E5 00E6 BF 00E9 E9 00F3 F3 00F5 F5 00F6 F6 00F7 F7 00F8 B8 00FC FC 0100 C2 0101 E2 0104 C0 0105 E0 0106 C3 0107 E3 010C C8 010D E8 0112 C7 0113 E7 0116 CB 0117 EB 0118 C6 0119 E6 0122 CC 0123 EC 012A CE 012B EE 012E C1 012F E1 0136 CD 0137 ED 013B CF 013C EF 0141 D9 0142 F9 0143 D1 0144 F1 0145 D2 0146 F2 014C D4 014D F4 0156 AA 0157 BA 015A DA 015B FA 0160 D0 0161 F0 016A DB 016B FB 0172 D8 0173 F8 0179 CA 017A EA 017B DD 017C FD 017D DE 017E FE 2019 FF 201C B4 201D A1 201E A5} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-13 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-13 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A2 A2 00A3 A3 00A4 A4 00A6 A6 00A7 A7 00A9 A9 00AB AB 00AC AC 00AD AD 00AE AE 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B5 B5 00B6 B6 00B7 B7 00B9 B9 00BB BB 00BC BC 00BD BD 00BE BE 00C4 C4 00C5 C5 00C6 AF 00C9 C9 00D3 D3 00D5 D5 00D6 D6 00D7 D7 00D8 A8 00DC DC 00DF DF 00E4 E4 00E5 E5 00E6 BF 00E9 E9 00F3 F3 00F5 F5 00F6 F6 00F7 F7 00F8 B8 00FC FC 0100 C2 0101 E2 0104 C0 0105 E0 0106 C3 0107 E3 010C C8 010D E8 0112 C7 0113 E7 0116 CB 0117 EB 0118 C6 0119 E6 0122 CC 0123 EC 012A CE 012B EE 012E C1 012F E1 0136 CD 0137 ED 013B CF 013C EF 0141 D9 0142 F9 0143 D1 0144 F1 0145 D2 0146 F2 014C D4 014D F4 0156 AA 0157 BA 015A DA 015B FA 0160 D0 0161 F0 016A DB 016B FB 0172 D8 0173 F8 0179 CA 017A EA 017B DD 017C FD 017D DE 017E FE 2019 FF 201C B4 201D A1 201E A5} +} -result {} + +# iso8859-13 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # iso8859-13 + +# iso8859-13 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-13 \U000000A1 tcl8 1A -1 {} {} + iso8859-13 \U000000A1 replace 1A -1 {} {} + iso8859-13 \U000000A1 strict {} 0 {} {} + iso8859-13 \U00000400 tcl8 1A -1 {} {} + iso8859-13 \U00000400 replace 1A -1 {} {} + iso8859-13 \U00000400 strict {} 0 {} {} + iso8859-13 \U0000D800 tcl8 1A -1 {} {} + iso8859-13 \U0000D800 replace 1A -1 {} {} + iso8859-13 \U0000D800 strict {} 0 {} {} + iso8859-13 \U0000DC00 tcl8 1A -1 {} {} + iso8859-13 \U0000DC00 replace 1A -1 {} {} + iso8859-13 \U0000DC00 strict {} 0 {} {} + iso8859-13 \U00010000 tcl8 1A -1 {} {} + iso8859-13 \U00010000 replace 1A -1 {} {} + iso8859-13 \U00010000 strict {} 0 {} {} + iso8859-13 \U0010FFFF tcl8 1A -1 {} {} + iso8859-13 \U0010FFFF replace 1A -1 {} {} + iso8859-13 \U0010FFFF strict {} 0 {} {} +}; # iso8859-13 + +# +# iso8859-14 (generated from glibc-ISO_8859_14-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-14 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-14 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A3 A3 00A7 A7 00A9 A9 00AD AD 00AE AE 00B6 B6 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FF FF 010A A4 010B A5 0120 B2 0121 B3 0174 D0 0175 F0 0176 DE 0177 FE 0178 AF 1E02 A1 1E03 A2 1E0A A6 1E0B AB 1E1E B0 1E1F B1 1E40 B4 1E41 B5 1E56 B7 1E57 B9 1E60 BB 1E61 BF 1E6A D7 1E6B F7 1E80 A8 1E81 B8 1E82 AA 1E83 BA 1E84 BD 1E85 BE 1EF2 AC 1EF3 BC} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-14 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-14 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A3 A3 00A7 A7 00A9 A9 00AD AD 00AE AE 00B6 B6 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FF FF 010A A4 010B A5 0120 B2 0121 B3 0174 D0 0175 F0 0176 DE 0177 FE 0178 AF 1E02 A1 1E03 A2 1E0A A6 1E0B AB 1E1E B0 1E1F B1 1E40 B4 1E41 B5 1E56 B7 1E57 B9 1E60 BB 1E61 BF 1E6A D7 1E6B F7 1E80 A8 1E81 B8 1E82 AA 1E83 BA 1E84 BD 1E85 BE 1EF2 AC 1EF3 BC} +} -result {} + +# iso8859-14 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # iso8859-14 + +# iso8859-14 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-14 \U000000A1 tcl8 1A -1 {} {} + iso8859-14 \U000000A1 replace 1A -1 {} {} + iso8859-14 \U000000A1 strict {} 0 {} {} + iso8859-14 \U00000400 tcl8 1A -1 {} {} + iso8859-14 \U00000400 replace 1A -1 {} {} + iso8859-14 \U00000400 strict {} 0 {} {} + iso8859-14 \U0000D800 tcl8 1A -1 {} {} + iso8859-14 \U0000D800 replace 1A -1 {} {} + iso8859-14 \U0000D800 strict {} 0 {} {} + iso8859-14 \U0000DC00 tcl8 1A -1 {} {} + iso8859-14 \U0000DC00 replace 1A -1 {} {} + iso8859-14 \U0000DC00 strict {} 0 {} {} + iso8859-14 \U00010000 tcl8 1A -1 {} {} + iso8859-14 \U00010000 replace 1A -1 {} {} + iso8859-14 \U00010000 strict {} 0 {} {} + iso8859-14 \U0010FFFF tcl8 1A -1 {} {} + iso8859-14 \U0010FFFF replace 1A -1 {} {} + iso8859-14 \U0010FFFF strict {} 0 {} {} +}; # iso8859-14 + +# +# iso8859-15 (generated from glibc-ISO_8859_15-2.1.2) + +test encoding-convertfrom-ucmCompare-iso8859-15 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-15 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A5 A5 00A7 A7 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B5 B5 00B6 B6 00B7 B7 00B9 B9 00BA BA 00BB BB 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D0 D0 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F0 F0 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 00FF FF 0152 BC 0153 BD 0160 A6 0161 A8 0178 BE 017D B4 017E B8 20AC A4} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-15 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-15 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A1 A1 00A2 A2 00A3 A3 00A5 A5 00A7 A7 00A9 A9 00AA AA 00AB AB 00AC AC 00AD AD 00AE AE 00AF AF 00B0 B0 00B1 B1 00B2 B2 00B3 B3 00B5 B5 00B6 B6 00B7 B7 00B9 B9 00BA BA 00BB BB 00BF BF 00C0 C0 00C1 C1 00C2 C2 00C3 C3 00C4 C4 00C5 C5 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D0 D0 00D1 D1 00D2 D2 00D3 D3 00D4 D4 00D5 D5 00D6 D6 00D7 D7 00D8 D8 00D9 D9 00DA DA 00DB DB 00DC DC 00DD DD 00DE DE 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E3 E3 00E4 E4 00E5 E5 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F0 F0 00F1 F1 00F2 F2 00F3 F3 00F4 F4 00F5 F5 00F6 F6 00F7 F7 00F8 F8 00F9 F9 00FA FA 00FB FB 00FC FC 00FD FD 00FE FE 00FF FF 0152 BC 0153 BD 0160 A6 0161 A8 0178 BE 017D B4 017E B8 20AC A4} +} -result {} + +# iso8859-15 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # iso8859-15 + +# iso8859-15 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-15 \U000000A4 tcl8 1A -1 {} {} + iso8859-15 \U000000A4 replace 1A -1 {} {} + iso8859-15 \U000000A4 strict {} 0 {} {} + iso8859-15 \U00000400 tcl8 1A -1 {} {} + iso8859-15 \U00000400 replace 1A -1 {} {} + iso8859-15 \U00000400 strict {} 0 {} {} + iso8859-15 \U0000D800 tcl8 1A -1 {} {} + iso8859-15 \U0000D800 replace 1A -1 {} {} + iso8859-15 \U0000D800 strict {} 0 {} {} + iso8859-15 \U0000DC00 tcl8 1A -1 {} {} + iso8859-15 \U0000DC00 replace 1A -1 {} {} + iso8859-15 \U0000DC00 strict {} 0 {} {} + iso8859-15 \U00010000 tcl8 1A -1 {} {} + iso8859-15 \U00010000 replace 1A -1 {} {} + iso8859-15 \U00010000 strict {} 0 {} {} + iso8859-15 \U0010FFFF tcl8 1A -1 {} {} + iso8859-15 \U0010FFFF replace 1A -1 {} {} + iso8859-15 \U0010FFFF strict {} 0 {} {} +}; # iso8859-15 + +# +# iso8859-16 (generated from glibc-ISO_8859_16-2.3.3) + +test encoding-convertfrom-ucmCompare-iso8859-16 {Compare against ICU UCM} -body { + ucmConvertfromMismatches iso8859-16 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A7 A7 00A9 A9 00AB AB 00AD AD 00B0 B0 00B1 B1 00B6 B6 00B7 B7 00BB BB 00C0 C0 00C1 C1 00C2 C2 00C4 C4 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D2 D2 00D3 D3 00D4 D4 00D6 D6 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E4 E4 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F2 F2 00F3 F3 00F4 F4 00F6 F6 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 0102 C3 0103 E3 0104 A1 0105 A2 0106 C5 0107 E5 010C B2 010D B9 0110 D0 0111 F0 0118 DD 0119 FD 0141 A3 0142 B3 0143 D1 0144 F1 0150 D5 0151 F5 0152 BC 0153 BD 015A D7 015B F7 0160 A6 0161 A8 0170 D8 0171 F8 0178 BE 0179 AC 017A AE 017B AF 017C BF 017D B4 017E B8 0218 AA 0219 BA 021A DE 021B FE 201D B5 201E A5 20AC A4} +} -result {} + +test encoding-convertto-ucmCompare-iso8859-16 {Compare against ICU UCM} -body { + ucmConverttoMismatches iso8859-16 {0000 00 0001 01 0002 02 0003 03 0004 04 0005 05 0006 06 0007 07 0008 08 0009 09 000A 0A 000B 0B 000C 0C 000D 0D 000E 0E 000F 0F 0010 10 0011 11 0012 12 0013 13 0014 14 0015 15 0016 16 0017 17 0018 18 0019 19 001A 1A 001B 1B 001C 1C 001D 1D 001E 1E 001F 1F 0020 20 0021 21 0022 22 0023 23 0024 24 0025 25 0026 26 0027 27 0028 28 0029 29 002A 2A 002B 2B 002C 2C 002D 2D 002E 2E 002F 2F 0030 30 0031 31 0032 32 0033 33 0034 34 0035 35 0036 36 0037 37 0038 38 0039 39 003A 3A 003B 3B 003C 3C 003D 3D 003E 3E 003F 3F 0040 40 0041 41 0042 42 0043 43 0044 44 0045 45 0046 46 0047 47 0048 48 0049 49 004A 4A 004B 4B 004C 4C 004D 4D 004E 4E 004F 4F 0050 50 0051 51 0052 52 0053 53 0054 54 0055 55 0056 56 0057 57 0058 58 0059 59 005A 5A 005B 5B 005C 5C 005D 5D 005E 5E 005F 5F 0060 60 0061 61 0062 62 0063 63 0064 64 0065 65 0066 66 0067 67 0068 68 0069 69 006A 6A 006B 6B 006C 6C 006D 6D 006E 6E 006F 6F 0070 70 0071 71 0072 72 0073 73 0074 74 0075 75 0076 76 0077 77 0078 78 0079 79 007A 7A 007B 7B 007C 7C 007D 7D 007E 7E 007F 7F 0080 80 0081 81 0082 82 0083 83 0084 84 0085 85 0086 86 0087 87 0088 88 0089 89 008A 8A 008B 8B 008C 8C 008D 8D 008E 8E 008F 8F 0090 90 0091 91 0092 92 0093 93 0094 94 0095 95 0096 96 0097 97 0098 98 0099 99 009A 9A 009B 9B 009C 9C 009D 9D 009E 9E 009F 9F 00A0 A0 00A7 A7 00A9 A9 00AB AB 00AD AD 00B0 B0 00B1 B1 00B6 B6 00B7 B7 00BB BB 00C0 C0 00C1 C1 00C2 C2 00C4 C4 00C6 C6 00C7 C7 00C8 C8 00C9 C9 00CA CA 00CB CB 00CC CC 00CD CD 00CE CE 00CF CF 00D2 D2 00D3 D3 00D4 D4 00D6 D6 00D9 D9 00DA DA 00DB DB 00DC DC 00DF DF 00E0 E0 00E1 E1 00E2 E2 00E4 E4 00E6 E6 00E7 E7 00E8 E8 00E9 E9 00EA EA 00EB EB 00EC EC 00ED ED 00EE EE 00EF EF 00F2 F2 00F3 F3 00F4 F4 00F6 F6 00F9 F9 00FA FA 00FB FB 00FC FC 00FF FF 0102 C3 0103 E3 0104 A1 0105 A2 0106 C5 0107 E5 010C B2 010D B9 0110 D0 0111 F0 0118 DD 0119 FD 0141 A3 0142 B3 0143 D1 0144 F1 0150 D5 0151 F5 0152 BC 0153 BD 015A D7 015B F7 0160 A6 0161 A8 0170 D8 0171 F8 0178 BE 0179 AC 017A AE 017B AF 017C BF 017D B4 017E B8 0218 AA 0219 BA 021A DE 021B FE 201D B5 201E A5 20AC A4} +} -result {} + +# iso8859-16 - invalid byte sequences +lappend encInvalidBytes {*}{ +}; # iso8859-16 + +# iso8859-16 - invalid byte sequences +lappend encUnencodableStrings {*}{ + iso8859-16 \U000000A1 tcl8 1A -1 {} {} + iso8859-16 \U000000A1 replace 1A -1 {} {} + iso8859-16 \U000000A1 strict {} 0 {} {} + iso8859-16 \U00000400 tcl8 1A -1 {} {} + iso8859-16 \U00000400 replace 1A -1 {} {} + iso8859-16 \U00000400 strict {} 0 {} {} + iso8859-16 \U0000D800 tcl8 1A -1 {} {} + iso8859-16 \U0000D800 replace 1A -1 {} {} + iso8859-16 \U0000D800 strict {} 0 {} {} + iso8859-16 \U0000DC00 tcl8 1A -1 {} {} + iso8859-16 \U0000DC00 replace 1A -1 {} {} + iso8859-16 \U0000DC00 strict {} 0 {} {} + iso8859-16 \U00010000 tcl8 1A -1 {} {} + iso8859-16 \U00010000 replace 1A -1 {} {} + iso8859-16 \U00010000 strict {} 0 {} {} + iso8859-16 \U0010FFFF tcl8 1A -1 {} {} + iso8859-16 \U0010FFFF replace 1A -1 {} {} + iso8859-16 \U0010FFFF strict {} 0 {} {} +}; # iso8859-16 diff --git a/tools/ucm2tests.tcl b/tools/ucm2tests.tcl index e971631..dc878ef 100644 --- a/tools/ucm2tests.tcl +++ b/tools/ucm2tests.tcl @@ -37,14 +37,27 @@ namespace eval ucm { iso8859-9 glibc-ISO_8859_9-2.1.2 iso8859-10 glibc-ISO_8859_10-2.1.2 iso8859-11 glibc-ISO_8859_11-2.1.2 - iso8859-13 glibc-ISO_8859_13-2.1.2 + iso8859-13 glibc-ISO_8859_13-2.3.3 iso8859-14 glibc-ISO_8859_14-2.1.2 iso8859-15 glibc-ISO_8859_15-2.1.2 iso8859-16 glibc-ISO_8859_16-2.3.3 } - # Dictionary Character map for Tcl encoding + # Array keyed by Tcl encoding name. Each element contains mapping of + # Unicode code point -> byte sequence for that encoding as a flat list + # (or dictionary). Both are stored as hex strings variable charMap + + # Array keyed by Tcl encoding name. List of invalid code sequences + # each being a hex string. + variable invalidCodeSequences + + # Array keyed by Tcl encoding name. List of unicode code points that are + # not mapped, each being a hex string. + variable unmappedCodePoints + + # The fallback character per encoding + variable encSubchar } proc ucm::abort {msg} { @@ -68,7 +81,11 @@ proc ucm::print {s} { puts $outputChan $s } -proc ucm::parse_SBCS {fd} { +proc ucm::parse_SBCS {encName fd} { + variable charMap + variable invalidCodeSequences + variable unmappedCodePoints + set result {} while {[gets $fd line] >= 0} { if {[string match #* $line]} { @@ -87,26 +104,44 @@ proc ucm::parse_SBCS {fd} { # It is a fallback mapping - ignore } } - return $result -} + set charMap($encName) $result -proc ucm::generate_tests {} { - variable encNameMap - variable charMap - variable outputPath - variable outputChan - - if {[info exists outputPath]} { - set outputChan [open $outputPath w] - } else { - set outputChan stdout + # Find out invalid code sequences and unicode code points that are not mapped + set valid {} + set mapped {} + foreach {unich bytes} $result { + lappend mapped $unich + lappend valid $bytes + } + set invalidCodeSequences($encName) {} + for {set i 0} {$i <= 255} {incr i} { + set hex [format %.2X $i] + if {[lsearch -exact $valid $hex] < 0} { + lappend invalidCodeSequences($encName) $hex + } } - array set tclNames {} - foreach encName [encoding names] { - set tclNames($encName) "" + set unmappedCodePoints($encName) {} + for {set i 0} {$i <= 65535} {incr i} { + set hex [format %.4X $i] + if {[lsearch -exact $mapped $hex] < 0} { + lappend unmappedCodePoints($encName) $hex + # Only look for (at most) one below 256 and one above 1024 + if {$i < 255} { + # Found one so jump past 8 bits + set i 255 + } else { + break + } + } + if {$i == 255} { + set i 1023 + } } + lappend unmappedCodePoints($encName) D800 DC00 10000 10FFFF +} +proc ucm::generate_boilerplate {} { # Common procedures print { # This file is automatically generated by ucm2tests.tcl. @@ -118,6 +153,7 @@ proc ucm::generate_tests {} { proc ucmConvertfromMismatches {enc map} { set mismatches {} foreach {unihex hex} $map { + set unihex [string range 00000000$unihex end-7 end]; # Make 8 digits set unich [subst "\\U$unihex"] if {[encoding convertfrom -profile strict $enc [binary decode hex $hex]] ne $unich} { lappend mismatches "<[printable $unich],$hex>" @@ -128,6 +164,7 @@ proc ucmConvertfromMismatches {enc map} { proc ucmConverttoMismatches {enc map} { set mismatches {} foreach {unihex hex} $map { + set unihex [string range 00000000$unihex end-7 end]; # Make 8 digits set unich [subst "\\U$unihex"] if {[encoding convertto -profile strict $enc $unich] ne [binary decode hex $hex]} { lappend mismatches "<[printable $unich],$hex>" @@ -154,6 +191,30 @@ if {[info commands printable] eq ""} { } } } +} ; # generate_boilerplate + +proc ucm::generate_tests {} { + variable encNameMap + variable charMap + variable invalidCodeSequences + variable unmappedCodePoints + variable outputPath + variable outputChan + variable encSubchar + + if {[info exists outputPath]} { + set outputChan [open $outputPath w] + fconfigure $outputChan -translation lf + } else { + set outputChan stdout + } + + array set tclNames {} + foreach encName [encoding names] { + set tclNames($encName) "" + } + + generate_boilerplate foreach encName [lsort -dictionary [array names encNameMap]] { if {![info exists charMap($encName)]} { warn "No character map read for $encName" @@ -161,6 +222,7 @@ if {[info commands printable] eq ""} { } unset tclNames($encName) + # Print the valid tests print "\n#\n# $encName (generated from $encNameMap($encName))" print "\ntest encoding-convertfrom-ucmCompare-$encName {Compare against ICU UCM} -body \{" print " ucmConvertfromMismatches $encName {$charMap($encName)}" @@ -172,13 +234,42 @@ if {[info commands printable] eq ""} { # This will generate individual tests for every char # and test in lead, tail, middle, solo configurations # but takes considerable time - print "lappend encValidStrings {*}{" + print "lappend encValidStrings \{*\}\{" foreach {unich hex} $charMap($encName) { print " $encName \\u$unich $hex {} {}" } - print "}; # $encName" + print "\}; # $encName" + } + + # Generate the invalidity checks + print "\n# $encName - invalid byte sequences" + print "lappend encInvalidBytes \{*\}\{" + foreach hex $invalidCodeSequences($encName) { + # Map XXXX... to \xXX\xXX... + set uhex [regsub -all .. $hex {\\x\0}] + set uhex \\U[string range 00000000$hex end-7 end] + print " $encName $hex tcl8 $uhex -1 {} {}" + print " $encName $hex replace \\uFFFD -1 {} {}" + print " $encName $hex strict {} 0 {} {}" + } + print "\}; # $encName" + + print "\n# $encName - invalid byte sequences" + print "lappend encUnencodableStrings \{*\}\{" + if {[info exists encSubchar($encName)]} { + set subchar $encSubchar($encName) + } else { + set subchar "3F"; # Tcl uses ? by default } + foreach hex $unmappedCodePoints($encName) { + set uhex \\U[string range 00000000$hex end-7 end] + print " $encName $uhex tcl8 $subchar -1 {} {}" + print " $encName $uhex replace $subchar -1 {} {}" + print " $encName $uhex strict {} 0 {} {}" + } + print "\}; # $encName" } + if {[array size tclNames]} { warn "Missing encoding: [lsort [array names tclNames]]" } @@ -190,6 +281,8 @@ if {[info commands printable] eq ""} { proc ucm::parse_file {encName ucmPath} { variable charMap + variable encSubchar + set fd [open $ucmPath] try { # Parse the metadata @@ -205,7 +298,7 @@ proc ucm::parse_file {encName ucmPath} { } } if {![info exists state(charmap)]} { - abort "Error: $path has No CHARMAP line." + abort "Error: $ucmPath has No CHARMAP line." } foreach key {code_set_name uconv_class} { if {[info exists state($key)]} { @@ -216,18 +309,22 @@ proc ucm::parse_file {encName ucmPath} { abort "Duplicate file for $encName ($path)" } if {![info exists state(uconv_class)]} { - abort "Error: $path has no uconv_class definition." + abort "Error: $ucmPath has no uconv_class definition." + } + if {[info exists state(subchar)]} { + # \xNN\xNN.. -> NNNN.. + set encSubchar($encName) [string map {\\x {}} $state(subchar)] } switch -exact -- $state(uconv_class) { SBCS { if {[catch { - set charMap($encName) [parse_SBCS $fd] + parse_SBCS $encName $fd } result]} { - abort "Could not process $path. $result" + abort "Could not process $ucmPath. $result" } } default { - log "Skipping $path -- not SBCS encoding." + log "Skipping $ucmPath -- not SBCS encoding." return } } @@ -236,15 +333,6 @@ proc ucm::parse_file {encName ucmPath} { } } -proc ucm::expand_paths {patterns} { - set expanded {} - foreach pat $patterns { - # The file join is for \ -> / - lappend expanded {*}[glob -nocomplain [file join $pat]] - } - return $expanded -} - proc ucm::run {} { variable encNameMap variable outputPath -- cgit v0.12 From 1d76ffb03b359c7f557943523fd9b0c49a312554 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 22 Feb 2023 20:44:13 +0000 Subject: minor bug-fix in utf-16/utf-32: 2 testcases failed in Tcl 9 compatibility mode (-DTCL_NO_DEPRECATED) --- generic/tclEncoding.c | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 0490831..8e13b43 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -237,8 +237,13 @@ static Tcl_EncodingConvertProc Iso88591ToUtfProc; */ static const Tcl_ObjType encodingType = { - "encoding", FreeEncodingInternalRep, DupEncodingInternalRep, NULL, NULL + "encoding", + FreeEncodingInternalRep, + DupEncodingInternalRep, + NULL, + NULL }; + #define EncodingSetInternalRep(objPtr, encoding) \ do { \ Tcl_ObjInternalRep ir; \ @@ -461,7 +466,7 @@ FillEncodingFileMap(void) map = Tcl_NewDictObj(); Tcl_IncrRefCount(map); - for (i = numDirs-1; i >= 0; i--) { + for (i = numDirs-1; i != TCL_INDEX_NONE; i--) { /* * Iterate backwards through the search path so as we overwrite * entries found, we favor files earlier on the search path. @@ -1182,7 +1187,7 @@ Tcl_ExternalToUtfDString( * Tcl_ExternalToUtfDStringEx -- * * Convert a source buffer from the specified encoding into UTF-8. -* The parameter flags controls the behavior, if any of the bytes in + * The parameter flags controls the behavior, if any of the bytes in * the source buffer are invalid or cannot be represented in utf-8. * Possible flags values: * TCL_ENCODING_STOPONERROR: don't replace invalid characters/bytes but @@ -1458,8 +1463,9 @@ Tcl_UtfToExternalDStringEx( char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; - int dstLen, result, soFar, srcRead, dstWrote, dstChars; + int result, soFar, srcRead, dstWrote, dstChars; const char *srcStart = src; + int dstLen; Tcl_DStringInit(dstPtr); dst = Tcl_DStringValue(dstPtr); @@ -2627,9 +2633,10 @@ Utf32ToUtfProc( result = TCL_CONVERT_NOSPACE; } else { /* destination is not full, so we really are at the end now */ - if (flags & TCL_ENCODING_STOPONERROR) { + if ((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT) { result = TCL_CONVERT_SYNTAX; } else { + result = TCL_OK; dst += Tcl_UniCharToUtf(0xFFFD, dst); numChars++; src += bytesLeft; @@ -2854,9 +2861,10 @@ Utf16ToUtfProc( result = TCL_CONVERT_NOSPACE; } else { /* destination is not full, so we really are at the end now */ - if (flags & TCL_ENCODING_STOPONERROR) { + if (((flags & TCL_ENCODING_STRICT) == TCL_ENCODING_STRICT)) { result = TCL_CONVERT_SYNTAX; } else { + result = TCL_OK; dst += Tcl_UniCharToUtf(0xFFFD, dst); numChars++; src++; -- cgit v0.12 From d1920b380d4a987240715b3ce72f7d68dfca2b09 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 23 Feb 2023 10:22:58 +0000 Subject: Fix gcc warnings and encoding error message (bug [40c61a5d10]) --- generic/tclCmdAH.c | 2 +- generic/tclEncoding.c | 4 ++-- tests/cmdAH.test | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 4dfb541..1b74064 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -589,7 +589,7 @@ numArgsError: /* ONLY jump here if nothing needs to be freed!!! */ interp, 1, objv, - "??-profile profile? ?-failindex var? ?encoding?? data"); + "? ?-profile profile? ?-failindex var? encoding ? data"); return TCL_ERROR; } diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index bc830b4..a877468 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -4265,7 +4265,7 @@ TclEncodingProfileNameToId( const char *profileName, /* Name of profile */ int *profilePtr) /* Output */ { - int i; + size_t i; for (i = 0; i < sizeof(encodingProfiles) / sizeof(encodingProfiles[0]); ++i) { if (!strcmp(profileName, encodingProfiles[i].name)) { @@ -4305,7 +4305,7 @@ TclEncodingProfileIdToName( Tcl_Interp *interp, /* For error messages. May be NULL */ int profileValue) /* Profile #define value */ { - int i; + size_t i; for (i = 0; i < sizeof(encodingProfiles) / sizeof(encodingProfiles[0]); ++i) { if (profileValue == encodingProfiles[i].value) { diff --git a/tests/cmdAH.test b/tests/cmdAH.test index cfde678..d76607c 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -175,8 +175,8 @@ test cmdAH-3.2 {Tcl_ContinueObjCmd, success} { # encoding command set "numargErrors(encoding system)" {^wrong # args: should be "(encoding |::tcl::encoding::)system \?encoding\?"$} -set "numargErrors(encoding convertfrom)" {^wrong # args: should be "(encoding |::tcl::encoding::)convertfrom \?\?-profile profile\? \?-failindex var\? \?encoding\?\? data"$} -set "numargErrors(encoding convertto)" {^wrong # args: should be "(encoding |::tcl::encoding::)convertto \?\?-profile profile\? \?-failindex var\? \?encoding\?\? data"$} +set "numargErrors(encoding convertfrom)" {^wrong # args: should be "(encoding |::tcl::encoding::)convertfrom \? \?-profile profile\? \?-failindex var\? encoding \? data"$} +set "numargErrors(encoding convertto)" {^wrong # args: should be "(encoding |::tcl::encoding::)convertto \? \?-profile profile\? \?-failindex var\? encoding \? data"$} set "numargErrors(encoding names)" {wrong # args: should be "encoding names"} set "numargErrors(encoding profiles)" {wrong # args: should be "encoding profiles"} -- cgit v0.12 From bf7b1adb896dbe4f79efb038aa0ecaebbdd3919c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 Feb 2023 10:44:56 +0000 Subject: See [d19fe0a5b] for follow-up to previous commit --- generic/tclEncoding.c | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index ecec6e9..2b3b614 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -2516,13 +2516,10 @@ UnicodeToUtfProc( result = TCL_CONVERT_NOSPACE; } else { /* destination is not full, so we really are at the end now */ - if (flags & TCL_ENCODING_STOPONERROR) { - result = TCL_CONVERT_SYNTAX; - } else { - dst += Tcl_UniCharToUtf(0xFFFD, dst); - numChars++; - src++; - } + result = TCL_OK; + dst += Tcl_UniCharToUtf(0xFFFD, dst); + numChars++; + src++; } } *srcReadPtr = src - srcStart; -- cgit v0.12 From da915fdadfa41477f967f92d37c63e278621acd7 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 23 Feb 2023 13:19:45 +0000 Subject: New signature for Tcl_ExternalToUtfDStringEx and Tcl_UtfToExternalDStringEx as per TIP 656 --- generic/tcl.decls | 14 ++-- generic/tclCmdAH.c | 99 +++++++++++++++++++++++++--- generic/tclDecls.h | 18 +++--- generic/tclEncoding.c | 174 +++++++++++++++++++++++++++++++++++++++----------- tests/cmdAH.test | 24 +++++-- 5 files changed, 264 insertions(+), 65 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index a48ab02..a789ef6 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2441,13 +2441,17 @@ declare 656 { declare 657 { int Tcl_UniCharIsUnicode(int ch) } + +# TIP 656 declare 658 { - Tcl_Size Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, - const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr) -} + int Tcl_ExternalToUtfDStringEx(Tcl_Interp *interp, Tcl_Encoding encoding, + const char *src, int srcLen, int flags, Tcl_DString *dsPtr, + Tcl_Size *errorLocationPtr) +} declare 659 { - Tcl_Size Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, - const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr) + int Tcl_UtfToExternalDStringEx(Tcl_Interp *interp, Tcl_Encoding encoding, + const char *src, int srcLen, int flags, Tcl_DString *dsPtr, + Tcl_Size *errorLocationPtr) } # TIP #511 diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 1b74064..24b2038 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -671,6 +671,7 @@ EncodingConvertfromObjCmd( int flags; int result; Tcl_Obj *failVarObj; + Tcl_Size errorLocation; if (EncodingConvertParseOptions( interp, objc, objv, &encoding, &data, &flags, &failVarObj) @@ -693,8 +694,47 @@ EncodingConvertfromObjCmd( if (bytesPtr == NULL) { return TCL_ERROR; } - result = Tcl_ExternalToUtfDStringEx(encoding, bytesPtr, length, - flags, &ds); + result = Tcl_ExternalToUtfDStringEx(interp, encoding, bytesPtr, length, flags, + &ds, failVarObj ? &errorLocation : NULL); + /* NOTE: ds must be freed beyond this point even on error */ + switch (result) { + case TCL_OK: + errorLocation = TCL_INDEX_NONE; + break; + case TCL_ERROR: + /* Error in parameters. Should not happen. interp will have error */ + Tcl_DStringFree(&ds); + return TCL_ERROR; + default: + /* + * One of the TCL_CONVERT_* errors. If we were not interested in the + * error location, interp result would already have been filled in + * and we can just return the error. Otherwise, we have to return + * what could be decoded and the returned error location. + */ + if (failVarObj == NULL) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + break; + } + + /* + * TCL_OK or a TCL_CONVERT_* error where the caller wants back as much + * data as was converted. + */ + if (failVarObj) { + /* I hope, wide int will cover Tcl_Size data type */ + if (Tcl_ObjSetVar2(interp, + failVarObj, + NULL, + Tcl_NewWideIntObj(errorLocation), + TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + } +#ifdef OBSOLETE if (result != TCL_INDEX_NONE && TCL_ENCODING_PROFILE_GET(flags) != TCL_ENCODING_PROFILE_TCL8) { if (failVarObj != NULL) { @@ -717,6 +757,7 @@ EncodingConvertfromObjCmd( return TCL_ERROR; } } +#endif /* * Note that we cannot use Tcl_DStringResult here because it will @@ -725,9 +766,7 @@ EncodingConvertfromObjCmd( Tcl_SetObjResult(interp, Tcl_DStringToObj(&ds)); - /* - * We're done with the encoding - */ + /* We're done with the encoding */ Tcl_FreeEncoding(encoding); return TCL_OK; @@ -763,6 +802,7 @@ EncodingConverttoObjCmd( int result; int flags; Tcl_Obj *failVarObj; + Tcl_Size errorLocation; if (EncodingConvertParseOptions( interp, objc, objv, &encoding, &data, &flags, &failVarObj) @@ -775,8 +815,47 @@ EncodingConverttoObjCmd( */ stringPtr = TclGetStringFromObj(data, &length); - result = Tcl_UtfToExternalDStringEx(encoding, stringPtr, length, - flags, &ds); + result = Tcl_UtfToExternalDStringEx(interp, encoding, stringPtr, length, flags, + &ds, failVarObj ? &errorLocation : NULL); + /* NOTE: ds must be freed beyond this point even on error */ + + switch (result) { + case TCL_OK: + errorLocation = TCL_INDEX_NONE; + break; + case TCL_ERROR: + /* Error in parameters. Should not happen. interp will have error */ + Tcl_DStringFree(&ds); + return TCL_ERROR; + default: + /* + * One of the TCL_CONVERT_* errors. If we were not interested in the + * error location, interp result would already have been filled in + * and we can just return the error. Otherwise, we have to return + * what could be decoded and the returned error location. + */ + if (failVarObj == NULL) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + break; + } + /* + * TCL_OK or a TCL_CONVERT_* error where the caller wants back as much + * data as was converted. + */ + if (failVarObj) { + /* I hope, wide int will cover Tcl_Size data type */ + if (Tcl_ObjSetVar2(interp, + failVarObj, + NULL, + Tcl_NewWideIntObj(errorLocation), + TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + } +#ifdef OBSOLETE if (result != TCL_INDEX_NONE && TCL_ENCODING_PROFILE_GET(flags) != TCL_ENCODING_PROFILE_TCL8) { if (failVarObj != NULL) { @@ -802,14 +881,14 @@ EncodingConverttoObjCmd( return TCL_ERROR; } } +#endif + Tcl_SetObjResult(interp, Tcl_NewByteArrayObj((unsigned char*) Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); Tcl_DStringFree(&ds); - /* - * We're done with the encoding - */ + /* We're done with the encoding */ Tcl_FreeEncoding(encoding); return TCL_OK; diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 77517e8..fbfa8a1 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1955,13 +1955,15 @@ EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); /* 657 */ EXTERN int Tcl_UniCharIsUnicode(int ch); /* 658 */ -EXTERN Tcl_Size Tcl_ExternalToUtfDStringEx(Tcl_Encoding encoding, - const char *src, Tcl_Size srcLen, int flags, - Tcl_DString *dsPtr); +EXTERN int Tcl_ExternalToUtfDStringEx(Tcl_Interp *interp, + Tcl_Encoding encoding, const char *src, + int srcLen, int flags, Tcl_DString *dsPtr, + Tcl_Size *errorLocationPtr); /* 659 */ -EXTERN Tcl_Size Tcl_UtfToExternalDStringEx(Tcl_Encoding encoding, - const char *src, Tcl_Size srcLen, int flags, - Tcl_DString *dsPtr); +EXTERN int Tcl_UtfToExternalDStringEx(Tcl_Interp *interp, + Tcl_Encoding encoding, const char *src, + int srcLen, int flags, Tcl_DString *dsPtr, + Tcl_Size *errorLocationPtr); /* 660 */ EXTERN int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber); @@ -2741,8 +2743,8 @@ typedef struct TclStubs { const char * (*tcl_UtfNext) (const char *src); /* 655 */ const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */ int (*tcl_UniCharIsUnicode) (int ch); /* 657 */ - Tcl_Size (*tcl_ExternalToUtfDStringEx) (Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr); /* 658 */ - Tcl_Size (*tcl_UtfToExternalDStringEx) (Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr); /* 659 */ + int (*tcl_ExternalToUtfDStringEx) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr, Tcl_Size *errorLocationPtr); /* 658 */ + int (*tcl_UtfToExternalDStringEx) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_DString *dsPtr, Tcl_Size *errorLocationPtr); /* 659 */ int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */ int (*tclListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *objcPtr, Tcl_Obj ***objvPtr); /* 661 */ int (*tclListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, size_t *lengthPtr); /* 662 */ diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index daab3a9..365aa90 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1203,7 +1203,8 @@ Tcl_ExternalToUtfDString( Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { - Tcl_ExternalToUtfDStringEx(encoding, src, srcLen, TCL_ENCODING_PROFILE_TCL8, dstPtr); + Tcl_ExternalToUtfDStringEx( + NULL, encoding, src, srcLen, TCL_ENCODING_PROFILE_TCL8, dstPtr, NULL); return Tcl_DStringValue(dstPtr); } @@ -1223,29 +1224,49 @@ Tcl_ExternalToUtfDString( * to TCL_ENCODING_PROFILE_STRICT overriding any specified profile flags * - TCL_ENCODING_MODIFIED: enable Tcl internal conversion mapping \xC0\x80 * to 0x00. Only valid for "utf-8" and "cesu-8". + * Any other flag bits will cause an error to be returned (for future + * compatibility) * * Results: - * The converted bytes are stored in the DString, which is then NULL - * terminated in an encoding-specific manner. The return value is - * the error position in the source string or -1 if no conversion error - * is reported. - * + * The return value is one of + * TCL_OK: success. Converted string in *dstPtr + * TCL_ERROR: error in passed parameters. Error message in interp + * TCL_CONVERT_MULTIBYTE: source ends in truncated multibyte sequence + * TCL_CONVERT_SYNTAX: source is not conformant to encoding definition + * TCL_CONVERT_UNKNOWN: source contained a character that could not + * be represented in target encoding. + * * Side effects: - * None. + * + * TCL_OK: The converted bytes are stored in the DString and NUL + * terminated in an encoding-specific manner. + * TCL_ERROR: an error, message is stored in the interp if not NULL. + * TCL_CONVERT_*: if errorLocPtr is NULL, an error message is stored + * in the interpreter (if not NULL). If errorLocPtr is not NULL, + * no error message is stored as it is expected the caller is + * interested in whatever is decoded so far and not treating this + * as an error condition. + * + * In addition, *dstPtr is always initialized and must be cleared + * by the caller irrespective of the return code. * *------------------------------------------------------------------------- */ int Tcl_ExternalToUtfDStringEx( + Tcl_Interp *interp, /* For error messages. May be NULL. */ Tcl_Encoding encoding, /* The encoding for the source string, or NULL * for the default system encoding. */ const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes, or < 0 for * encoding-specific string length. */ int flags, /* Conversion control flags. */ - Tcl_DString *dstPtr) /* Uninitialized or free DString in which the + Tcl_DString *dstPtr, /* Uninitialized or free DString in which the * converted string is stored. */ + Tcl_Size *errorLocPtr) /* Where to store the error location + (or TCL_INDEX_NONE if no error). May + be NULL. */ { char *dst; Tcl_EncodingState state; @@ -1253,14 +1274,14 @@ Tcl_ExternalToUtfDStringEx( int dstLen, result, soFar, srcRead, dstWrote, dstChars; const char *srcStart = src; - Tcl_DStringInit(dstPtr); + Tcl_DStringInit(dstPtr); /* Must always be initialized before returning */ dst = Tcl_DStringValue(dstPtr); dstLen = dstPtr->spaceAvl - 1; if (encoding == NULL) { - encoding = systemEncoding; + encoding = systemEncoding; } - encodingPtr = (Encoding *) encoding; + encodingPtr = (Encoding *)encoding; if (src == NULL) { srcLen = 0; @@ -1275,26 +1296,53 @@ Tcl_ExternalToUtfDStringEx( } while (1) { - result = encodingPtr->toUtfProc(encodingPtr->clientData, src, srcLen, - flags, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars); - soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + result = encodingPtr->toUtfProc(encodingPtr->clientData, src, + srcLen, flags, &state, dst, dstLen, + &srcRead, &dstWrote, &dstChars); + soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + + src += srcRead; + if (result != TCL_CONVERT_NOSPACE) { + Tcl_Size nBytesProcessed = (Tcl_Size)(src - srcStart); + + Tcl_DStringSetLength(dstPtr, soFar); + if (errorLocPtr) { + /* + * Do not write error message into interpreter if caller + * wants to know error location. + */ + *errorLocPtr = result == TCL_OK ? TCL_INDEX_NONE : nBytesProcessed; + } + else { + /* Caller wants error message on failure */ + if (result != TCL_OK && interp != NULL) { + char buf[TCL_INTEGER_SPACE]; + sprintf(buf, "%u", nBytesProcessed); + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("unexpected byte sequence starting at index %" + "u: '\\x%X'", + nBytesProcessed, + UCHAR(srcStart[nBytesProcessed]))); + Tcl_SetErrorCode( + interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", buf, NULL); + } + } + return result; + } - src += srcRead; - if (result != TCL_CONVERT_NOSPACE) { - Tcl_DStringSetLength(dstPtr, soFar); - return (result == TCL_OK) ? TCL_INDEX_NONE : (int)(src - srcStart); - } - flags &= ~TCL_ENCODING_START; - srcLen -= srcRead; - if (Tcl_DStringLength(dstPtr) == 0) { - Tcl_DStringSetLength(dstPtr, dstLen); - } - Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1); - dst = Tcl_DStringValue(dstPtr) + soFar; - dstLen = Tcl_DStringLength(dstPtr) - soFar - 1; + /* Expand space and continue */ + flags &= ~TCL_ENCODING_START; + srcLen -= srcRead; + if (Tcl_DStringLength(dstPtr) == 0) { + Tcl_DStringSetLength(dstPtr, dstLen); + } + Tcl_DStringSetLength(dstPtr, 2 * Tcl_DStringLength(dstPtr) + 1); + dst = Tcl_DStringValue(dstPtr) + soFar; + dstLen = Tcl_DStringLength(dstPtr) - soFar - 1; } } - + /* *------------------------------------------------------------------------- * @@ -1441,7 +1489,8 @@ Tcl_UtfToExternalDString( Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { - Tcl_UtfToExternalDStringEx(encoding, src, srcLen, TCL_ENCODING_PROFILE_DEFAULT, dstPtr); + Tcl_UtfToExternalDStringEx( + NULL, encoding, src, srcLen, TCL_ENCODING_PROFILE_DEFAULT, dstPtr, NULL); return Tcl_DStringValue(dstPtr); } @@ -1462,27 +1511,45 @@ Tcl_UtfToExternalDString( * of 0x00. Only valid for "utf-8" and "cesu-8". * * Results: - * The converted bytes are stored in the DString, which is then NULL - * terminated in an encoding-specific manner. The return value is - * the error position in the source string or -1 if no conversion error - * is reported. + * The return value is one of + * TCL_OK: success. Converted string in *dstPtr + * TCL_ERROR: error in passed parameters. Error message in interp + * TCL_CONVERT_MULTIBYTE: source ends in truncated multibyte sequence + * TCL_CONVERT_SYNTAX: source is not conformant to encoding definition + * TCL_CONVERT_UNKNOWN: source contained a character that could not + * be represented in target encoding. * * Side effects: - * None. + * + * TCL_OK: The converted bytes are stored in the DString and NUL + * terminated in an encoding-specific manner + * TCL_ERROR: an error, message is stored in the interp if not NULL. + * TCL_CONVERT_*: if errorLocPtr is NULL, an error message is stored + * in the interpreter (if not NULL). If errorLocPtr is not NULL, + * no error message is stored as it is expected the caller is + * interested in whatever is decoded so far and not treating this + * as an error condition. + * + * In addition, *dstPtr is always initialized and must be cleared + * by the caller irrespective of the return code. * *------------------------------------------------------------------------- */ int Tcl_UtfToExternalDStringEx( + Tcl_Interp *interp, /* For error messages. May be NULL. */ Tcl_Encoding encoding, /* The encoding for the converted string, or * NULL for the default system encoding. */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes, or < 0 for * strlen(). */ int flags, /* Conversion control flags. */ - Tcl_DString *dstPtr) /* Uninitialized or free DString in which the + Tcl_DString *dstPtr, /* Uninitialized or free DString in which the * converted string is stored. */ + Tcl_Size *errorLocPtr) /* Where to store the error location + (or TCL_INDEX_NONE if no error). May + be NULL. */ { char *dst; Tcl_EncodingState state; @@ -1505,21 +1572,49 @@ Tcl_UtfToExternalDStringEx( } else if (srcLen < 0) { srcLen = strlen(src); } + flags = TclEncodingExternalFlagsToInternal(flags); flags |= TCL_ENCODING_START | TCL_ENCODING_END; while (1) { result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, - srcLen, flags, &state, dst, dstLen, - &srcRead, &dstWrote, &dstChars); + srcLen, flags, &state, dst, dstLen, + &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); src += srcRead; if (result != TCL_CONVERT_NOSPACE) { + Tcl_Size nBytesProcessed = (Tcl_Size)(src - srcStart); int i = soFar + encodingPtr->nullSize - 1; while (i >= soFar) { Tcl_DStringSetLength(dstPtr, i--); } - return (result == TCL_OK) ? TCL_INDEX_NONE : (int)(src - srcStart); + if (errorLocPtr) { + /* + * Do not write error message into interpreter if caller + * wants to know error location. + */ + *errorLocPtr = result == TCL_OK ? TCL_INDEX_NONE : nBytesProcessed; + } + else { + /* Caller wants error message on failure */ + if (result != TCL_OK && interp != NULL) { + Tcl_Size pos = Tcl_NumUtfChars(srcStart, nBytesProcessed); + int ucs4; + char buf[TCL_INTEGER_SPACE]; + TclUtfToUCS4(&srcStart[nBytesProcessed], &ucs4); + sprintf(buf, "%u", nBytesProcessed); + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf( + "unexpected character at index %" TCL_Z_MODIFIER + "u: 'U+%06X'", + pos, + ucs4)); + Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", + buf, NULL); + } + } + return result; } flags &= ~TCL_ENCODING_START; @@ -2682,6 +2777,8 @@ Utf32ToUtfProc( /* Bug [10c2c17c32]. If Hi surrogate, finish 3-byte UTF-8 */ dst += Tcl_UniCharToUtf(-1, dst); } + + /* * If we had a truncated code unit at the end AND this is the last * fragment AND profile is not "strict", stick FFFD in its place. @@ -2917,6 +3014,7 @@ Utf16ToUtfProc( /* Bug [10c2c17c32]. If Hi surrogate, finish 3-byte UTF-8 */ dst += Tcl_UniCharToUtf(-1, dst); } + /* * If we had a truncated code unit at the end AND this is the last * fragment AND profile is not "strict", stick FFFD in its place. diff --git a/tests/cmdAH.test b/tests/cmdAH.test index f8eba4e..471d46a 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -703,15 +703,25 @@ lappend encInvalidBytes {*}{ # happen when the sequence is at the end (including by itself) Thus {solo tail} # in some cases. lappend encInvalidBytes {*}{ - utf-16le 41 tcl8 \uFFFD -1 {solo tail} {Truncated} - utf-16le 41 replace \uFFFD -1 {solo tail} {Truncated} - utf-16le 41 strict {} 0 {solo tail} {Truncated} + utf-16le 41 tcl8 \uFFFD -1 {solo tail} {Truncated} + utf-16le 41 replace \uFFFD -1 {solo tail} {Truncated} + utf-16le 41 strict {} 0 {solo tail} {Truncated} utf-16le 00D8 tcl8 \uD800 -1 {} {Missing low surrogate} utf-16le 00D8 replace \uFFFD -1 {knownBug} {Missing low surrogate} utf-16le 00D8 strict {} 0 {knownBug} {Missing low surrogate} utf-16le 00DC tcl8 \uDC00 -1 {} {Missing high surrogate} utf-16le 00DC replace \uFFFD -1 {knownBug} {Missing high surrogate} utf-16le 00DC strict {} 0 {knownBug} {Missing high surrogate} + + utf-16be 41 tcl8 \uFFFD -1 {solo tail} {Truncated} + utf-16be 41 replace \uFFFD -1 {solo tail} {Truncated} + utf-16be 41 strict {} 0 {solo tail} {Truncated} + utf-16be D800 tcl8 \uD800 -1 {} {Missing low surrogate} + utf-16be D800 replace \uFFFD -1 {knownBug} {Missing low surrogate} + utf-16be D800 strict {} 0 {knownBug} {Missing low surrogate} + utf-16be DC00 tcl8 \uDC00 -1 {} {Missing high surrogate} + utf-16be DC00 replace \uFFFD -1 {knownBug} {Missing high surrogate} + utf-16be DC00 strict {} 0 {knownBug} {Missing high surrogate} } # utf32-le and utf32-be test cases. Note utf32 cases are automatically generated @@ -727,7 +737,7 @@ lappend encInvalidBytes {*}{ utf-32le 4100 strict {} 0 {solo tail} {Truncated} utf-32le 410000 tcl8 \uFFFD -1 {solo tail} {Truncated} utf-32le 410000 replace \uFFFD -1 {solo} {Truncated} - utf-32le 410000 strict {} 0 {solo tail} {Truncated} + utf-32le 410000 strict {} 0 {solo tail} {Truncated} utf-32le 00D80000 tcl8 \uD800 -1 {} {High-surrogate} utf-32le 00D80000 replace \uFFFD -1 {} {High-surrogate} utf-32le 00D80000 strict {} 0 {} {High-surrogate} @@ -745,8 +755,14 @@ lappend encInvalidBytes {*}{ utf-32le FFFFFFFF strict {} 0 {} {Out of range} utf-32be 41 tcl8 \uFFFD -1 {solo tail} {Truncated} + utf-32be 41 replace \uFFFD -1 {solo tail} {Truncated} + utf-32be 41 strict {} 0 {solo tail} {Truncated} utf-32be 0041 tcl8 \uFFFD -1 {solo tail} {Truncated} + utf-32be 0041 replace \uFFFD -1 {solo} {Truncated} + utf-32be 0041 strict {} 0 {solo tail} {Truncated} utf-32be 000041 tcl8 \uFFFD -1 {solo tail} {Truncated} + utf-32be 000041 replace \uFFFD -1 {solo} {Truncated} + utf-32be 000041 strict {} 0 {solo tail} {Truncated} utf-32be 0000D800 tcl8 \uD800 -1 {} {High-surrogate} utf-32be 0000D800 replace \uFFFD -1 {} {High-surrogate} utf-32be 0000D800 strict {} 0 {} {High-surrogate} -- cgit v0.12 From 186cc71273a606360094ccb275bc239c6c17235a Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Thu, 23 Feb 2023 13:24:58 +0000 Subject: Had forgotten to remove disabled code --- generic/tclCmdAH.c | 52 ---------------------------------------------------- 1 file changed, 52 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 24b2038..93c3416 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -734,31 +734,6 @@ EncodingConvertfromObjCmd( return TCL_ERROR; } } -#ifdef OBSOLETE - if (result != TCL_INDEX_NONE && - TCL_ENCODING_PROFILE_GET(flags) != TCL_ENCODING_PROFILE_TCL8) { - if (failVarObj != NULL) { - if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } - } else { - char buf[TCL_INTEGER_SPACE]; - sprintf(buf, "%u", result); - Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected byte sequence starting at index %" - "u: '\\x%X'", result, UCHAR(bytesPtr[result]))); - Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", - buf, NULL); - Tcl_DStringFree(&ds); - return TCL_ERROR; - } - } - else if (failVarObj != NULL) { - if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(-1), TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } - } -#endif - /* * Note that we cannot use Tcl_DStringResult here because it will * truncate the string at the first null byte. @@ -855,33 +830,6 @@ EncodingConverttoObjCmd( return TCL_ERROR; } } -#ifdef OBSOLETE - if (result != TCL_INDEX_NONE && - TCL_ENCODING_PROFILE_GET(flags) != TCL_ENCODING_PROFILE_TCL8) { - if (failVarObj != NULL) { - /* I hope, wide int will cover size_t data type */ - if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(result), TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } - } else { - size_t pos = Tcl_NumUtfChars(stringPtr, result); - int ucs4; - char buf[TCL_INTEGER_SPACE]; - TclUtfToUCS4(&stringPtr[result], &ucs4); - sprintf(buf, "%u", result); - Tcl_SetObjResult(interp, Tcl_ObjPrintf("unexpected character at index %" - TCL_Z_MODIFIER "u: 'U+%06X'", pos, ucs4)); - Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", - buf, NULL); - Tcl_DStringFree(&ds); - return TCL_ERROR; - } - } else if (failVarObj != NULL) { - if (Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(-1), TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; - } - } -#endif Tcl_SetObjResult(interp, Tcl_NewByteArrayObj((unsigned char*) Tcl_DStringValue(&ds), -- cgit v0.12 From 10c559acbfbd8c8848e7f8fb9166e00e2aec2dc5 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 Feb 2023 21:20:21 +0000 Subject: Remove left-over traces of [0a74820b6d], which was merged into the apn-encoding-profile and landed into tip-656. This commit was merged premature into core-8-branch, leaving a [dab7fd5973|memory leak] --- generic/tclIO.c | 59 +------ generic/tclIOCmd.c | 25 +-- tests/io.test | 474 +++++++++++------------------------------------------ 3 files changed, 99 insertions(+), 459 deletions(-) diff --git a/generic/tclIO.c b/generic/tclIO.c index 880b669..b12adf6 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -4645,7 +4645,6 @@ Tcl_GetsObj( /* State info for channel */ ChannelBuffer *bufPtr; int inEofChar, skip, copiedTotal, oldFlags, oldRemoved; - int reportError = 0; int oldLength; Tcl_Encoding encoding; char *dst, *dstEnd, *eol, *eof; @@ -4654,7 +4653,6 @@ Tcl_GetsObj( if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { UpdateInterest(chanPtr); Tcl_SetErrno(EILSEQ); - ResetFlag(statePtr, CHANNEL_ENCODING_ERROR); return TCL_INDEX_NONE; } @@ -4914,19 +4912,6 @@ Tcl_GetsObj( goto done; } goto gotEOL; - } else if (gs.bytesWrote == 0 - && GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { - /* Set eol to the position that caused the encoding error, and then - * coninue to gotEOL, which stores the data that was decoded - * without error to objPtr. This allows the caller to do something - * useful with the data decoded so far, and also results in the - * position of the file being the first byte that was not - * succesfully decoded, allowing further processing at exactly that - * point, if desired. - */ - eol = dstEnd; - reportError = 1; - goto gotEOL; } dst = dstEnd; } @@ -4970,16 +4955,7 @@ Tcl_GetsObj( Tcl_SetObjLength(objPtr, eol - objPtr->bytes); CommonGetsCleanup(chanPtr); ResetFlag(statePtr, CHANNEL_BLOCKED); - if (reportError) { - ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR|CHANNEL_ENCODING_ERROR); - /* reset CHANNEL_ENCODING_ERROR to afford a chance to reconfigure - * the channel and try again - */ - Tcl_SetErrno(EILSEQ); - copiedTotal = -1; - } else { - copiedTotal = gs.totalChars + gs.charsWrote - skip; - } + copiedTotal = gs.totalChars + gs.charsWrote - skip; goto done; /* @@ -6007,9 +5983,8 @@ DoReadChars( } if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR)) { - /* TODO: UpdateInterest not needed here? */ + /* TODO: We don't need this call? */ UpdateInterest(chanPtr); - Tcl_SetErrno(EILSEQ); return -1; } @@ -6025,7 +6000,7 @@ DoReadChars( assert(statePtr->inputEncodingFlags & TCL_ENCODING_END); assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR)); - /* TODO: UpdateInterest not needed here? */ + /* TODO: We don't need this call? */ UpdateInterest(chanPtr); return 0; } @@ -6039,7 +6014,7 @@ DoReadChars( } ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF); statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; - /* TODO: UpdateInterest not needed here? */ + /* TODO: We don't need this call? */ UpdateInterest(chanPtr); return 0; } @@ -6070,7 +6045,7 @@ DoReadChars( } /* - * Recycle current buffer if empty. + * If the current buffer is empty recycle it. */ bufPtr = statePtr->inQueueHead; @@ -6083,24 +6058,6 @@ DoReadChars( statePtr->inQueueTail = NULL; } } - - /* - * If CHANNEL_ENCODING_ERROR and CHANNEL_STICKY_EOF are both set, - * then CHANNEL_ENCODING_ERROR was caused by data that occurred - * after the EOF character was encountered, so it doesn't count as - * a real error. - */ - - if (GotFlag(statePtr, CHANNEL_ENCODING_ERROR) - && !GotFlag(statePtr, CHANNEL_STICKY_EOF) - && !GotFlag(statePtr, CHANNEL_NONBLOCKING)) { - /* Channel is synchronous. Return an error so that callers - * like [read] can return an error. - */ - Tcl_SetErrno(EILSEQ); - copied = -1; - goto finish; - } } if (copiedNow < 0) { @@ -6129,7 +6086,6 @@ DoReadChars( } } -finish: /* * Failure to fill a channel buffer may have left channel reporting a * "blocked" state, but so long as we fulfilled the request here, the @@ -6793,14 +6749,11 @@ TranslateInputEOL( * EOF character was seen in EOL translated range. Leave current file * position pointing at the EOF character, but don't store the EOF * character in the output string. - * - * If CHANNEL_ENCODING_ERROR is set, it can only be because of data - * encountered after the EOF character, so it is nonsense. Unset it. */ SetFlag(statePtr, CHANNEL_EOF | CHANNEL_STICKY_EOF); statePtr->inputEncodingFlags |= TCL_ENCODING_END; - ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR|CHANNEL_ENCODING_ERROR); + ResetFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR); } } diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 507e06c..e8a534f 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -296,9 +296,6 @@ Tcl_GetsObjCmd( int lineLen; /* Length of line just read. */ int mode; /* Mode in which channel is opened. */ Tcl_Obj *linePtr, *chanObjPtr; - /* - Tcl_Obj *resultDictPtr, *returnOptsPtr; - */ int code = TCL_OK; if ((objc != 2) && (objc != 3)) { @@ -321,6 +318,7 @@ Tcl_GetsObjCmd( lineLen = Tcl_GetsObj(chan, linePtr); if (lineLen < 0) { if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { + Tcl_DecrRefCount(linePtr); /* * TIP #219. @@ -334,15 +332,6 @@ Tcl_GetsObjCmd( "error reading \"%s\": %s", TclGetString(chanObjPtr), Tcl_PosixError(interp))); } - /* - resultDictPtr = Tcl_NewDictObj(); - Tcl_DictObjPut(NULL, resultDictPtr, Tcl_NewStringObj("read", -1) - , linePtr); - returnOptsPtr = Tcl_NewDictObj(); - Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-result", -1) - , resultDictPtr); - Tcl_SetReturnOptions(interp, returnOptsPtr); - */ code = TCL_ERROR; goto done; } @@ -393,9 +382,6 @@ Tcl_ReadObjCmd( int charactersRead; /* How many characters were read? */ int mode; /* Mode in which channel is opened. */ Tcl_Obj *resultPtr, *chanObjPtr; - /* - Tcl_Obj *resultDictPtr, *returnOptsPtr; - */ if ((objc != 2) && (objc != 3)) { Interp *iPtr; @@ -484,17 +470,8 @@ Tcl_ReadObjCmd( "error reading \"%s\": %s", TclGetString(chanObjPtr), Tcl_PosixError(interp))); } - /* - resultDictPtr = Tcl_NewDictObj(); - Tcl_DictObjPut(NULL, resultDictPtr, Tcl_NewStringObj("read", -1) - , resultPtr); - returnOptsPtr = Tcl_NewDictObj(); - Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-result", -1) - , resultDictPtr); TclChannelRelease(chan); Tcl_DecrRefCount(resultPtr); - Tcl_SetReturnOptions(interp, returnOptsPtr); - */ return TCL_ERROR; } diff --git a/tests/io.test b/tests/io.test index 0f47a8e..4578a93 100644 --- a/tests/io.test +++ b/tests/io.test @@ -1547,53 +1547,19 @@ test io-12.8 {ReadChars: multibyte chars split} { close $f scan [string index $in end] %c } 160 - - -apply [list {} { - set template { - test io-12.9.@variant@ {ReadChars: multibyte chars split, default (strict)} -body { - set res {} - set f [open $path(test1) w] - fconfigure $f -translation binary - puts -nonewline $f [string repeat a 9]\xC2 - close $f - set f [open $path(test1)] - fconfigure $f -encoding utf-8 @strict@ -buffersize 10 - set status [catch {read $f} cres copts] - #set in [dict get $copts -result] - #lappend res $in - lappend res $status $cres - set status [catch {read $f} cres copts] - #set in [dict get $copts -result] - #lappend res $in - lappend res $status $cres - set res - } -cleanup { - catch {close $f} - } -match glob\ - } - - #append template {\ - # -result {{read aaaaaaaaa} 1\ - # {error reading "*": illegal byte sequence}\ - # {read {}} 1 {error reading "*": illegal byte sequence}} - #} - - append template {\ - -result {1\ - {error reading "*": illegal byte sequence}\ - 1 {error reading "*": illegal byte sequence}} - } - - # strict encoding may be the default in Tcl 9, but in 8 it is not - foreach variant {encodingstrict} strict {{-encodingprofile strict}} { - set script [string map [ - list @variant@ $variant @strict@ $strict] $template] - uplevel 1 $script - } -} [namespace current]] - - +test io-12.9 {ReadChars: multibyte chars split} -body { + set f [open $path(test1) w] + fconfigure $f -translation binary + puts -nonewline $f [string repeat a 9]\xC2 + close $f + set f [open $path(test1)] + fconfigure $f -encoding utf-8 -buffersize 10 + set in [read $f] + close $f + scan [string index $in end] %c +} -cleanup { + catch {close $f} +} -result 194 test io-12.10 {ReadChars: multibyte chars split} -body { set f [open $path(test1) w] fconfigure $f -translation binary @@ -9177,136 +9143,68 @@ test io-75.5 {invalid utf-8 encoding read is ignored (-encodingprofile tcl8)} -s removeFile io-75.5 } -result 4181 +test io-75.6 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} -setup { + set fn [makeFile {} io-75.6] + set f [open $fn w+] + fconfigure $f -encoding binary + # \x81 is invalid in utf-8 + puts -nonewline $f A\x81 + flush $f + seek $f 0 + fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -strictencoding 1 +} -body { + set d [read $f] + binary scan $d H* hd + lappend hd [catch {read $f} msg] + close $f + lappend hd $msg +} -cleanup { + removeFile io-75.6 +} -match glob -result {41 1 {error reading "*": illegal byte sequence}} -apply [list {} { - - - set test { - test io-75.6 {invalid utf-8 encoding read is not ignored (-encodingprofile strict)} -setup { - set hd {} - set fn [makeFile {} io-75.6] - set f [open $fn w+] - fconfigure $f -encoding binary - # \x81 is invalid in utf-8 - puts -nonewline $f A\x81 - flush $f - seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -encodingprofile strict - } -body { - set status [catch {read $f} cres copts] - #set d [dict get $copts -result read] - #binary scan $d H* hd - lappend hd $status $cres - } -cleanup { - close $f - removeFile io-75.6 - } -match glob\ - } - - #append test {\ - # -result {41 1 {error reading "*": illegal byte sequence}} - #} - - append test {\ - -result {1 {error reading "*": illegal byte sequence}} - } - - uplevel 1 $test - - set test { - test io-75.7 {invalid utf-8 encoding eof handling (-encodingprofile strict)} -setup { - set hd {} - set fn [makeFile {} io-75.7] - set f [open $fn w+] - fconfigure $f -encoding binary - # \xA1 is invalid in utf-8. -eofchar is not detected, because it comes later. - puts -nonewline $f A\xA1\x1A - flush $f - seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -encodingprofile strict - } -body { - set status [catch {read $f} cres copts] - #set d [dict get $copts -result read] - #binary scan $d H* hd - lappend hd [eof $f] - lappend hd $status - lappend hd $cres - fconfigure $f -encoding iso8859-1 - lappend hd [read $f];# We changed encoding, so now we can read the \xA1 - close $f - set hd - } -cleanup { - removeFile io-75.7 - } -match glob\ - } - - #append test {\ - # -result {41 0 1 {error reading "*": illegal byte sequence} ¡} - #} - - append test {\ - -result {0 1 {error reading "*": illegal byte sequence} ¡} - } - - uplevel 1 $test - - -} [namespace current]] - - - -test io-75.8.incomplete { - incomplete uft-8 char after eof char is not an error (-encodingprofile strict) -} -setup { - set hd {} - set fn [makeFile {} io-75.8] +test io-75.7 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { + set fn [makeFile {} io-75.7] set f [open $fn w+] fconfigure $f -encoding binary - # \x81 is invalid and also incomplete utf-8 data, but because the eof - # character \x1A appears first, it's not an error. - puts -nonewline $f A\x1A\x81 + # \xA1 is invalid in utf-8. -eofchar is not detected, because it comes later. + puts -nonewline $f A\xA1\x1A flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -encodingprofile strict + fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -strictencoding 1 } -body { set d [read $f] binary scan $d H* hd lappend hd [eof $f] - # there should be no error on additional reads - lappend hd [read $f] + lappend hd [catch {read $f} msg] + lappend hd $msg + fconfigure $f -encoding iso8859-1 + lappend hd [read $f];# We changed encoding, so now we can read the \xA1 close $f set hd } -cleanup { - removeFile io-75.8 -} -result {41 1 {}} + removeFile io-75.7 +} -match glob -result {41 0 1 {error reading "*": illegal byte sequence} ¡} - -test io-75.8.invalid {invalid utf-8 after eof char is not an error (-encodingprofile strict)} -setup { - set res {} +test io-75.8 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { set fn [makeFile {} io-75.8] set f [open $fn w+] fconfigure $f -encoding binary - # \xc0\x80 is invalid utf-8 data, but because the eof character \x1A - # appears first, it's not an error. - puts -nonewline $f A\x1a\xc0\x80 + # \x81 is invalid in utf-8, but since \x1A comes first, -eofchar takes precedence. + puts -nonewline $f A\x1A\x81 flush $f seek $f 0 fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -encodingprofile strict } -body { set d [read $f] - foreach char [split $d {}] { - lappend res [format %x [scan $char %c]] - } - lappend res [eof $f] - # there should be no error on additional reads - lappend res [read $f] + binary scan $d H* hd + lappend hd [eof $f] + lappend hd [read $f] close $f - set res + set hd } -cleanup { removeFile io-75.8 } -result {41 1 {}} - test io-75.9 {unrepresentable character write passes and is replaced by ?} -setup { set fn [makeFile {} io-75.9] set f [open $fn w+] @@ -9321,7 +9219,9 @@ test io-75.9 {unrepresentable character write passes and is replaced by ?} -setu removeFile io-75.9 } -match glob -result [list {A} {error writing "*": illegal byte sequence}] - +# Incomplete sequence test. +# This error may IMHO only be detected with the close. +# But the read already returns the incomplete sequence. test io-75.10 {incomplete multibyte encoding read is ignored} -setup { set fn [makeFile {} io-75.10] set f [open $fn w+] @@ -9329,7 +9229,7 @@ test io-75.10 {incomplete multibyte encoding read is ignored} -setup { puts -nonewline $f A\xC0 flush $f seek $f 0 - fconfigure $f -encoding utf-8 -encodingprofile tcl8 -buffering none + fconfigure $f -encoding utf-8 -buffering none } -body { set d [read $f] close $f @@ -9338,135 +9238,39 @@ test io-75.10 {incomplete multibyte encoding read is ignored} -setup { } -cleanup { removeFile io-75.10 } -result 41c0 +# The current result returns the orphan byte as byte. +# This may be expected due to special utf-8 handling. +# As utf-8 has a special treatment in multi-byte decoding, also test another +# one. +test io-75.11 {shiftjis encoding error read results in raw bytes} -setup { + set fn [makeFile {} io-75.11] + set f [open $fn w+] + fconfigure $f -encoding binary + # In shiftjis, \x81 starts a two-byte sequence. + # But 2nd byte \xFF is not allowed + puts -nonewline $f A\x81\xFFA + flush $f + seek $f 0 + fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf -strictencoding 1 +} -body { + set d [read $f] + binary scan $d H* hd + lappend hd [catch {set d [read $f]} msg] + lappend hd $msg +} -cleanup { + close $f + removeFile io-75.11 +} -match glob -result {41 1 {error reading "*": illegal byte sequence}} -apply [list {} { - - set test { - test io-75.10_strict {incomplete multibyte encoding read is an error} -setup { - set res {} - set fn [makeFile {} io-75.10] - set f [open $fn w+] - fconfigure $f -encoding binary - puts -nonewline $f A\xC0 - flush $f - seek $f 0 - fconfigure $f -encoding utf-8 -encodingprofile strict -buffering none - } -body { - set status [catch {read $f} cres copts] - - #set d [dict get $copts -result read] - #binary scan $d H* hd - #lappend res $hd $cres - lappend res $cres - - chan configure $f -encoding iso8859-1 - - set d [read $f] - binary scan $d H* hd - lappend res $hd - close $f - return $res - } -cleanup { - removeFile io-75.10 - } -match glob\ - } - - #append test {\ - # -result {41 {error reading "*": illegal byte sequence} c0} - #} - - append test {\ - -result {{error reading "*": illegal byte sequence} c0} - } - - uplevel 1 $test - - - - set test { - # As utf-8 has a special treatment in multi-byte decoding, also test another - # one. - test io-75.11 {shiftjis encoding error read results in raw bytes} -setup { - set hd {} - set fn [makeFile {} io-75.11] - set f [open $fn w+] - fconfigure $f -encoding binary - # In shiftjis, \x81 starts a two-byte sequence. - # But 2nd byte \xFF is not allowed - puts -nonewline $f A\x81\xFFA - flush $f - seek $f 0 - fconfigure $f -encoding shiftjis -buffering none -eofchar "" \ - -translation lf -encodingprofile strict - } -body { - set status [catch {read $f} cres copts] - #set d [dict get $copts -result read] - #binary scan $d H* hd - lappend hd $status - lappend hd $cres - } -cleanup { - close $f - removeFile io-75.11 - } -match glob - } - - #append test {\ - # -result {41 1 {error reading "*": illegal byte sequence}} - #} - - append test {\ - -result {1 {error reading "*": illegal byte sequence}} - } - - - set test { - test io-75.12 {invalid utf-8 encoding read is an error} -setup { - set hd {} - set res {} - set fn [makeFile {} io-75.12] - set f [open $fn w+] - fconfigure $f -encoding binary - puts -nonewline $f A\x81 - flush $f - seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf \ - -encodingprofile strict - } -body { - set status [catch {read $f} cres copts] - #set d [dict get $copts -result read] - #binary scan $d H* hd - #lappend res $hd - lappend res $status $cres - return $res - } -cleanup { - catch {close $f} - removeFile io-75.12 - } -match glob\ - } - - #append test {\ - # -result {41 1 {error reading "*": illegal byte sequence}} - #} - - - append test {\ - -result {1 {error reading "*": illegal byte sequence}} - } - - uplevel 1 $test -} [namespace current]] - - -test io-75.12_ignore {invalid utf-8 encoding read is ignored} -setup { +test io-75.12 {invalid utf-8 encoding read is ignored} -setup { set fn [makeFile {} io-75.12] set f [open $fn w+] fconfigure $f -encoding binary puts -nonewline $f A\x81 flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar {} \ - -translation lf -encodingprofile tcl8 + fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf } -body { set d [read $f] close $f @@ -9475,121 +9279,27 @@ test io-75.12_ignore {invalid utf-8 encoding read is ignored} -setup { } -cleanup { removeFile io-75.12 } -result 4181 - - -apply [list {} { - - set test { - test io-75.13 {invalid utf-8 encoding read is not ignored (-encodingprofile strict)} -setup { - set hd {} - set fn [makeFile {} io-75.13] - set f [open $fn w+] - fconfigure $f -encoding binary - # \x81 is invalid in utf-8 - puts -nonewline $f A\x81 - flush $f - seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar "" \ - -translation lf -encodingprofile strict - } -body { - set status [catch {read $f} cres copts] - #set d [dict get $copts -result read] - #binary scan $d H* hd - lappend hd $status - lappend hd $cres - } -cleanup { - catch {close $f} - removeFile io-75.13 - } -match glob\ - } - - #append test {\ - # -result {41 1 {error reading "*": illegal byte sequence}} - #} - - append test {\ - -result {1 {error reading "*": illegal byte sequence}} - } - - uplevel 1 $test - - set test { - } - -} [namespace current]] - - -test io-75.14 { - invalid utf-8 encoding [gets] continues in non-strict mode after error -} -setup { - set res {} - set fn [makeFile {} io-75.14] +test io-75.13 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} -setup { + set fn [makeFile {} io-75.13] set f [open $fn w+] - fconfigure $f -translation binary - # \xc0 is invalid in utf-8 - puts -nonewline $f a\nb\xc0\nc\n + fconfigure $f -encoding binary + # \x81 is invalid in utf-8 + puts -nonewline $f "A\x81" flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf -encodingprofile strict + fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -strictencoding 1 } -body { - lappend res [gets $f] - set status [catch {gets $f} cres copts] - lappend res $status $cres - chan configure $f -encodingprofile tcl8 - lappend res [gets $f] - lappend res [gets $f] - close $f - return $res + set d [read $f] + binary scan $d H* hd + lappend hd [catch {read $f} msg] + close $f + lappend hd $msg } -cleanup { - removeFile io-75.14 -} -match glob -result {a 1 {error reading "*": illegal byte sequence} bÀ c} - - - -apply [list {} { - set test { - test io-75.15 {invalid utf-8 encoding strict gets should not hang} -setup { - set res {} - set fn [makeFile {} io-75.15] - set chan [open $fn w+] - fconfigure $chan -encoding binary - # This is not valid UTF-8 - puts $chan hello\nAB\xc0\x40CD\nEFG - close $chan - } -body { - #Now try to read it with [gets] - set chan [open $fn] - fconfigure $chan -encoding utf-8 -encodingprofile strict - lappend res [gets $chan] - set status [catch {gets $chan} cres copts] - lappend res $status $cres - set status [catch {gets $chan} cres copts] - lappend res $status $cres - #lappend res [dict get $copts -result] - chan configur $chan -encoding binary - foreach char [split [read $chan 2] {}] { - lappend res [format %x [scan $char %c]] - } - return $res - } -cleanup { - close $chan - removeFile io-75.15 - } -match glob\ - } + removeFile io-75.13 +} -match glob -result {41 1 {error reading "*": illegal byte sequence}} - #append test {\ - # -result {hello 1 {error reading "*": illegal byte sequence}\ - # 1 {error reading "*": illegal byte sequence} {read AB} c0 40} - #} - - append test {\ - -result {hello 1 {error reading "*": illegal byte sequence}\ - 1 {error reading "*": illegal byte sequence} c0 40} - } - - uplevel 1 $test +# ### ### ### ######### ######### ######### -} [namespace current]] test io-76.0 {channel modes} -setup { -- cgit v0.12 From 6caf48437905145c68bd35e5c12819a86540b235 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 23 Feb 2023 21:31:04 +0000 Subject: -strictencoding 1 -> -encodingprofile strict (since the testcases placed back in previous commit didn't have that yet) --- tests/io.test | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/io.test b/tests/io.test index 4578a93..a8f7bc7 100644 --- a/tests/io.test +++ b/tests/io.test @@ -9143,7 +9143,7 @@ test io-75.5 {invalid utf-8 encoding read is ignored (-encodingprofile tcl8)} -s removeFile io-75.5 } -result 4181 -test io-75.6 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} -setup { +test io-75.6 {invalid utf-8 encoding read is not ignored (-encodingprofile strict)} -setup { set fn [makeFile {} io-75.6] set f [open $fn w+] fconfigure $f -encoding binary @@ -9151,7 +9151,7 @@ test io-75.6 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} -s puts -nonewline $f A\x81 flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -strictencoding 1 + fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -encodingprofile strict } -body { set d [read $f] binary scan $d H* hd @@ -9162,7 +9162,7 @@ test io-75.6 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} -s removeFile io-75.6 } -match glob -result {41 1 {error reading "*": illegal byte sequence}} -test io-75.7 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { +test io-75.7 {invalid utf-8 encoding eof handling (-encodingprofile strict)} -setup { set fn [makeFile {} io-75.7] set f [open $fn w+] fconfigure $f -encoding binary @@ -9170,7 +9170,7 @@ test io-75.7 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { puts -nonewline $f A\xA1\x1A flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -strictencoding 1 + fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -encodingprofile strict } -body { set d [read $f] binary scan $d H* hd @@ -9185,7 +9185,7 @@ test io-75.7 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { removeFile io-75.7 } -match glob -result {41 0 1 {error reading "*": illegal byte sequence} ¡} -test io-75.8 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup { +test io-75.8 {invalid utf-8 encoding eof handling (-encodingprofile strict)} -setup { set fn [makeFile {} io-75.8] set f [open $fn w+] fconfigure $f -encoding binary @@ -9252,7 +9252,7 @@ test io-75.11 {shiftjis encoding error read results in raw bytes} -setup { puts -nonewline $f A\x81\xFFA flush $f seek $f 0 - fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf -strictencoding 1 + fconfigure $f -encoding shiftjis -buffering none -eofchar "" -translation lf -encodingprofile strict } -body { set d [read $f] binary scan $d H* hd @@ -9279,7 +9279,7 @@ test io-75.12 {invalid utf-8 encoding read is ignored} -setup { } -cleanup { removeFile io-75.12 } -result 4181 -test io-75.13 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} -setup { +test io-75.13 {invalid utf-8 encoding read is not ignored (-encodingprofile strict)} -setup { set fn [makeFile {} io-75.13] set f [open $fn w+] fconfigure $f -encoding binary @@ -9287,7 +9287,7 @@ test io-75.13 {invalid utf-8 encoding read is not ignored (-strictencoding 1)} - puts -nonewline $f "A\x81" flush $f seek $f 0 - fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -strictencoding 1 + fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -encodingprofile strict } -body { set d [read $f] binary scan $d H* hd -- cgit v0.12 From 485bc2fd887abb2501321c670e66c849da1b026c Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 24 Feb 2023 03:35:31 +0000 Subject: Bug [40c61a5d10]. Fix syntax error message. --- generic/tclCmdAH.c | 11 ++++++----- tests/cmdAH.test | 4 ++-- tests/safe.test | 8 ++++---- 3 files changed, 12 insertions(+), 11 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 93c3416..19a5bc3 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -585,11 +585,12 @@ EncodingConvertParseOptions ( if (objc == 1) { numArgsError: /* ONLY jump here if nothing needs to be freed!!! */ - Tcl_WrongNumArgs( - interp, - 1, - objv, - "? ?-profile profile? ?-failindex var? encoding ? data"); + Tcl_WrongNumArgs(interp, + 1, + objv, + "?-profile profile? ?-failindex var? encoding data"); + ((Interp *)interp)->flags |= INTERP_ALTERNATE_WRONG_ARGS; + Tcl_WrongNumArgs(interp, 1, objv, "data"); return TCL_ERROR; } diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 471d46a..ba78c23 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -175,8 +175,8 @@ test cmdAH-3.2 {Tcl_ContinueObjCmd, success} { # encoding command set "numargErrors(encoding system)" {^wrong # args: should be "(encoding |::tcl::encoding::)system \?encoding\?"$} -set "numargErrors(encoding convertfrom)" {^wrong # args: should be "(encoding |::tcl::encoding::)convertfrom \? \?-profile profile\? \?-failindex var\? encoding \? data"$} -set "numargErrors(encoding convertto)" {^wrong # args: should be "(encoding |::tcl::encoding::)convertto \? \?-profile profile\? \?-failindex var\? encoding \? data"$} +set "numargErrors(encoding convertfrom)" {wrong # args: should be "(encoding |::tcl::encoding::)convertfrom \?-profile profile\? \?-failindex var\? encoding data" or "(encoding |::tcl::encoding::)convertfrom data"} +set "numargErrors(encoding convertto)" {wrong # args: should be "(encoding |::tcl::encoding::)convertto \?-profile profile\? \?-failindex var\? encoding data" or "(encoding |::tcl::encoding::)convertto data"} set "numargErrors(encoding names)" {wrong # args: should be "encoding names"} set "numargErrors(encoding profiles)" {wrong # args: should be "encoding profiles"} diff --git a/tests/safe.test b/tests/safe.test index 8c8382a..f3890b7 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -1473,7 +1473,7 @@ test safe-11.7 {testing safe encoding} -setup { interp eval $i encoding convertfrom } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ??-profile profile? ?-failindex var? ?encoding?? data"} +} -result {wrong # args: should be "encoding convertfrom ?-profile profile? ?-failindex var? encoding data" or "encoding convertfrom data"} test safe-11.7.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1482,7 +1482,7 @@ test safe-11.7.1 {testing safe encoding} -setup { } -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertfrom ??-profile profile? ?-failindex var? ?encoding?? data" +} -result {wrong # args: should be "encoding convertfrom ?-profile profile? ?-failindex var? encoding data" or "encoding convertfrom data" while executing "encoding convertfrom" invoked from within @@ -1495,7 +1495,7 @@ test safe-11.8 {testing safe encoding} -setup { interp eval $i encoding convertto } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ??-profile profile? ?-failindex var? ?encoding?? data"} +} -result {wrong # args: should be "encoding convertto ?-profile profile? ?-failindex var? encoding data" or "encoding convertto data"} test safe-11.8.1 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -1504,7 +1504,7 @@ test safe-11.8.1 {testing safe encoding} -setup { } -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i -} -result {wrong # args: should be "encoding convertto ??-profile profile? ?-failindex var? ?encoding?? data" +} -result {wrong # args: should be "encoding convertto ?-profile profile? ?-failindex var? encoding data" or "encoding convertto data" while executing "encoding convertto" invoked from within -- cgit v0.12 From 1c3c25097b1f63d6b1a0446c2c441833c4ecec11 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Fri, 24 Feb 2023 08:25:27 +0000 Subject: int -> Tcl_Size in tclEncoding.c (making the diff between Tcl 8.7 and 9.0 smaller) --- generic/tclEncoding.c | 54 +++++++++++++++++++++++++-------------------------- 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 8e13b43..f32baac 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -36,7 +36,7 @@ typedef struct { * encoding is deleted. */ void *clientData; /* Arbitrary value associated with encoding * type. Passed to conversion functions. */ - int nullSize; /* Number of 0x00 bytes that signify + Tcl_Size nullSize; /* Number of 0x00 bytes that signify * end-of-string in this encoding. This number * is used to determine the source string * length when the srcLen argument is @@ -374,7 +374,7 @@ int Tcl_SetEncodingSearchPath( Tcl_Obj *searchPath) { - int dummy; + Tcl_Size dummy; if (TCL_ERROR == TclListObjLengthM(NULL, searchPath, &dummy)) { return TCL_ERROR; @@ -421,7 +421,7 @@ void TclSetLibraryPath( Tcl_Obj *path) { - int dummy; + Tcl_Size dummy; if (TCL_ERROR == TclListObjLengthM(NULL, path, &dummy)) { return; @@ -457,7 +457,7 @@ TclSetLibraryPath( static void FillEncodingFileMap(void) { - int i, numDirs = 0; + Tcl_Size i, numDirs = 0; Tcl_Obj *map, *searchPath; searchPath = Tcl_GetEncodingSearchPath(); @@ -472,7 +472,7 @@ FillEncodingFileMap(void) * entries found, we favor files earlier on the search path. */ - int j, numFiles; + Tcl_Size j, numFiles; Tcl_Obj *directory, *matchFileList; Tcl_Obj **filev; Tcl_GlobTypeData readableFiles = { @@ -1005,7 +1005,7 @@ Tcl_GetEncodingNames( * *--------------------------------------------------------------------------- */ -int +Tcl_Size Tcl_GetEncodingNulLength( Tcl_Encoding encoding) { @@ -1171,7 +1171,7 @@ Tcl_ExternalToUtfDString( Tcl_Encoding encoding, /* The encoding for the source string, or NULL * for the default system encoding. */ const char *src, /* Source string in specified encoding. */ - int srcLen, /* Source string length in bytes, or < 0 for + Tcl_Size srcLen, /* Source string length in bytes, or < 0 for * encoding-specific string length. */ Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ @@ -1210,12 +1210,12 @@ Tcl_ExternalToUtfDString( *------------------------------------------------------------------------- */ -int +Tcl_Size Tcl_ExternalToUtfDStringEx( Tcl_Encoding encoding, /* The encoding for the source string, or NULL * for the default system encoding. */ const char *src, /* Source string in specified encoding. */ - int srcLen, /* Source string length in bytes, or < 0 for + Tcl_Size srcLen, /* Source string length in bytes, or < 0 for * encoding-specific string length. */ int flags, /* Conversion control flags. */ Tcl_DString *dstPtr) /* Uninitialized or free DString in which the @@ -1224,7 +1224,8 @@ Tcl_ExternalToUtfDStringEx( char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; - int dstLen, result, soFar, srcRead, dstWrote, dstChars; + int result, soFar, srcRead, dstWrote, dstChars; + Tcl_Size dstLen; const char *srcStart = src; Tcl_DStringInit(dstPtr); @@ -1255,7 +1256,7 @@ Tcl_ExternalToUtfDStringEx( src += srcRead; if (result != TCL_CONVERT_NOSPACE) { Tcl_DStringSetLength(dstPtr, soFar); - return (result == TCL_OK) ? TCL_INDEX_NONE : (int)(src - srcStart); + return (result == TCL_OK) ? TCL_INDEX_NONE : (Tcl_Size)(src - srcStart); } flags &= ~TCL_ENCODING_START; srcLen -= srcRead; @@ -1292,7 +1293,7 @@ Tcl_ExternalToUtf( Tcl_Encoding encoding, /* The encoding for the source string, or NULL * for the default system encoding. */ const char *src, /* Source string in specified encoding. */ - int srcLen, /* Source string length in bytes, or < 0 for + Tcl_Size srcLen, /* Source string length in bytes, or < 0 for * encoding-specific string length. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state @@ -1302,7 +1303,7 @@ Tcl_ExternalToUtf( * routine under control of flags argument. */ char *dst, /* Output buffer in which converted string is * stored. */ - int dstLen, /* The maximum length of output buffer in + Tcl_Size dstLen, /* The maximum length of output buffer in * bytes. */ int *srcReadPtr, /* Filled with the number of bytes from the * source string that were converted. This may @@ -1409,7 +1410,7 @@ Tcl_UtfToExternalDString( Tcl_Encoding encoding, /* The encoding for the converted string, or * NULL for the default system encoding. */ const char *src, /* Source string in UTF-8. */ - int srcLen, /* Source string length in bytes, or < 0 for + Tcl_Size srcLen, /* Source string length in bytes, or < 0 for * strlen(). */ Tcl_DString *dstPtr) /* Uninitialized or free DString in which the * converted string is stored. */ @@ -1449,12 +1450,12 @@ Tcl_UtfToExternalDString( *------------------------------------------------------------------------- */ -int +Tcl_Size Tcl_UtfToExternalDStringEx( Tcl_Encoding encoding, /* The encoding for the converted string, or * NULL for the default system encoding. */ const char *src, /* Source string in UTF-8. */ - int srcLen, /* Source string length in bytes, or < 0 for + Tcl_Size srcLen, /* Source string length in bytes, or < 0 for * strlen(). */ int flags, /* Conversion control flags. */ Tcl_DString *dstPtr) /* Uninitialized or free DString in which the @@ -1465,7 +1466,7 @@ Tcl_UtfToExternalDStringEx( const Encoding *encodingPtr; int result, soFar, srcRead, dstWrote, dstChars; const char *srcStart = src; - int dstLen; + Tcl_Size dstLen; Tcl_DStringInit(dstPtr); dst = Tcl_DStringValue(dstPtr); @@ -1494,7 +1495,7 @@ Tcl_UtfToExternalDStringEx( while (i >= soFar) { Tcl_DStringSetLength(dstPtr, i--); } - return (result == TCL_OK) ? TCL_INDEX_NONE : (int)(src - srcStart); + return (result == TCL_OK) ? TCL_INDEX_NONE : (Tcl_Size)(src - srcStart); } flags &= ~TCL_ENCODING_START; @@ -1532,7 +1533,7 @@ Tcl_UtfToExternal( Tcl_Encoding encoding, /* The encoding for the converted string, or * NULL for the default system encoding. */ const char *src, /* Source string in UTF-8. */ - int srcLen, /* Source string length in bytes, or < 0 for + Tcl_Size srcLen, /* Source string length in bytes, or < 0 for * strlen(). */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state @@ -1542,7 +1543,7 @@ Tcl_UtfToExternal( * routine under control of flags argument. */ char *dst, /* Output buffer in which converted string * is stored. */ - int dstLen, /* The maximum length of output buffer in + Tcl_Size dstLen, /* The maximum length of output buffer in * bytes. */ int *srcReadPtr, /* Filled with the number of bytes from the * source string that were converted. This may @@ -1653,7 +1654,7 @@ OpenEncodingFileChannel( Tcl_Obj *map = TclGetProcessGlobalValue(&encodingFileMap); Tcl_Obj **dir, *path, *directory = NULL; Tcl_Channel chan = NULL; - int i, numDirs; + Tcl_Size i, numDirs; TclListObjGetElementsM(NULL, searchPath, &numDirs, &dir); Tcl_IncrRefCount(nameObj); @@ -1918,7 +1919,7 @@ LoadTableEncoding( for (i = 0; i < numPages; i++) { int ch; const char *p; - int expected = 3 + 16 * (16 * 4 + 1); + Tcl_Size expected = 3 + 16 * (16 * 4 + 1); if (Tcl_ReadChars(chan, objPtr, expected, 0) != expected) { return NULL; @@ -2154,7 +2155,7 @@ LoadEscapeEncoding( Tcl_DStringInit(&escapeData); while (1) { - int argc; + Tcl_Size argc; const char **argv; char *line; Tcl_DString lineString; @@ -3919,8 +3920,7 @@ EscapeFromUtfProc( result = TCL_CONVERT_NOSPACE; break; } - memcpy(dst, subTablePtr->sequence, - subTablePtr->sequenceLen); + memcpy(dst, subTablePtr->sequence, subTablePtr->sequenceLen); dst += subTablePtr->sequenceLen; } } @@ -4138,11 +4138,11 @@ unilen4( static void InitializeEncodingSearchPath( char **valuePtr, - unsigned int *lengthPtr, + TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr) { const char *bytes; - int i, numDirs, numBytes; + Tcl_Size i, numDirs, numBytes; Tcl_Obj *libPathObj, *encodingObj, *searchPathObj; TclNewLiteralStringObj(encodingObj, "encoding"); -- cgit v0.12 From 854369a67c1719356d036c3fe11e052a7fe62e80 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 24 Feb 2023 09:35:09 +0000 Subject: Factor out encoding test vectors into separate file so they can be used for file IO tests --- tests/cmdAH.test | 634 +------------------------------------------- tests/encodingVectors.tcl | 655 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 656 insertions(+), 633 deletions(-) create mode 100644 tests/encodingVectors.tcl diff --git a/tests/cmdAH.test b/tests/cmdAH.test index ba78c23..cec93d2 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -180,640 +180,8 @@ set "numargErrors(encoding convertto)" {wrong # args: should be "(encoding |::tc set "numargErrors(encoding names)" {wrong # args: should be "encoding names"} set "numargErrors(encoding profiles)" {wrong # args: should be "encoding profiles"} -set encProfiles {tcl8 strict replace} -set encDefaultProfile tcl8; # Should reflect the default from implementation - -# TODO - valid sequences for different encodings - shiftjis etc. -# Note utf-16, utf-32 missing because they are automatically -# generated based on le/be versions. -lappend encValidStrings {*}{ - ascii \u0000 00 {} {Lowest ASCII} - ascii \u007F 7F knownBug {Highest ASCII} - ascii \u007D 7D {} {Brace - just to verify test scripts are escaped correctly} - ascii \u007B 7B {} {Terminating brace - just to verify test scripts are escaped correctly} - - utf-8 \u0000 00 {} {Unicode Table 3.7 Row 1} - utf-8 \u007F 7F {} {Unicode Table 3.7 Row 1} - utf-8 \u0080 C280 {} {Unicode Table 3.7 Row 2} - utf-8 \u07FF DFBF {} {Unicode Table 3.7 Row 2} - utf-8 \u0800 E0A080 {} {Unicode Table 3.7 Row 3} - utf-8 \u0FFF E0BFBF {} {Unicode Table 3.7 Row 3} - utf-8 \u1000 E18080 {} {Unicode Table 3.7 Row 4} - utf-8 \uCFFF ECBFBF {} {Unicode Table 3.7 Row 4} - utf-8 \uD000 ED8080 {} {Unicode Table 3.7 Row 5} - utf-8 \uD7FF ED9FBF {} {Unicode Table 3.7 Row 5} - utf-8 \uE000 EE8080 {} {Unicode Table 3.7 Row 6} - utf-8 \uFFFF EFBFBF {} {Unicode Table 3.7 Row 6} - utf-8 \U10000 F0908080 {} {Unicode Table 3.7 Row 7} - utf-8 \U3FFFF F0BFBFBF {} {Unicode Table 3.7 Row 7} - utf-8 \U40000 F1808080 {} {Unicode Table 3.7 Row 8} - utf-8 \UFFFFF F3BFBFBF {} {Unicode Table 3.7 Row 8} - utf-8 \U100000 F4808080 {} {Unicode Table 3.7 Row 9} - utf-8 \U10FFFF F48FBFBF {} {Unicode Table 3.7 Row 9} - utf-8 A\u03A9\u8A9E\U00010384 41CEA9E8AA9EF0908E84 {} {Unicode 2.5} - - utf-16le \u0000 0000 {} {Lowest code unit} - utf-16le \uD7FF FFD7 {} {Below high surrogate range} - utf-16le \uE000 00E0 {} {Above low surrogate range} - utf-16le \uFFFF FFFF {} {Highest code unit} - utf-16le \U010000 00D800DC {} {First surrogate pair} - utf-16le \U10FFFF FFDBFFDF {} {First surrogate pair} - utf-16le A\u03A9\u8A9E\U00010384 4100A9039E8A00D884DF {} {Unicode 2.5} - - utf-16be \u0000 0000 {} {Lowest code unit} - utf-16be \uD7FF D7FF {} {Below high surrogate range} - utf-16be \uE000 E000 {} {Above low surrogate range} - utf-16be \uFFFF FFFF {} {Highest code unit} - utf-16be \U010000 D800DC00 {} {First surrogate pair} - utf-16be \U10FFFF DBFFDFFF {} {First surrogate pair} - utf-16be A\u03A9\u8A9E\U00010384 004103A98A9ED800DF84 {} {Unicode 2.5} - - utf-32le \u0000 00000000 {} {Lowest code unit} - utf-32le \uFFFF FFFF0000 {} {Highest BMP} - utf-32le \U010000 00000100 {} {First supplementary} - utf-32le \U10FFFF ffff1000 {} {Last supplementary} - utf-32le A\u03A9\u8A9E\U00010384 41000000A90300009E8A000084030100 {} {Unicode 2.5} - - utf-32be \u0000 00000000 {} {Lowest code unit} - utf-32be \uFFFF 0000FFFF {} {Highest BMP} - utf-32be \U010000 00010000 {} {First supplementary} - utf-32be \U10FFFF 0010FFFF {} {Last supplementary} - utf-32be A\u03A9\u8A9E\U00010384 00000041000003A900008A9E00010384 {} {Unicode 2.5} -} - -# Invalid byte sequences. These are driven from a table with format -# {encoding bytes profile expectedresult expectedfailindex ctrl comment} -# -# should be unique for test ids to be unique. Note utf-16, -# utf-32 missing because they are automatically generated based on le/be -# versions. Each entry potentially results in generation of multiple tests. -# This is controlled by the ctrl field. This should be a list of -# zero or more of the following: -# solo - the test data is the string itself -# lead - the test data is the string followed by a valid suffix -# tail - the test data is the string preceded by a prefix -# middle - the test data is the string wrapped by a prefix and suffix -# If the ctrl field is empty it is treated as all of the above -# Note if there is any other value by itself, it will cause the test to -# be skipped. This is intentional to skip known bugs. -# TODO - non-UTF encodings - -# ascii - Any byte above 127 is invalid and is mapped -# to the same numeric code point except for the range -# 80-9F which is treated as cp1252. -# This tests the TableToUtfProc code path. -lappend encInvalidBytes {*}{ - ascii 80 tcl8 \u20AC -1 {knownBug} {map to cp1252} - ascii 80 replace \uFFFD -1 {} {Smallest invalid byte} - ascii 80 strict {} 0 {} {Smallest invalid byte} - ascii 81 tcl8 \u0081 -1 {knownBug} {map to cp1252} - ascii 82 tcl8 \u201A -1 {knownBug} {map to cp1252} - ascii 83 tcl8 \u0192 -1 {knownBug} {map to cp1252} - ascii 84 tcl8 \u201E -1 {knownBug} {map to cp1252} - ascii 85 tcl8 \u2026 -1 {knownBug} {map to cp1252} - ascii 86 tcl8 \u2020 -1 {knownBug} {map to cp1252} - ascii 87 tcl8 \u2021 -1 {knownBug} {map to cp1252} - ascii 88 tcl8 \u0276 -1 {knownBug} {map to cp1252} - ascii 89 tcl8 \u2030 -1 {knownBug} {map to cp1252} - ascii 8A tcl8 \u0160 -1 {knownBug} {map to cp1252} - ascii 8B tcl8 \u2039 -1 {knownBug} {map to cp1252} - ascii 8C tcl8 \u0152 -1 {knownBug} {map to cp1252} - ascii 8D tcl8 \u008D -1 {knownBug} {map to cp1252} - ascii 8E tcl8 \u017D -1 {knownBug} {map to cp1252} - ascii 8F tcl8 \u008F -1 {knownBug} {map to cp1252} - ascii 90 tcl8 \u0090 -1 {knownBug} {map to cp1252} - ascii 91 tcl8 \u2018 -1 {knownBug} {map to cp1252} - ascii 92 tcl8 \u2019 -1 {knownBug} {map to cp1252} - ascii 93 tcl8 \u201C -1 {knownBug} {map to cp1252} - ascii 94 tcl8 \u201D -1 {knownBug} {map to cp1252} - ascii 95 tcl8 \u2022 -1 {knownBug} {map to cp1252} - ascii 96 tcl8 \u2013 -1 {knownBug} {map to cp1252} - ascii 97 tcl8 \u2014 -1 {knownBug} {map to cp1252} - ascii 98 tcl8 \u02DC -1 {knownBug} {map to cp1252} - ascii 99 tcl8 \u2122 -1 {knownBug} {map to cp1252} - ascii 9A tcl8 \u0161 -1 {knownBug} {map to cp1252} - ascii 9B tcl8 \u203A -1 {knownBug} {map to cp1252} - ascii 9C tcl8 \u0153 -1 {knownBug} {map to cp1252} - ascii 9D tcl8 \u009D -1 {knownBug} {map to cp1252} - ascii 9E tcl8 \u017E -1 {knownBug} {map to cp1252} - ascii 9F tcl8 \u0178 -1 {knownBug} {map to cp1252} - - ascii FF tcl8 \u00FF -1 {} {Largest invalid byte} - ascii FF replace \uFFFD -1 {} {Largest invalid byte} - ascii FF strict {} 0 {} {Largest invalid byte} -} - -# utf-8 - valid sequences based on Table 3.7 in the Unicode -# standard. -# -# Code Points First Second Third Fourth Byte -# U+0000..U+007F 00..7F -# U+0080..U+07FF C2..DF 80..BF -# U+0800..U+0FFF E0 A0..BF 80..BF -# U+1000..U+CFFF E1..EC 80..BF 80..BF -# U+D000..U+D7FF ED 80..9F 80..BF -# U+E000..U+FFFF EE..EF 80..BF 80..BF -# U+10000..U+3FFFF F0 90..BF 80..BF 80..BF -# U+40000..U+FFFFF F1..F3 80..BF 80..BF 80..BF -# U+100000..U+10FFFF F4 80..8F 80..BF 80..BF -# -# Tests below are based on the "gaps" in the above table. Note ascii test -# values are repeated because internally a different code path is used -# (UtfToUtfProc). -# Note C0, C1, F5:FF are invalid bytes ANYWHERE. Exception is C080 -lappend encInvalidBytes {*}{ - utf-8 80 tcl8 \u20AC -1 {} {map to cp1252} - utf-8 80 replace \uFFFD -1 {} {Smallest invalid byte} - utf-8 80 strict {} 0 {} {Smallest invalid byte} - utf-8 81 tcl8 \u0081 -1 {} {map to cp1252} - utf-8 82 tcl8 \u201A -1 {} {map to cp1252} - utf-8 83 tcl8 \u0192 -1 {} {map to cp1252} - utf-8 84 tcl8 \u201E -1 {} {map to cp1252} - utf-8 85 tcl8 \u2026 -1 {} {map to cp1252} - utf-8 86 tcl8 \u2020 -1 {} {map to cp1252} - utf-8 87 tcl8 \u2021 -1 {} {map to cp1252} - utf-8 88 tcl8 \u02C6 -1 {} {map to cp1252} - utf-8 89 tcl8 \u2030 -1 {} {map to cp1252} - utf-8 8A tcl8 \u0160 -1 {} {map to cp1252} - utf-8 8B tcl8 \u2039 -1 {} {map to cp1252} - utf-8 8C tcl8 \u0152 -1 {} {map to cp1252} - utf-8 8D tcl8 \u008D -1 {} {map to cp1252} - utf-8 8E tcl8 \u017D -1 {} {map to cp1252} - utf-8 8F tcl8 \u008F -1 {} {map to cp1252} - utf-8 90 tcl8 \u0090 -1 {} {map to cp1252} - utf-8 91 tcl8 \u2018 -1 {} {map to cp1252} - utf-8 92 tcl8 \u2019 -1 {} {map to cp1252} - utf-8 93 tcl8 \u201C -1 {} {map to cp1252} - utf-8 94 tcl8 \u201D -1 {} {map to cp1252} - utf-8 95 tcl8 \u2022 -1 {} {map to cp1252} - utf-8 96 tcl8 \u2013 -1 {} {map to cp1252} - utf-8 97 tcl8 \u2014 -1 {} {map to cp1252} - utf-8 98 tcl8 \u02DC -1 {} {map to cp1252} - utf-8 99 tcl8 \u2122 -1 {} {map to cp1252} - utf-8 9A tcl8 \u0161 -1 {} {map to cp1252} - utf-8 9B tcl8 \u203A -1 {} {map to cp1252} - utf-8 9C tcl8 \u0153 -1 {} {map to cp1252} - utf-8 9D tcl8 \u009D -1 {} {map to cp1252} - utf-8 9E tcl8 \u017E -1 {} {map to cp1252} - utf-8 9F tcl8 \u0178 -1 {} {map to cp1252} - - utf-8 C0 tcl8 \u00C0 -1 {} {C0 is invalid anywhere} - utf-8 C0 strict {} 0 {} {C0 is invalid anywhere} - utf-8 C0 replace \uFFFD -1 {} {C0 is invalid anywhere} - utf-8 C080 tcl8 \u0000 -1 {} {C080 -> U+0 in Tcl's internal modified UTF8} - utf-8 C080 strict {} 0 {} {C080 -> invalid} - utf-8 C080 replace \uFFFD -1 {} {C080 -> single replacement char} - utf-8 C0A2 tcl8 \u00C0\u00A2 -1 {} {websec.github.io - A} - utf-8 C0A2 replace \uFFFD\uFFFD -1 {} {websec.github.io - A} - utf-8 C0A2 strict {} 0 {} {websec.github.io - A} - utf-8 C0A7 tcl8 \u00C0\u00A7 -1 {} {websec.github.io - double quote} - utf-8 C0A7 replace \uFFFD\uFFFD -1 {} {websec.github.io - double quote} - utf-8 C0A7 strict {} 0 {} {websec.github.io - double quote} - utf-8 C0AE tcl8 \u00C0\u00AE -1 {} {websec.github.io - full stop} - utf-8 C0AE replace \uFFFD\uFFFD -1 {} {websec.github.io - full stop} - utf-8 C0AE strict {} 0 {} {websec.github.io - full stop} - utf-8 C0AF tcl8 \u00C0\u00AF -1 {} {websec.github.io - solidus} - utf-8 C0AF replace \uFFFD\uFFFD -1 {} {websec.github.io - solidus} - utf-8 C0AF strict {} 0 {} {websec.github.io - solidus} - - utf-8 C1 tcl8 \u00C1 -1 {} {C1 is invalid everywhere} - utf-8 C1 replace \uFFFD -1 {} {C1 is invalid everywhere} - utf-8 C1 strict {} 0 {} {C1 is invalid everywhere} - utf-8 C181 tcl8 \u00C1\u0081 -1 {} {websec.github.io - base test (A)} - utf-8 C181 replace \uFFFD\uFFFD -1 {} {websec.github.io - base test (A)} - utf-8 C181 strict {} 0 {} {websec.github.io - base test (A)} - utf-8 C19C tcl8 \u00C1\u0153 -1 {} {websec.github.io - reverse solidus} - utf-8 C19C replace \uFFFD\uFFFD -1 {} {websec.github.io - reverse solidus} - utf-8 C19C strict {} 0 {} {websec.github.io - reverse solidus} - - utf-8 C2 tcl8 \u00C2 -1 {} {Missing trail byte} - utf-8 C2 replace \uFFFD -1 {} {Missing trail byte} - utf-8 C2 strict {} 0 {} {Missing trail byte} - utf-8 C27F tcl8 \u00C2\x7F -1 {} {Trail byte must be 80:BF} - utf-8 C27F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} - utf-8 C27F strict {} 0 {} {Trail byte must be 80:BF} - utf-8 DF tcl8 \u00DF -1 {} {Missing trail byte} - utf-8 DF replace \uFFFD -1 {} {Missing trail byte} - utf-8 DF strict {} 0 {} {Missing trail byte} - utf-8 DF7F tcl8 \u00DF\x7F -1 {} {Trail byte must be 80:BF} - utf-8 DF7F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} - utf-8 DF7F strict {} 0 {} {Trail byte must be 80:BF} - utf-8 DFE0A080 tcl8 \u00DF\u0800 -1 {} {Invalid trail byte is start of valid sequence} - utf-8 DFE0A080 replace \uFFFD\u0800 -1 {} {Invalid trail byte is start of valid sequence} - utf-8 DFE0A080 strict {} 0 {} {Invalid trail byte is start of valid sequence} - - utf-8 E0 tcl8 \u00E0 -1 {} {Missing trail byte} - utf-8 E0 replace \uFFFD -1 {} {Missing trail byte} - utf-8 E0 strict {} 0 {} {Missing trail byte} - utf-8 E080 tcl8 \u00E0\u20AC -1 {} {First trail byte must be A0:BF} - utf-8 E080 replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF} - utf-8 E080 strict {} 0 {} {First trail byte must be A0:BF} - utf-8 E0819C tcl8 \u00E0\u0081\u0153 -1 {} {websec.github.io - reverse solidus} - utf-8 E0819C replace \uFFFD\uFFFD\uFFFD -1 {} {websec.github.io - reverse solidus} - utf-8 E0819C strict {} 0 {} {websec.github.io - reverse solidus} - utf-8 E09F tcl8 \u00E0\u0178 -1 {} {First trail byte must be A0:BF} - utf-8 E09F replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF} - utf-8 E09F strict {} 0 {} {First trail byte must be A0:BF} - utf-8 E0A0 tcl8 \u00E0\u00A0 -1 {} {Missing second trail byte} - utf-8 E0A0 replace \uFFFD -1 {knownW3C} {Missing second trail byte} - utf-8 E0A0 strict {} 0 {} {Missing second trail byte} - utf-8 E0BF tcl8 \u00E0\u00BF -1 {} {Missing second trail byte} - utf-8 E0BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} - utf-8 E0BF strict {} 0 {} {Missing second trail byte} - utf-8 E0A07F tcl8 \u00E0\u00A0\x7F -1 {} {Second trail byte must be 80:BF} - utf-8 E0A07F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 E0A07F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 E0BF7F tcl8 \u00E0\u00BF\x7F -1 {} {Second trail byte must be 80:BF} - utf-8 E0BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 E0BF7F strict {} 0 {} {Second trail byte must be 80:BF} - - utf-8 E1 tcl8 \u00E1 -1 {} {Missing trail byte} - utf-8 E1 replace \uFFFD -1 {} {Missing trail byte} - utf-8 E1 strict {} 0 {} {Missing trail byte} - utf-8 E17F tcl8 \u00E1\x7F -1 {} {Trail byte must be 80:BF} - utf-8 E17F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} - utf-8 E17F strict {} 0 {} {Trail byte must be 80:BF} - utf-8 E181 tcl8 \u00E1\u0081 -1 {} {Missing second trail byte} - utf-8 E181 replace \uFFFD -1 {knownW3C} {Missing second trail byte} - utf-8 E181 strict {} 0 {} {Missing second trail byte} - utf-8 E1BF tcl8 \u00E1\u00BF -1 {} {Missing second trail byte} - utf-8 E1BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} - utf-8 E1BF strict {} 0 {} {Missing second trail byte} - utf-8 E1807F tcl8 \u00E1\u20AC\x7F -1 {} {Second trail byte must be 80:BF} - utf-8 E1807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 E1807F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 E1BF7F tcl8 \u00E1\u00BF\x7F -1 {} {Second trail byte must be 80:BF} - utf-8 E1BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 E1BF7F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 EC tcl8 \u00EC -1 {} {Missing trail byte} - utf-8 EC replace \uFFFD -1 {} {Missing trail byte} - utf-8 EC strict {} 0 {} {Missing trail byte} - utf-8 EC7F tcl8 \u00EC\x7F -1 {} {Trail byte must be 80:BF} - utf-8 EC7F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} - utf-8 EC7F strict {} 0 {} {Trail byte must be 80:BF} - utf-8 EC81 tcl8 \u00EC\u0081 -1 {} {Missing second trail byte} - utf-8 EC81 replace \uFFFD -1 {knownW3C} {Missing second trail byte} - utf-8 EC81 strict {} 0 {} {Missing second trail byte} - utf-8 ECBF tcl8 \u00EC\u00BF -1 {} {Missing second trail byte} - utf-8 ECBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} - utf-8 ECBF strict {} 0 {} {Missing second trail byte} - utf-8 EC807F tcl8 \u00EC\u20AC\x7F -1 {} {Second trail byte must be 80:BF} - utf-8 EC807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 EC807F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 ECBF7F tcl8 \u00EC\u00BF\x7F -1 {} {Second trail byte must be 80:BF} - utf-8 ECBF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 ECBF7F strict {} 0 {} {Second trail byte must be 80:BF} - - utf-8 ED tcl8 \u00ED -1 {} {Missing trail byte} - utf-8 ED replace \uFFFD -1 {} {Missing trail byte} - utf-8 ED strict {} 0 {} {Missing trail byte} - utf-8 ED7F tcl8 \u00ED\u7F -1 {} {First trail byte must be 80:9F} - utf-8 ED7F replace \uFFFD\u7F -1 {} {First trail byte must be 80:9F} - utf-8 ED7F strict {} 0 {} {First trail byte must be 80:9F} - utf-8 EDA0 tcl8 \u00ED\u00A0 -1 {} {First trail byte must be 80:9F} - utf-8 EDA0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:9F} - utf-8 EDA0 strict {} 0 {} {First trail byte must be 80:9F} - utf-8 ED81 tcl8 \u00ED\u0081 -1 {} {Missing second trail byte} - utf-8 ED81 replace \uFFFD -1 {knownW3C} {Missing second trail byte} - utf-8 ED81 strict {} 0 {} {Missing second trail byte} - utf-8 EDBF tcl8 \u00ED\u00BF -1 {} {Missing second trail byte} - utf-8 EDBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} - utf-8 EDBF strict {} 0 {} {Missing second trail byte} - utf-8 ED807F tcl8 \u00ED\u20AC\x7F -1 {} {Second trail byte must be 80:BF} - utf-8 ED807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 ED807F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 ED9F7F tcl8 \u00ED\u0178\x7F -1 {} {Second trail byte must be 80:BF} - utf-8 ED9F7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 ED9F7F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 EDA080 tcl8 \uD800 -1 {} {High surrogate} - utf-8 EDA080 replace \uFFFD -1 {} {High surrogate} - utf-8 EDA080 strict {} 0 {} {High surrogate} - utf-8 EDAFBF tcl8 \uDBFF -1 {} {High surrogate} - utf-8 EDAFBF replace \uFFFD -1 {} {High surrogate} - utf-8 EDAFBF strict {} 0 {} {High surrogate} - utf-8 EDB080 tcl8 \uDC00 -1 {} {Low surrogate} - utf-8 EDB080 replace \uFFFD -1 {} {Low surrogate} - utf-8 EDB080 strict {} 0 {} {Low surrogate} - utf-8 EDBFBF tcl8 \uDFFF -1 {} {Low surrogate} - utf-8 EDBFBF replace \uFFFD -1 {} {Low surrogate} - utf-8 EDBFBF strict {} 0 {} {Low surrogate} - utf-8 EDA080EDB080 tcl8 \U00010000 -1 {} {High low surrogate pair} - utf-8 EDA080EDB080 replace \uFFFD\uFFFD -1 {} {High low surrogate pair} - utf-8 EDA080EDB080 strict {} 0 {} {High low surrogate pair} - utf-8 EDAFBFEDBFBF tcl8 \U0010FFFF -1 {} {High low surrogate pair} - utf-8 EDAFBFEDBFBF replace \uFFFD\uFFFD -1 {} {High low surrogate pair} - utf-8 EDAFBFEDBFBF strict {} 0 {} {High low surrogate pair} - - utf-8 EE tcl8 \u00EE -1 {} {Missing trail byte} - utf-8 EE replace \uFFFD -1 {} {Missing trail byte} - utf-8 EE strict {} 0 {} {Missing trail byte} - utf-8 EE7F tcl8 \u00EE\u7F -1 {} {First trail byte must be 80:BF} - utf-8 EE7F replace \uFFFD\u7F -1 {} {First trail byte must be 80:BF} - utf-8 EE7F strict {} 0 {} {First trail byte must be 80:BF} - utf-8 EED0 tcl8 \u00EE\u00D0 -1 {} {First trail byte must be 80:BF} - utf-8 EED0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} - utf-8 EED0 strict {} 0 {} {First trail byte must be 80:BF} - utf-8 EE81 tcl8 \u00EE\u0081 -1 {} {Missing second trail byte} - utf-8 EE81 replace \uFFFD -1 {knownW3C} {Missing second trail byte} - utf-8 EE81 strict {} 0 {} {Missing second trail byte} - utf-8 EEBF tcl8 \u00EE\u00BF -1 {} {Missing second trail byte} - utf-8 EEBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} - utf-8 EEBF strict {} 0 {} {Missing second trail byte} - utf-8 EE807F tcl8 \u00EE\u20AC\x7F -1 {} {Second trail byte must be 80:BF} - utf-8 EE807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 EE807F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 EEBF7F tcl8 \u00EE\u00BF\x7F -1 {} {Second trail byte must be 80:BF} - utf-8 EEBF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 EEBF7F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 EF tcl8 \u00EF -1 {} {Missing trail byte} - utf-8 EF replace \uFFFD -1 {} {Missing trail byte} - utf-8 EF strict {} 0 {} {Missing trail byte} - utf-8 EF7F tcl8 \u00EF\u7F -1 {} {First trail byte must be 80:BF} - utf-8 EF7F replace \uFFFD\u7F -1 {} {First trail byte must be 80:BF} - utf-8 EF7F strict {} 0 {} {First trail byte must be 80:BF} - utf-8 EFD0 tcl8 \u00EF\u00D0 -1 {} {First trail byte must be 80:BF} - utf-8 EFD0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} - utf-8 EFD0 strict {} 0 {} {First trail byte must be 80:BF} - utf-8 EF81 tcl8 \u00EF\u0081 -1 {} {Missing second trail byte} - utf-8 EF81 replace \uFFFD -1 {knownW3C} {Missing second trail byte} - utf-8 EF81 strict {} 0 {} {Missing second trail byte} - utf-8 EFBF tcl8 \u00EF\u00BF -1 {} {Missing second trail byte} - utf-8 EFBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} - utf-8 EFBF strict {} 0 {} {Missing second trail byte} - utf-8 EF807F tcl8 \u00EF\u20AC\x7F -1 {} {Second trail byte must be 80:BF} - utf-8 EF807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 EF807F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 EFBF7F tcl8 \u00EF\u00BF\x7F -1 {} {Second trail byte must be 80:BF} - utf-8 EFBF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 EFBF7F strict {} 0 {} {Second trail byte must be 80:BF} - - utf-8 F0 tcl8 \u00F0 -1 {} {Missing trail byte} - utf-8 F0 replace \uFFFD -1 {} {Missing trail byte} - utf-8 F0 strict {} 0 {} {Missing trail byte} - utf-8 F080 tcl8 \u00F0\u20AC -1 {} {First trail byte must be 90:BF} - utf-8 F080 replace \uFFFD -1 {knownW3C} {First trail byte must be 90:BF} - utf-8 F080 strict {} 0 {} {First trail byte must be 90:BF} - utf-8 F08F tcl8 \u00F0\u8F -1 {} {First trail byte must be 90:BF} - utf-8 F08F replace \uFFFD -1 {knownW3C} {First trail byte must be 90:BF} - utf-8 F08F strict {} 0 {} {First trail byte must be 90:BF} - utf-8 F0D0 tcl8 \u00F0\u00D0 -1 {} {First trail byte must be 90:BF} - utf-8 F0D0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 90:BF} - utf-8 F0D0 strict {} 0 {} {First trail byte must be 90:BF} - utf-8 F090 tcl8 \u00F0\u0090 -1 {} {Missing second trail byte} - utf-8 F090 replace \uFFFD -1 {knownW3C} {Missing second trail byte} - utf-8 F090 strict {} 0 {} {Missing second trail byte} - utf-8 F0BF tcl8 \u00F0\u00BF -1 {} {Missing second trail byte} - utf-8 F0BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} - utf-8 F0BF strict {} 0 {} {Missing second trail byte} - utf-8 F0907F tcl8 \u00F0\u0090\x7F -1 {} {Second trail byte must be 80:BF} - utf-8 F0907F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 F0907F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 F0BF7F tcl8 \u00F0\u00BF\x7F -1 {} {Second trail byte must be 80:BF} - utf-8 F0BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 F0BF7F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 F090BF tcl8 \u00F0\u0090\u00BF -1 {} {Missing third trail byte} - utf-8 F090BF replace \uFFFD -1 {knownW3C} {Missing third trail byte} - utf-8 F090BF strict {} 0 {} {Missing third trail byte} - utf-8 F0BF81 tcl8 \u00F0\u00BF\u0081 -1 {} {Missing third trail byte} - utf-8 F0BF81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} - utf-8 F0BF81 strict {} 0 {} {Missing third trail byte} - utf-8 F0BF807F tcl8 \u00F0\u00BF\u20AC\x7F -1 {} {Third trail byte must be 80:BF} - utf-8 F0BF817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} - utf-8 F0BF817F strict {} 0 {} {Third trail byte must be 80:BF} - utf-8 F090BFD0 tcl8 \u00F0\u0090\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} - utf-8 F090BFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF} - utf-8 F090BFD0 strict {} 0 {} {Third trail byte must be 80:BF} - - utf-8 F1 tcl8 \u00F1 -1 {} {Missing trail byte} - utf-8 F1 replace \uFFFD -1 {} {Missing trail byte} - utf-8 F1 strict {} 0 {} {Missing trail byte} - utf-8 F17F tcl8 \u00F1\u7F -1 {} {First trail byte must be 80:BF} - utf-8 F17F replace \uFFFD -1 {knownW3C} {First trail byte must be 80:BF} - utf-8 F17F strict {} 0 {} {First trail byte must be 80:BF} - utf-8 F1D0 tcl8 \u00F1\u00D0 -1 {} {First trail byte must be 80:BF} - utf-8 F1D0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} - utf-8 F1D0 strict {} 0 {} {First trail byte must be 80:BF} - utf-8 F180 tcl8 \u00F1\u20AC -1 {} {Missing second trail byte} - utf-8 F180 replace \uFFFD -1 {knownW3C} {Missing second trail byte} - utf-8 F180 strict {} 0 {} {Missing second trail byte} - utf-8 F1BF tcl8 \u00F1\u00BF -1 {} {Missing second trail byte} - utf-8 F1BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} - utf-8 F1BF strict {} 0 {} {Missing second trail byte} - utf-8 F1807F tcl8 \u00F1\u20AC\x7F -1 {} {Second trail byte must be 80:BF} - utf-8 F1807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 F1807F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 F1BF7F tcl8 \u00F1\u00BF\x7F -1 {} {Second trail byte must be 80:BF} - utf-8 F1BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 F1BF7F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 F180BF tcl8 \u00F1\u20AC\u00BF -1 {} {Missing third trail byte} - utf-8 F180BF replace \uFFFD -1 {knownW3C} {Missing third trail byte} - utf-8 F180BF strict {} 0 {} {Missing third trail byte} - utf-8 F1BF81 tcl8 \u00F1\u00BF\u0081 -1 {} {Missing third trail byte} - utf-8 F1BF81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} - utf-8 F1BF81 strict {} 0 {} {Missing third trail byte} - utf-8 F1BF807F tcl8 \u00F1\u00BF\u20AC\x7F -1 {} {Third trail byte must be 80:BF} - utf-8 F1BF817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} - utf-8 F1BF817F strict {} 0 {} {Third trail byte must be 80:BF} - utf-8 F180BFD0 tcl8 \u00F1\u20AC\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} - utf-8 F180BFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF} - utf-8 F180BFD0 strict {} 0 {} {Third trail byte must be 80:BF} - utf-8 F3 tcl8 \u00F3 -1 {} {Missing trail byte} - utf-8 F3 replace \uFFFD -1 {} {Missing trail byte} - utf-8 F3 strict {} 0 {} {Missing trail byte} - utf-8 F37F tcl8 \u00F3\x7F -1 {} {First trail byte must be 80:BF} - utf-8 F37F replace \uFFFD -1 {knownW3C} {First trail byte must be 80:BF} - utf-8 F37F strict {} 0 {} {First trail byte must be 80:BF} - utf-8 F3D0 tcl8 \u00F3\u00D0 -1 {} {First trail byte must be 80:BF} - utf-8 F3D0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} - utf-8 F3D0 strict {} 0 {} {First trail byte must be 80:BF} - utf-8 F380 tcl8 \u00F3\u20AC -1 {} {Missing second trail byte} - utf-8 F380 replace \uFFFD -1 {knownW3C} {Missing second trail byte} - utf-8 F380 strict {} 0 {} {Missing second trail byte} - utf-8 F3BF tcl8 \u00F3\u00BF -1 {} {Missing second trail byte} - utf-8 F3BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} - utf-8 F3BF strict {} 0 {} {Missing second trail byte} - utf-8 F3807F tcl8 \u00F3\u20AC\x7F -1 {} {Second trail byte must be 80:BF} - utf-8 F3807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 F3807F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 F3BF7F tcl8 \u00F3\u00BF\x7F -1 {} {Second trail byte must be 80:BF} - utf-8 F3BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 F3BF7F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 F380BF tcl8 \u00F3\u20AC\u00BF -1 {} {Missing third trail byte} - utf-8 F380BF replace \uFFFD -1 {knownW3C} {Missing third trail byte} - utf-8 F380BF strict {} 0 {} {Missing third trail byte} - utf-8 F3BF81 tcl8 \u00F3\u00BF\u0081 -1 {} {Missing third trail byte} - utf-8 F3BF81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} - utf-8 F3BF81 strict {} 0 {} {Missing third trail byte} - utf-8 F3BF807F tcl8 \u00F3\u00BF\u20AC\x7F -1 {} {Third trail byte must be 80:BF} - utf-8 F3BF817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} - utf-8 F3BF817F strict {} 0 {} {Third trail byte must be 80:BF} - utf-8 F380BFD0 tcl8 \u00F3\u20AC\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} - utf-8 F380BFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF} - utf-8 F380BFD0 strict {} 0 {} {Third trail byte must be 80:BF} - - utf-8 F4 tcl8 \u00F4 -1 {} {Missing trail byte} - utf-8 F4 replace \uFFFD -1 {} {Missing trail byte} - utf-8 F4 strict {} 0 {} {Missing trail byte} - utf-8 F47F tcl8 \u00F4\u7F -1 {} {First trail byte must be 80:8F} - utf-8 F47F replace \uFFFD\u7F -1 {knownW3C} {First trail byte must be 80:8F} - utf-8 F47F strict {} 0 {} {First trail byte must be 80:8F} - utf-8 F490 tcl8 \u00F4\u0090 -1 {} {First trail byte must be 80:8F} - utf-8 F490 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:8F} - utf-8 F490 strict {} 0 {} {First trail byte must be 80:8F} - utf-8 F480 tcl8 \u00F4\u20AC -1 {} {Missing second trail byte} - utf-8 F480 replace \uFFFD -1 {knownW3C} {Missing second trail byte} - utf-8 F480 strict {} 0 {} {Missing second trail byte} - utf-8 F48F tcl8 \u00F4\u008F -1 {} {Missing second trail byte} - utf-8 F48F replace \uFFFD -1 {knownW3C} {Missing second trail byte} - utf-8 F48F strict {} 0 {} {Missing second trail byte} - utf-8 F4807F tcl8 \u00F4\u20AC\x7F -1 {} {Second trail byte must be 80:BF} - utf-8 F4807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 F4807F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 F48F7F tcl8 \u00F4\u008F\x7F -1 {} {Second trail byte must be 80:BF} - utf-8 F48F7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} - utf-8 F48F7F strict {} 0 {} {Second trail byte must be 80:BF} - utf-8 F48081 tcl8 \u00F4\u20AC\u0081 -1 {} {Missing third trail byte} - utf-8 F48081 replace \uFFFD -1 {knownW3C} {Missing third trail byte} - utf-8 F48081 strict {} 0 {} {Missing third trail byte} - utf-8 F48F81 tcl8 \u00F4\u008F\u0081 -1 {} {Missing third trail byte} - utf-8 F48F81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} - utf-8 F48F81 strict {} 0 {} {Missing third trail byte} - utf-8 F481817F tcl8 \u00F4\u0081\u0081\x7F -1 {} {Third trail byte must be 80:BF} - utf-8 F480817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} - utf-8 F480817F strict {} 0 {} {Third trail byte must be 80:BF} - utf-8 F48FBFD0 tcl8 \u00F4\u008F\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} - utf-8 F48FBFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF} - utf-8 F48FBFD0 strict {} 0 {} {Third trail byte must be 80:BF} - - utf-8 F5 tcl8 \u00F5 -1 {} {F5:FF are invalid everywhere} - utf-8 F5 replace \uFFFD -1 {} {F5:FF are invalid everywhere} - utf-8 F5 strict {} 0 {} {F5:FF are invalid everywhere} - utf-8 FF tcl8 \u00FF -1 {} {F5:FF are invalid everywhere} - utf-8 FF replace \uFFFD -1 {} {F5:FF are invalid everywhere} - utf-8 FF strict {} 0 {} {F5:FF are invalid everywhere} - - utf-8 C0AFE080BFF0818130 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {} {Unicode Table 3-8} - utf-8 EDA080EDBFBFEDAF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {knownW3C} {Unicode Table 3-9} - utf-8 F4919293FF4180BF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\u0041\uFFFD\uFFFD\x30 -1 {} {Unicode Table 3-10} - utf-8 E180E2F09192F1BF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {knownW3C} {Unicode Table 3.11} -} - -# utf16-le and utf16-be test cases. Note utf16 cases are automatically generated -# based on these depending on platform endianness. Note truncated tests can only -# happen when the sequence is at the end (including by itself) Thus {solo tail} -# in some cases. -lappend encInvalidBytes {*}{ - utf-16le 41 tcl8 \uFFFD -1 {solo tail} {Truncated} - utf-16le 41 replace \uFFFD -1 {solo tail} {Truncated} - utf-16le 41 strict {} 0 {solo tail} {Truncated} - utf-16le 00D8 tcl8 \uD800 -1 {} {Missing low surrogate} - utf-16le 00D8 replace \uFFFD -1 {knownBug} {Missing low surrogate} - utf-16le 00D8 strict {} 0 {knownBug} {Missing low surrogate} - utf-16le 00DC tcl8 \uDC00 -1 {} {Missing high surrogate} - utf-16le 00DC replace \uFFFD -1 {knownBug} {Missing high surrogate} - utf-16le 00DC strict {} 0 {knownBug} {Missing high surrogate} - - utf-16be 41 tcl8 \uFFFD -1 {solo tail} {Truncated} - utf-16be 41 replace \uFFFD -1 {solo tail} {Truncated} - utf-16be 41 strict {} 0 {solo tail} {Truncated} - utf-16be D800 tcl8 \uD800 -1 {} {Missing low surrogate} - utf-16be D800 replace \uFFFD -1 {knownBug} {Missing low surrogate} - utf-16be D800 strict {} 0 {knownBug} {Missing low surrogate} - utf-16be DC00 tcl8 \uDC00 -1 {} {Missing high surrogate} - utf-16be DC00 replace \uFFFD -1 {knownBug} {Missing high surrogate} - utf-16be DC00 strict {} 0 {knownBug} {Missing high surrogate} -} - -# utf32-le and utf32-be test cases. Note utf32 cases are automatically generated -# based on these depending on platform endianness. Note truncated tests can only -# happen when the sequence is at the end (including by itself) Thus {solo tail} -# in some cases. -lappend encInvalidBytes {*}{ - utf-32le 41 tcl8 \uFFFD -1 {solo tail} {Truncated} - utf-32le 41 replace \uFFFD -1 {solo} {Truncated} - utf-32le 41 strict {} 0 {solo tail} {Truncated} - utf-32le 4100 tcl8 \uFFFD -1 {solo tail} {Truncated} - utf-32le 4100 replace \uFFFD -1 {solo} {Truncated} - utf-32le 4100 strict {} 0 {solo tail} {Truncated} - utf-32le 410000 tcl8 \uFFFD -1 {solo tail} {Truncated} - utf-32le 410000 replace \uFFFD -1 {solo} {Truncated} - utf-32le 410000 strict {} 0 {solo tail} {Truncated} - utf-32le 00D80000 tcl8 \uD800 -1 {} {High-surrogate} - utf-32le 00D80000 replace \uFFFD -1 {} {High-surrogate} - utf-32le 00D80000 strict {} 0 {} {High-surrogate} - utf-32le 00DC0000 tcl8 \uDC00 -1 {} {Low-surrogate} - utf-32le 00DC0000 replace \uFFFD -1 {} {Low-surrogate} - utf-32le 00DC0000 strict {} 0 {} {Low-surrogate} - utf-32le 00D8000000DC0000 tcl8 \uD800\uDC00 -1 {} {High-low-surrogate-pair} - utf-32le 00D8000000DC0000 replace \uFFFD\uFFFD -1 {} {High-low-surrogate-pair} - utf-32le 00D8000000DC0000 strict {} 0 {} {High-low-surrogate-pair} - utf-32le 00001100 tcl8 \UFFFD -1 {} {Out of range} - utf-32le 00001100 replace \UFFFD -1 {} {Out of range} - utf-32le 00001100 strict {} 0 {} {Out of range} - utf-32le FFFFFFFF tcl8 \UFFFD -1 {} {Out of range} - utf-32le FFFFFFFF replace \UFFFD -1 {} {Out of range} - utf-32le FFFFFFFF strict {} 0 {} {Out of range} - - utf-32be 41 tcl8 \uFFFD -1 {solo tail} {Truncated} - utf-32be 41 replace \uFFFD -1 {solo tail} {Truncated} - utf-32be 41 strict {} 0 {solo tail} {Truncated} - utf-32be 0041 tcl8 \uFFFD -1 {solo tail} {Truncated} - utf-32be 0041 replace \uFFFD -1 {solo} {Truncated} - utf-32be 0041 strict {} 0 {solo tail} {Truncated} - utf-32be 000041 tcl8 \uFFFD -1 {solo tail} {Truncated} - utf-32be 000041 replace \uFFFD -1 {solo} {Truncated} - utf-32be 000041 strict {} 0 {solo tail} {Truncated} - utf-32be 0000D800 tcl8 \uD800 -1 {} {High-surrogate} - utf-32be 0000D800 replace \uFFFD -1 {} {High-surrogate} - utf-32be 0000D800 strict {} 0 {} {High-surrogate} - utf-32be 0000DC00 tcl8 \uDC00 -1 {} {Low-surrogate} - utf-32be 0000DC00 replace \uFFFD -1 {} {Low-surrogate} - utf-32be 0000DC00 strict {} 0 {} {Low-surrogate} - utf-32be 0000D8000000DC00 tcl8 \uD800\uDC00 -1 {} {High-low-surrogate-pair} - utf-32be 0000D8000000DC00 replace \uFFFD\uFFFD -1 {} {High-low-surrogate-pair} - utf-32be 0000D8000000DC00 strict {} 0 {} {High-low-surrogate-pair} - utf-32be 00110000 tcl8 \UFFFD -1 {} {Out of range} - utf-32be 00110000 replace \UFFFD -1 {} {Out of range} - utf-32be 00110000 strict {} 0 {} {Out of range} - utf-32be FFFFFFFF tcl8 \UFFFD -1 {} {Out of range} - utf-32be FFFFFFFF replace \UFFFD -1 {} {Out of range} - utf-32be FFFFFFFF strict {} 0 {} {Out of range} -} - - -# Strings that cannot be encoded for specific encoding / profiles -# {encoding string profile exptedresult expectedfailindex ctrl comment} -# should be unique for test ids to be unique. -# Note utf-16, utf-32 missing because they are automatically -# generated based on le/be versions. -# Each entry potentially results in generation of multiple tests. -# This is controlled by the ctrl field. This should be a list of -# zero or more of the following: -# solo - the test data is the string itself -# lead - the test data is the string followed by a valid suffix -# tail - the test data is the string preceded by a prefix -# middle - the test data is the string wrapped by a prefix and suffix -# If the ctrl field is empty it is treated as all of the above -# Note if there is any other value by itself, it will cause the test to -# be skipped. This is intentional to skip known bugs. -# TODO - other encodings -# TODO - out of range code point (note cannot be generated by \U notation) -lappend encUnencodableStrings {*}{ - ascii \u00e0 tcl8 3f -1 {} {unencodable} - ascii \u00e0 strict {} 0 {} {unencodable} - - iso8859-1 \u0141 tcl8 3f -1 {} unencodable - iso8859-1 \u0141 strict {} 0 {} unencodable - - utf-8 \uD800 tcl8 eda080 -1 {} High-surrogate - utf-8 \uD800 strict {} 0 {} High-surrogate - utf-8 \uDC00 tcl8 edb080 -1 {} High-surrogate - utf-8 \uDC00 strict {} 0 {} High-surrogate -} +source [file join [file dirname [info script]] encodingVectors.tcl] -# Generated tests comparing against ICU -# TODO - commented out for now as generating a lot of mismatches. -# source [file join [file dirname [info script]] icuUcmTests.tcl] # Maps utf-{16,32}{le,be} to utf-16, utf-32 and # others to "". Used to test utf-16, utf-32 based diff --git a/tests/encodingVectors.tcl b/tests/encodingVectors.tcl new file mode 100644 index 0000000..986e221 --- /dev/null +++ b/tests/encodingVectors.tcl @@ -0,0 +1,655 @@ +# This file contains test vectors for verifying various encodings. They are +# stored in a common file so that they can be sourced into the various test +# modules that are dependent on encodings. This file contains statically defined +# test vectors. In addition, it sources the ICU-generated test vectors from +# icuUcmTests.tcl. +# +# Note that sourcing the file will reinitialize any existing encoding test +# vectors. +# + +# List of defined encoding profiles +set encProfiles {tcl8 strict replace} +set encDefaultProfile tcl8; # Should reflect the default from implementation + +# encValidStrings - Table of valid strings. +# +# Each row is +# The pair should be unique for generated test ids to be unique. +# STR is a string that can be encoded in the encoding ENCODING resulting +# in the byte sequence BYTES. The CTRL field is a list that controls test +# generation. It may contain zero or more of `solo`, `lead`, `tail` and +# `middle` indicating that the generated tests should include the string +# by itself, as the lead of a longer string, as the tail of a longer string +# and in the middle of a longer string. If CTRL is empty, it is treated as +# containing all four of the above. The CTRL field may also contain the +# words knownBug or knownW3C which will cause the test generation for that +# vector to be skipped. +# +# utf-16, utf-32 missing because they are automatically +# generated based on le/be versions. +set encValidStrings {}; # Reset the table + +lappend encValidStrings {*}{ + ascii \u0000 00 {} {Lowest ASCII} + ascii \u007F 7F knownBug {Highest ASCII} + ascii \u007D 7D {} {Brace - just to verify test scripts are escaped correctly} + ascii \u007B 7B {} {Terminating brace - just to verify test scripts are escaped correctly} + + utf-8 \u0000 00 {} {Unicode Table 3.7 Row 1} + utf-8 \u007F 7F {} {Unicode Table 3.7 Row 1} + utf-8 \u0080 C280 {} {Unicode Table 3.7 Row 2} + utf-8 \u07FF DFBF {} {Unicode Table 3.7 Row 2} + utf-8 \u0800 E0A080 {} {Unicode Table 3.7 Row 3} + utf-8 \u0FFF E0BFBF {} {Unicode Table 3.7 Row 3} + utf-8 \u1000 E18080 {} {Unicode Table 3.7 Row 4} + utf-8 \uCFFF ECBFBF {} {Unicode Table 3.7 Row 4} + utf-8 \uD000 ED8080 {} {Unicode Table 3.7 Row 5} + utf-8 \uD7FF ED9FBF {} {Unicode Table 3.7 Row 5} + utf-8 \uE000 EE8080 {} {Unicode Table 3.7 Row 6} + utf-8 \uFFFF EFBFBF {} {Unicode Table 3.7 Row 6} + utf-8 \U10000 F0908080 {} {Unicode Table 3.7 Row 7} + utf-8 \U3FFFF F0BFBFBF {} {Unicode Table 3.7 Row 7} + utf-8 \U40000 F1808080 {} {Unicode Table 3.7 Row 8} + utf-8 \UFFFFF F3BFBFBF {} {Unicode Table 3.7 Row 8} + utf-8 \U100000 F4808080 {} {Unicode Table 3.7 Row 9} + utf-8 \U10FFFF F48FBFBF {} {Unicode Table 3.7 Row 9} + utf-8 A\u03A9\u8A9E\U00010384 41CEA9E8AA9EF0908E84 {} {Unicode 2.5} + + utf-16le \u0000 0000 {} {Lowest code unit} + utf-16le \uD7FF FFD7 {} {Below high surrogate range} + utf-16le \uE000 00E0 {} {Above low surrogate range} + utf-16le \uFFFF FFFF {} {Highest code unit} + utf-16le \U010000 00D800DC {} {First surrogate pair} + utf-16le \U10FFFF FFDBFFDF {} {First surrogate pair} + utf-16le A\u03A9\u8A9E\U00010384 4100A9039E8A00D884DF {} {Unicode 2.5} + + utf-16be \u0000 0000 {} {Lowest code unit} + utf-16be \uD7FF D7FF {} {Below high surrogate range} + utf-16be \uE000 E000 {} {Above low surrogate range} + utf-16be \uFFFF FFFF {} {Highest code unit} + utf-16be \U010000 D800DC00 {} {First surrogate pair} + utf-16be \U10FFFF DBFFDFFF {} {First surrogate pair} + utf-16be A\u03A9\u8A9E\U00010384 004103A98A9ED800DF84 {} {Unicode 2.5} + + utf-32le \u0000 00000000 {} {Lowest code unit} + utf-32le \uFFFF FFFF0000 {} {Highest BMP} + utf-32le \U010000 00000100 {} {First supplementary} + utf-32le \U10FFFF ffff1000 {} {Last supplementary} + utf-32le A\u03A9\u8A9E\U00010384 41000000A90300009E8A000084030100 {} {Unicode 2.5} + + utf-32be \u0000 00000000 {} {Lowest code unit} + utf-32be \uFFFF 0000FFFF {} {Highest BMP} + utf-32be \U010000 00010000 {} {First supplementary} + utf-32be \U10FFFF 0010FFFF {} {Last supplementary} + utf-32be A\u03A9\u8A9E\U00010384 00000041000003A900008A9E00010384 {} {Unicode 2.5} +} + +# encInvalidBytes - Table of invalid byte sequences +# These are byte sequences that should appear for an encoding. Each row is +# of the form +# +# The triple should be unique for test ids to be +# unique. BYTES is a byte sequence that is invalid. EXPECTEDRESULT is the +# expected string when the bytes are decoded using the PROFILE profile. +# FAILINDEX gives the expected index of the invalid byte under that profile. The +# CTRL field is a list that controls test generation. It may contain zero or +# more of `solo`, `lead`, `tail` and `middle` indicating that the generated the +# tail of a longer and in the middle of a longer string. If empty, it is treated +# as containing all four of the above. The CTRL field may also contain the words +# knownBug or knownW3C which will cause the test generation for that vector to +# be skipped. +# +# utf-32 missing because they are automatically generated based on le/be +# versions. +set encInvalidBytes {}; # Reset the table + +# ascii - Any byte above 127 is invalid and is mapped +# to the same numeric code point except for the range +# 80-9F which is treated as cp1252. +# This tests the TableToUtfProc code path. +lappend encInvalidBytes {*}{ + ascii 80 tcl8 \u20AC -1 {knownBug} {map to cp1252} + ascii 80 replace \uFFFD -1 {} {Smallest invalid byte} + ascii 80 strict {} 0 {} {Smallest invalid byte} + ascii 81 tcl8 \u0081 -1 {knownBug} {map to cp1252} + ascii 82 tcl8 \u201A -1 {knownBug} {map to cp1252} + ascii 83 tcl8 \u0192 -1 {knownBug} {map to cp1252} + ascii 84 tcl8 \u201E -1 {knownBug} {map to cp1252} + ascii 85 tcl8 \u2026 -1 {knownBug} {map to cp1252} + ascii 86 tcl8 \u2020 -1 {knownBug} {map to cp1252} + ascii 87 tcl8 \u2021 -1 {knownBug} {map to cp1252} + ascii 88 tcl8 \u0276 -1 {knownBug} {map to cp1252} + ascii 89 tcl8 \u2030 -1 {knownBug} {map to cp1252} + ascii 8A tcl8 \u0160 -1 {knownBug} {map to cp1252} + ascii 8B tcl8 \u2039 -1 {knownBug} {map to cp1252} + ascii 8C tcl8 \u0152 -1 {knownBug} {map to cp1252} + ascii 8D tcl8 \u008D -1 {knownBug} {map to cp1252} + ascii 8E tcl8 \u017D -1 {knownBug} {map to cp1252} + ascii 8F tcl8 \u008F -1 {knownBug} {map to cp1252} + ascii 90 tcl8 \u0090 -1 {knownBug} {map to cp1252} + ascii 91 tcl8 \u2018 -1 {knownBug} {map to cp1252} + ascii 92 tcl8 \u2019 -1 {knownBug} {map to cp1252} + ascii 93 tcl8 \u201C -1 {knownBug} {map to cp1252} + ascii 94 tcl8 \u201D -1 {knownBug} {map to cp1252} + ascii 95 tcl8 \u2022 -1 {knownBug} {map to cp1252} + ascii 96 tcl8 \u2013 -1 {knownBug} {map to cp1252} + ascii 97 tcl8 \u2014 -1 {knownBug} {map to cp1252} + ascii 98 tcl8 \u02DC -1 {knownBug} {map to cp1252} + ascii 99 tcl8 \u2122 -1 {knownBug} {map to cp1252} + ascii 9A tcl8 \u0161 -1 {knownBug} {map to cp1252} + ascii 9B tcl8 \u203A -1 {knownBug} {map to cp1252} + ascii 9C tcl8 \u0153 -1 {knownBug} {map to cp1252} + ascii 9D tcl8 \u009D -1 {knownBug} {map to cp1252} + ascii 9E tcl8 \u017E -1 {knownBug} {map to cp1252} + ascii 9F tcl8 \u0178 -1 {knownBug} {map to cp1252} + + ascii FF tcl8 \u00FF -1 {} {Largest invalid byte} + ascii FF replace \uFFFD -1 {} {Largest invalid byte} + ascii FF strict {} 0 {} {Largest invalid byte} +} + +# utf-8 - valid sequences based on Table 3.7 in the Unicode +# standard. +# +# Code Points First Second Third Fourth Byte +# U+0000..U+007F 00..7F +# U+0080..U+07FF C2..DF 80..BF +# U+0800..U+0FFF E0 A0..BF 80..BF +# U+1000..U+CFFF E1..EC 80..BF 80..BF +# U+D000..U+D7FF ED 80..9F 80..BF +# U+E000..U+FFFF EE..EF 80..BF 80..BF +# U+10000..U+3FFFF F0 90..BF 80..BF 80..BF +# U+40000..U+FFFFF F1..F3 80..BF 80..BF 80..BF +# U+100000..U+10FFFF F4 80..8F 80..BF 80..BF +# +# Tests below are based on the "gaps" in the above table. Note ascii test +# values are repeated because internally a different code path is used +# (UtfToUtfProc). +# Note C0, C1, F5:FF are invalid bytes ANYWHERE. Exception is C080 +lappend encInvalidBytes {*}{ + utf-8 80 tcl8 \u20AC -1 {} {map to cp1252} + utf-8 80 replace \uFFFD -1 {} {Smallest invalid byte} + utf-8 80 strict {} 0 {} {Smallest invalid byte} + utf-8 81 tcl8 \u0081 -1 {} {map to cp1252} + utf-8 82 tcl8 \u201A -1 {} {map to cp1252} + utf-8 83 tcl8 \u0192 -1 {} {map to cp1252} + utf-8 84 tcl8 \u201E -1 {} {map to cp1252} + utf-8 85 tcl8 \u2026 -1 {} {map to cp1252} + utf-8 86 tcl8 \u2020 -1 {} {map to cp1252} + utf-8 87 tcl8 \u2021 -1 {} {map to cp1252} + utf-8 88 tcl8 \u02C6 -1 {} {map to cp1252} + utf-8 89 tcl8 \u2030 -1 {} {map to cp1252} + utf-8 8A tcl8 \u0160 -1 {} {map to cp1252} + utf-8 8B tcl8 \u2039 -1 {} {map to cp1252} + utf-8 8C tcl8 \u0152 -1 {} {map to cp1252} + utf-8 8D tcl8 \u008D -1 {} {map to cp1252} + utf-8 8E tcl8 \u017D -1 {} {map to cp1252} + utf-8 8F tcl8 \u008F -1 {} {map to cp1252} + utf-8 90 tcl8 \u0090 -1 {} {map to cp1252} + utf-8 91 tcl8 \u2018 -1 {} {map to cp1252} + utf-8 92 tcl8 \u2019 -1 {} {map to cp1252} + utf-8 93 tcl8 \u201C -1 {} {map to cp1252} + utf-8 94 tcl8 \u201D -1 {} {map to cp1252} + utf-8 95 tcl8 \u2022 -1 {} {map to cp1252} + utf-8 96 tcl8 \u2013 -1 {} {map to cp1252} + utf-8 97 tcl8 \u2014 -1 {} {map to cp1252} + utf-8 98 tcl8 \u02DC -1 {} {map to cp1252} + utf-8 99 tcl8 \u2122 -1 {} {map to cp1252} + utf-8 9A tcl8 \u0161 -1 {} {map to cp1252} + utf-8 9B tcl8 \u203A -1 {} {map to cp1252} + utf-8 9C tcl8 \u0153 -1 {} {map to cp1252} + utf-8 9D tcl8 \u009D -1 {} {map to cp1252} + utf-8 9E tcl8 \u017E -1 {} {map to cp1252} + utf-8 9F tcl8 \u0178 -1 {} {map to cp1252} + + utf-8 C0 tcl8 \u00C0 -1 {} {C0 is invalid anywhere} + utf-8 C0 strict {} 0 {} {C0 is invalid anywhere} + utf-8 C0 replace \uFFFD -1 {} {C0 is invalid anywhere} + utf-8 C080 tcl8 \u0000 -1 {} {C080 -> U+0 in Tcl's internal modified UTF8} + utf-8 C080 strict {} 0 {} {C080 -> invalid} + utf-8 C080 replace \uFFFD -1 {} {C080 -> single replacement char} + utf-8 C0A2 tcl8 \u00C0\u00A2 -1 {} {websec.github.io - A} + utf-8 C0A2 replace \uFFFD\uFFFD -1 {} {websec.github.io - A} + utf-8 C0A2 strict {} 0 {} {websec.github.io - A} + utf-8 C0A7 tcl8 \u00C0\u00A7 -1 {} {websec.github.io - double quote} + utf-8 C0A7 replace \uFFFD\uFFFD -1 {} {websec.github.io - double quote} + utf-8 C0A7 strict {} 0 {} {websec.github.io - double quote} + utf-8 C0AE tcl8 \u00C0\u00AE -1 {} {websec.github.io - full stop} + utf-8 C0AE replace \uFFFD\uFFFD -1 {} {websec.github.io - full stop} + utf-8 C0AE strict {} 0 {} {websec.github.io - full stop} + utf-8 C0AF tcl8 \u00C0\u00AF -1 {} {websec.github.io - solidus} + utf-8 C0AF replace \uFFFD\uFFFD -1 {} {websec.github.io - solidus} + utf-8 C0AF strict {} 0 {} {websec.github.io - solidus} + + utf-8 C1 tcl8 \u00C1 -1 {} {C1 is invalid everywhere} + utf-8 C1 replace \uFFFD -1 {} {C1 is invalid everywhere} + utf-8 C1 strict {} 0 {} {C1 is invalid everywhere} + utf-8 C181 tcl8 \u00C1\u0081 -1 {} {websec.github.io - base test (A)} + utf-8 C181 replace \uFFFD\uFFFD -1 {} {websec.github.io - base test (A)} + utf-8 C181 strict {} 0 {} {websec.github.io - base test (A)} + utf-8 C19C tcl8 \u00C1\u0153 -1 {} {websec.github.io - reverse solidus} + utf-8 C19C replace \uFFFD\uFFFD -1 {} {websec.github.io - reverse solidus} + utf-8 C19C strict {} 0 {} {websec.github.io - reverse solidus} + + utf-8 C2 tcl8 \u00C2 -1 {} {Missing trail byte} + utf-8 C2 replace \uFFFD -1 {} {Missing trail byte} + utf-8 C2 strict {} 0 {} {Missing trail byte} + utf-8 C27F tcl8 \u00C2\x7F -1 {} {Trail byte must be 80:BF} + utf-8 C27F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} + utf-8 C27F strict {} 0 {} {Trail byte must be 80:BF} + utf-8 DF tcl8 \u00DF -1 {} {Missing trail byte} + utf-8 DF replace \uFFFD -1 {} {Missing trail byte} + utf-8 DF strict {} 0 {} {Missing trail byte} + utf-8 DF7F tcl8 \u00DF\x7F -1 {} {Trail byte must be 80:BF} + utf-8 DF7F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} + utf-8 DF7F strict {} 0 {} {Trail byte must be 80:BF} + utf-8 DFE0A080 tcl8 \u00DF\u0800 -1 {} {Invalid trail byte is start of valid sequence} + utf-8 DFE0A080 replace \uFFFD\u0800 -1 {} {Invalid trail byte is start of valid sequence} + utf-8 DFE0A080 strict {} 0 {} {Invalid trail byte is start of valid sequence} + + utf-8 E0 tcl8 \u00E0 -1 {} {Missing trail byte} + utf-8 E0 replace \uFFFD -1 {} {Missing trail byte} + utf-8 E0 strict {} 0 {} {Missing trail byte} + utf-8 E080 tcl8 \u00E0\u20AC -1 {} {First trail byte must be A0:BF} + utf-8 E080 replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF} + utf-8 E080 strict {} 0 {} {First trail byte must be A0:BF} + utf-8 E0819C tcl8 \u00E0\u0081\u0153 -1 {} {websec.github.io - reverse solidus} + utf-8 E0819C replace \uFFFD\uFFFD\uFFFD -1 {} {websec.github.io - reverse solidus} + utf-8 E0819C strict {} 0 {} {websec.github.io - reverse solidus} + utf-8 E09F tcl8 \u00E0\u0178 -1 {} {First trail byte must be A0:BF} + utf-8 E09F replace \uFFFD\uFFFD -1 {} {First trail byte must be A0:BF} + utf-8 E09F strict {} 0 {} {First trail byte must be A0:BF} + utf-8 E0A0 tcl8 \u00E0\u00A0 -1 {} {Missing second trail byte} + utf-8 E0A0 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 E0A0 strict {} 0 {} {Missing second trail byte} + utf-8 E0BF tcl8 \u00E0\u00BF -1 {} {Missing second trail byte} + utf-8 E0BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 E0BF strict {} 0 {} {Missing second trail byte} + utf-8 E0A07F tcl8 \u00E0\u00A0\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 E0A07F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 E0A07F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 E0BF7F tcl8 \u00E0\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 E0BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 E0BF7F strict {} 0 {} {Second trail byte must be 80:BF} + + utf-8 E1 tcl8 \u00E1 -1 {} {Missing trail byte} + utf-8 E1 replace \uFFFD -1 {} {Missing trail byte} + utf-8 E1 strict {} 0 {} {Missing trail byte} + utf-8 E17F tcl8 \u00E1\x7F -1 {} {Trail byte must be 80:BF} + utf-8 E17F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} + utf-8 E17F strict {} 0 {} {Trail byte must be 80:BF} + utf-8 E181 tcl8 \u00E1\u0081 -1 {} {Missing second trail byte} + utf-8 E181 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 E181 strict {} 0 {} {Missing second trail byte} + utf-8 E1BF tcl8 \u00E1\u00BF -1 {} {Missing second trail byte} + utf-8 E1BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 E1BF strict {} 0 {} {Missing second trail byte} + utf-8 E1807F tcl8 \u00E1\u20AC\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 E1807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 E1807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 E1BF7F tcl8 \u00E1\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 E1BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 E1BF7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 EC tcl8 \u00EC -1 {} {Missing trail byte} + utf-8 EC replace \uFFFD -1 {} {Missing trail byte} + utf-8 EC strict {} 0 {} {Missing trail byte} + utf-8 EC7F tcl8 \u00EC\x7F -1 {} {Trail byte must be 80:BF} + utf-8 EC7F replace \uFFFD\x7F -1 {} {Trail byte must be 80:BF} + utf-8 EC7F strict {} 0 {} {Trail byte must be 80:BF} + utf-8 EC81 tcl8 \u00EC\u0081 -1 {} {Missing second trail byte} + utf-8 EC81 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 EC81 strict {} 0 {} {Missing second trail byte} + utf-8 ECBF tcl8 \u00EC\u00BF -1 {} {Missing second trail byte} + utf-8 ECBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 ECBF strict {} 0 {} {Missing second trail byte} + utf-8 EC807F tcl8 \u00EC\u20AC\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 EC807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 EC807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 ECBF7F tcl8 \u00EC\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 ECBF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 ECBF7F strict {} 0 {} {Second trail byte must be 80:BF} + + utf-8 ED tcl8 \u00ED -1 {} {Missing trail byte} + utf-8 ED replace \uFFFD -1 {} {Missing trail byte} + utf-8 ED strict {} 0 {} {Missing trail byte} + utf-8 ED7F tcl8 \u00ED\u7F -1 {} {First trail byte must be 80:9F} + utf-8 ED7F replace \uFFFD\u7F -1 {} {First trail byte must be 80:9F} + utf-8 ED7F strict {} 0 {} {First trail byte must be 80:9F} + utf-8 EDA0 tcl8 \u00ED\u00A0 -1 {} {First trail byte must be 80:9F} + utf-8 EDA0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:9F} + utf-8 EDA0 strict {} 0 {} {First trail byte must be 80:9F} + utf-8 ED81 tcl8 \u00ED\u0081 -1 {} {Missing second trail byte} + utf-8 ED81 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 ED81 strict {} 0 {} {Missing second trail byte} + utf-8 EDBF tcl8 \u00ED\u00BF -1 {} {Missing second trail byte} + utf-8 EDBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 EDBF strict {} 0 {} {Missing second trail byte} + utf-8 ED807F tcl8 \u00ED\u20AC\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 ED807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 ED807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 ED9F7F tcl8 \u00ED\u0178\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 ED9F7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 ED9F7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 EDA080 tcl8 \uD800 -1 {} {High surrogate} + utf-8 EDA080 replace \uFFFD -1 {} {High surrogate} + utf-8 EDA080 strict {} 0 {} {High surrogate} + utf-8 EDAFBF tcl8 \uDBFF -1 {} {High surrogate} + utf-8 EDAFBF replace \uFFFD -1 {} {High surrogate} + utf-8 EDAFBF strict {} 0 {} {High surrogate} + utf-8 EDB080 tcl8 \uDC00 -1 {} {Low surrogate} + utf-8 EDB080 replace \uFFFD -1 {} {Low surrogate} + utf-8 EDB080 strict {} 0 {} {Low surrogate} + utf-8 EDBFBF tcl8 \uDFFF -1 {} {Low surrogate} + utf-8 EDBFBF replace \uFFFD -1 {} {Low surrogate} + utf-8 EDBFBF strict {} 0 {} {Low surrogate} + utf-8 EDA080EDB080 tcl8 \U00010000 -1 {} {High low surrogate pair} + utf-8 EDA080EDB080 replace \uFFFD\uFFFD -1 {} {High low surrogate pair} + utf-8 EDA080EDB080 strict {} 0 {} {High low surrogate pair} + utf-8 EDAFBFEDBFBF tcl8 \U0010FFFF -1 {} {High low surrogate pair} + utf-8 EDAFBFEDBFBF replace \uFFFD\uFFFD -1 {} {High low surrogate pair} + utf-8 EDAFBFEDBFBF strict {} 0 {} {High low surrogate pair} + + utf-8 EE tcl8 \u00EE -1 {} {Missing trail byte} + utf-8 EE replace \uFFFD -1 {} {Missing trail byte} + utf-8 EE strict {} 0 {} {Missing trail byte} + utf-8 EE7F tcl8 \u00EE\u7F -1 {} {First trail byte must be 80:BF} + utf-8 EE7F replace \uFFFD\u7F -1 {} {First trail byte must be 80:BF} + utf-8 EE7F strict {} 0 {} {First trail byte must be 80:BF} + utf-8 EED0 tcl8 \u00EE\u00D0 -1 {} {First trail byte must be 80:BF} + utf-8 EED0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} + utf-8 EED0 strict {} 0 {} {First trail byte must be 80:BF} + utf-8 EE81 tcl8 \u00EE\u0081 -1 {} {Missing second trail byte} + utf-8 EE81 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 EE81 strict {} 0 {} {Missing second trail byte} + utf-8 EEBF tcl8 \u00EE\u00BF -1 {} {Missing second trail byte} + utf-8 EEBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 EEBF strict {} 0 {} {Missing second trail byte} + utf-8 EE807F tcl8 \u00EE\u20AC\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 EE807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 EE807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 EEBF7F tcl8 \u00EE\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 EEBF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 EEBF7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 EF tcl8 \u00EF -1 {} {Missing trail byte} + utf-8 EF replace \uFFFD -1 {} {Missing trail byte} + utf-8 EF strict {} 0 {} {Missing trail byte} + utf-8 EF7F tcl8 \u00EF\u7F -1 {} {First trail byte must be 80:BF} + utf-8 EF7F replace \uFFFD\u7F -1 {} {First trail byte must be 80:BF} + utf-8 EF7F strict {} 0 {} {First trail byte must be 80:BF} + utf-8 EFD0 tcl8 \u00EF\u00D0 -1 {} {First trail byte must be 80:BF} + utf-8 EFD0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} + utf-8 EFD0 strict {} 0 {} {First trail byte must be 80:BF} + utf-8 EF81 tcl8 \u00EF\u0081 -1 {} {Missing second trail byte} + utf-8 EF81 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 EF81 strict {} 0 {} {Missing second trail byte} + utf-8 EFBF tcl8 \u00EF\u00BF -1 {} {Missing second trail byte} + utf-8 EFBF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 EFBF strict {} 0 {} {Missing second trail byte} + utf-8 EF807F tcl8 \u00EF\u20AC\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 EF807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 EF807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 EFBF7F tcl8 \u00EF\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 EFBF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 EFBF7F strict {} 0 {} {Second trail byte must be 80:BF} + + utf-8 F0 tcl8 \u00F0 -1 {} {Missing trail byte} + utf-8 F0 replace \uFFFD -1 {} {Missing trail byte} + utf-8 F0 strict {} 0 {} {Missing trail byte} + utf-8 F080 tcl8 \u00F0\u20AC -1 {} {First trail byte must be 90:BF} + utf-8 F080 replace \uFFFD -1 {knownW3C} {First trail byte must be 90:BF} + utf-8 F080 strict {} 0 {} {First trail byte must be 90:BF} + utf-8 F08F tcl8 \u00F0\u8F -1 {} {First trail byte must be 90:BF} + utf-8 F08F replace \uFFFD -1 {knownW3C} {First trail byte must be 90:BF} + utf-8 F08F strict {} 0 {} {First trail byte must be 90:BF} + utf-8 F0D0 tcl8 \u00F0\u00D0 -1 {} {First trail byte must be 90:BF} + utf-8 F0D0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 90:BF} + utf-8 F0D0 strict {} 0 {} {First trail byte must be 90:BF} + utf-8 F090 tcl8 \u00F0\u0090 -1 {} {Missing second trail byte} + utf-8 F090 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F090 strict {} 0 {} {Missing second trail byte} + utf-8 F0BF tcl8 \u00F0\u00BF -1 {} {Missing second trail byte} + utf-8 F0BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F0BF strict {} 0 {} {Missing second trail byte} + utf-8 F0907F tcl8 \u00F0\u0090\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 F0907F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F0907F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F0BF7F tcl8 \u00F0\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 F0BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F0BF7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F090BF tcl8 \u00F0\u0090\u00BF -1 {} {Missing third trail byte} + utf-8 F090BF replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F090BF strict {} 0 {} {Missing third trail byte} + utf-8 F0BF81 tcl8 \u00F0\u00BF\u0081 -1 {} {Missing third trail byte} + utf-8 F0BF81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F0BF81 strict {} 0 {} {Missing third trail byte} + utf-8 F0BF807F tcl8 \u00F0\u00BF\u20AC\x7F -1 {} {Third trail byte must be 80:BF} + utf-8 F0BF817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F0BF817F strict {} 0 {} {Third trail byte must be 80:BF} + utf-8 F090BFD0 tcl8 \u00F0\u0090\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} + utf-8 F090BFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F090BFD0 strict {} 0 {} {Third trail byte must be 80:BF} + + utf-8 F1 tcl8 \u00F1 -1 {} {Missing trail byte} + utf-8 F1 replace \uFFFD -1 {} {Missing trail byte} + utf-8 F1 strict {} 0 {} {Missing trail byte} + utf-8 F17F tcl8 \u00F1\u7F -1 {} {First trail byte must be 80:BF} + utf-8 F17F replace \uFFFD -1 {knownW3C} {First trail byte must be 80:BF} + utf-8 F17F strict {} 0 {} {First trail byte must be 80:BF} + utf-8 F1D0 tcl8 \u00F1\u00D0 -1 {} {First trail byte must be 80:BF} + utf-8 F1D0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} + utf-8 F1D0 strict {} 0 {} {First trail byte must be 80:BF} + utf-8 F180 tcl8 \u00F1\u20AC -1 {} {Missing second trail byte} + utf-8 F180 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F180 strict {} 0 {} {Missing second trail byte} + utf-8 F1BF tcl8 \u00F1\u00BF -1 {} {Missing second trail byte} + utf-8 F1BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F1BF strict {} 0 {} {Missing second trail byte} + utf-8 F1807F tcl8 \u00F1\u20AC\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 F1807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F1807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F1BF7F tcl8 \u00F1\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 F1BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F1BF7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F180BF tcl8 \u00F1\u20AC\u00BF -1 {} {Missing third trail byte} + utf-8 F180BF replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F180BF strict {} 0 {} {Missing third trail byte} + utf-8 F1BF81 tcl8 \u00F1\u00BF\u0081 -1 {} {Missing third trail byte} + utf-8 F1BF81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F1BF81 strict {} 0 {} {Missing third trail byte} + utf-8 F1BF807F tcl8 \u00F1\u00BF\u20AC\x7F -1 {} {Third trail byte must be 80:BF} + utf-8 F1BF817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F1BF817F strict {} 0 {} {Third trail byte must be 80:BF} + utf-8 F180BFD0 tcl8 \u00F1\u20AC\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} + utf-8 F180BFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F180BFD0 strict {} 0 {} {Third trail byte must be 80:BF} + utf-8 F3 tcl8 \u00F3 -1 {} {Missing trail byte} + utf-8 F3 replace \uFFFD -1 {} {Missing trail byte} + utf-8 F3 strict {} 0 {} {Missing trail byte} + utf-8 F37F tcl8 \u00F3\x7F -1 {} {First trail byte must be 80:BF} + utf-8 F37F replace \uFFFD -1 {knownW3C} {First trail byte must be 80:BF} + utf-8 F37F strict {} 0 {} {First trail byte must be 80:BF} + utf-8 F3D0 tcl8 \u00F3\u00D0 -1 {} {First trail byte must be 80:BF} + utf-8 F3D0 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:BF} + utf-8 F3D0 strict {} 0 {} {First trail byte must be 80:BF} + utf-8 F380 tcl8 \u00F3\u20AC -1 {} {Missing second trail byte} + utf-8 F380 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F380 strict {} 0 {} {Missing second trail byte} + utf-8 F3BF tcl8 \u00F3\u00BF -1 {} {Missing second trail byte} + utf-8 F3BF replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F3BF strict {} 0 {} {Missing second trail byte} + utf-8 F3807F tcl8 \u00F3\u20AC\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 F3807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F3807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F3BF7F tcl8 \u00F3\u00BF\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 F3BF7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F3BF7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F380BF tcl8 \u00F3\u20AC\u00BF -1 {} {Missing third trail byte} + utf-8 F380BF replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F380BF strict {} 0 {} {Missing third trail byte} + utf-8 F3BF81 tcl8 \u00F3\u00BF\u0081 -1 {} {Missing third trail byte} + utf-8 F3BF81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F3BF81 strict {} 0 {} {Missing third trail byte} + utf-8 F3BF807F tcl8 \u00F3\u00BF\u20AC\x7F -1 {} {Third trail byte must be 80:BF} + utf-8 F3BF817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F3BF817F strict {} 0 {} {Third trail byte must be 80:BF} + utf-8 F380BFD0 tcl8 \u00F3\u20AC\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} + utf-8 F380BFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F380BFD0 strict {} 0 {} {Third trail byte must be 80:BF} + + utf-8 F4 tcl8 \u00F4 -1 {} {Missing trail byte} + utf-8 F4 replace \uFFFD -1 {} {Missing trail byte} + utf-8 F4 strict {} 0 {} {Missing trail byte} + utf-8 F47F tcl8 \u00F4\u7F -1 {} {First trail byte must be 80:8F} + utf-8 F47F replace \uFFFD\u7F -1 {knownW3C} {First trail byte must be 80:8F} + utf-8 F47F strict {} 0 {} {First trail byte must be 80:8F} + utf-8 F490 tcl8 \u00F4\u0090 -1 {} {First trail byte must be 80:8F} + utf-8 F490 replace \uFFFD\uFFFD -1 {} {First trail byte must be 80:8F} + utf-8 F490 strict {} 0 {} {First trail byte must be 80:8F} + utf-8 F480 tcl8 \u00F4\u20AC -1 {} {Missing second trail byte} + utf-8 F480 replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F480 strict {} 0 {} {Missing second trail byte} + utf-8 F48F tcl8 \u00F4\u008F -1 {} {Missing second trail byte} + utf-8 F48F replace \uFFFD -1 {knownW3C} {Missing second trail byte} + utf-8 F48F strict {} 0 {} {Missing second trail byte} + utf-8 F4807F tcl8 \u00F4\u20AC\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 F4807F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F4807F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F48F7F tcl8 \u00F4\u008F\x7F -1 {} {Second trail byte must be 80:BF} + utf-8 F48F7F replace \uFFFD\u7F -1 {knownW3C} {Second trail byte must be 80:BF} + utf-8 F48F7F strict {} 0 {} {Second trail byte must be 80:BF} + utf-8 F48081 tcl8 \u00F4\u20AC\u0081 -1 {} {Missing third trail byte} + utf-8 F48081 replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F48081 strict {} 0 {} {Missing third trail byte} + utf-8 F48F81 tcl8 \u00F4\u008F\u0081 -1 {} {Missing third trail byte} + utf-8 F48F81 replace \uFFFD -1 {knownW3C} {Missing third trail byte} + utf-8 F48F81 strict {} 0 {} {Missing third trail byte} + utf-8 F481817F tcl8 \u00F4\u0081\u0081\x7F -1 {} {Third trail byte must be 80:BF} + utf-8 F480817F replace \uFFFD\x7F -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F480817F strict {} 0 {} {Third trail byte must be 80:BF} + utf-8 F48FBFD0 tcl8 \u00F4\u008F\u00BF\u00D0 -1 {} {Third trail byte must be 80:BF} + utf-8 F48FBFD0 replace \uFFFD -1 {knownW3C} {Third trail byte must be 80:BF} + utf-8 F48FBFD0 strict {} 0 {} {Third trail byte must be 80:BF} + + utf-8 F5 tcl8 \u00F5 -1 {} {F5:FF are invalid everywhere} + utf-8 F5 replace \uFFFD -1 {} {F5:FF are invalid everywhere} + utf-8 F5 strict {} 0 {} {F5:FF are invalid everywhere} + utf-8 FF tcl8 \u00FF -1 {} {F5:FF are invalid everywhere} + utf-8 FF replace \uFFFD -1 {} {F5:FF are invalid everywhere} + utf-8 FF strict {} 0 {} {F5:FF are invalid everywhere} + + utf-8 C0AFE080BFF0818130 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {} {Unicode Table 3-8} + utf-8 EDA080EDBFBFEDAF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {knownW3C} {Unicode Table 3-9} + utf-8 F4919293FF4180BF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\uFFFD\u0041\uFFFD\uFFFD\x30 -1 {} {Unicode Table 3-10} + utf-8 E180E2F09192F1BF30 replace \uFFFD\uFFFD\uFFFD\uFFFD\x30 -1 {knownW3C} {Unicode Table 3.11} +} + +# utf16-le and utf16-be test cases. Note utf16 cases are automatically generated +# based on these depending on platform endianness. Note truncated tests can only +# happen when the sequence is at the end (including by itself) Thus {solo tail} +# in some cases. +lappend encInvalidBytes {*}{ + utf-16le 41 tcl8 \uFFFD -1 {solo tail} {Truncated} + utf-16le 41 replace \uFFFD -1 {solo tail} {Truncated} + utf-16le 41 strict {} 0 {solo tail} {Truncated} + utf-16le 00D8 tcl8 \uD800 -1 {} {Missing low surrogate} + utf-16le 00D8 replace \uFFFD -1 {knownBug} {Missing low surrogate} + utf-16le 00D8 strict {} 0 {knownBug} {Missing low surrogate} + utf-16le 00DC tcl8 \uDC00 -1 {} {Missing high surrogate} + utf-16le 00DC replace \uFFFD -1 {knownBug} {Missing high surrogate} + utf-16le 00DC strict {} 0 {knownBug} {Missing high surrogate} + + utf-16be 41 tcl8 \uFFFD -1 {solo tail} {Truncated} + utf-16be 41 replace \uFFFD -1 {solo tail} {Truncated} + utf-16be 41 strict {} 0 {solo tail} {Truncated} + utf-16be D800 tcl8 \uD800 -1 {} {Missing low surrogate} + utf-16be D800 replace \uFFFD -1 {knownBug} {Missing low surrogate} + utf-16be D800 strict {} 0 {knownBug} {Missing low surrogate} + utf-16be DC00 tcl8 \uDC00 -1 {} {Missing high surrogate} + utf-16be DC00 replace \uFFFD -1 {knownBug} {Missing high surrogate} + utf-16be DC00 strict {} 0 {knownBug} {Missing high surrogate} +} + +# utf32-le and utf32-be test cases. Note utf32 cases are automatically generated +# based on these depending on platform endianness. Note truncated tests can only +# happen when the sequence is at the end (including by itself) Thus {solo tail} +# in some cases. +lappend encInvalidBytes {*}{ + utf-32le 41 tcl8 \uFFFD -1 {solo tail} {Truncated} + utf-32le 41 replace \uFFFD -1 {solo} {Truncated} + utf-32le 41 strict {} 0 {solo tail} {Truncated} + utf-32le 4100 tcl8 \uFFFD -1 {solo tail} {Truncated} + utf-32le 4100 replace \uFFFD -1 {solo} {Truncated} + utf-32le 4100 strict {} 0 {solo tail} {Truncated} + utf-32le 410000 tcl8 \uFFFD -1 {solo tail} {Truncated} + utf-32le 410000 replace \uFFFD -1 {solo} {Truncated} + utf-32le 410000 strict {} 0 {solo tail} {Truncated} + utf-32le 00D80000 tcl8 \uD800 -1 {} {High-surrogate} + utf-32le 00D80000 replace \uFFFD -1 {} {High-surrogate} + utf-32le 00D80000 strict {} 0 {} {High-surrogate} + utf-32le 00DC0000 tcl8 \uDC00 -1 {} {Low-surrogate} + utf-32le 00DC0000 replace \uFFFD -1 {} {Low-surrogate} + utf-32le 00DC0000 strict {} 0 {} {Low-surrogate} + utf-32le 00D8000000DC0000 tcl8 \uD800\uDC00 -1 {} {High-low-surrogate-pair} + utf-32le 00D8000000DC0000 replace \uFFFD\uFFFD -1 {} {High-low-surrogate-pair} + utf-32le 00D8000000DC0000 strict {} 0 {} {High-low-surrogate-pair} + utf-32le 00001100 tcl8 \UFFFD -1 {} {Out of range} + utf-32le 00001100 replace \UFFFD -1 {} {Out of range} + utf-32le 00001100 strict {} 0 {} {Out of range} + utf-32le FFFFFFFF tcl8 \UFFFD -1 {} {Out of range} + utf-32le FFFFFFFF replace \UFFFD -1 {} {Out of range} + utf-32le FFFFFFFF strict {} 0 {} {Out of range} + + utf-32be 41 tcl8 \uFFFD -1 {solo tail} {Truncated} + utf-32be 41 replace \uFFFD -1 {solo tail} {Truncated} + utf-32be 41 strict {} 0 {solo tail} {Truncated} + utf-32be 0041 tcl8 \uFFFD -1 {solo tail} {Truncated} + utf-32be 0041 replace \uFFFD -1 {solo} {Truncated} + utf-32be 0041 strict {} 0 {solo tail} {Truncated} + utf-32be 000041 tcl8 \uFFFD -1 {solo tail} {Truncated} + utf-32be 000041 replace \uFFFD -1 {solo} {Truncated} + utf-32be 000041 strict {} 0 {solo tail} {Truncated} + utf-32be 0000D800 tcl8 \uD800 -1 {} {High-surrogate} + utf-32be 0000D800 replace \uFFFD -1 {} {High-surrogate} + utf-32be 0000D800 strict {} 0 {} {High-surrogate} + utf-32be 0000DC00 tcl8 \uDC00 -1 {} {Low-surrogate} + utf-32be 0000DC00 replace \uFFFD -1 {} {Low-surrogate} + utf-32be 0000DC00 strict {} 0 {} {Low-surrogate} + utf-32be 0000D8000000DC00 tcl8 \uD800\uDC00 -1 {} {High-low-surrogate-pair} + utf-32be 0000D8000000DC00 replace \uFFFD\uFFFD -1 {} {High-low-surrogate-pair} + utf-32be 0000D8000000DC00 strict {} 0 {} {High-low-surrogate-pair} + utf-32be 00110000 tcl8 \UFFFD -1 {} {Out of range} + utf-32be 00110000 replace \UFFFD -1 {} {Out of range} + utf-32be 00110000 strict {} 0 {} {Out of range} + utf-32be FFFFFFFF tcl8 \UFFFD -1 {} {Out of range} + utf-32be FFFFFFFF replace \UFFFD -1 {} {Out of range} + utf-32be FFFFFFFF strict {} 0 {} {Out of range} +} + +# Strings that cannot be encoded for specific encoding / profiles +# +# should be unique for test ids to be unique. +# See earlier comments about CTRL field. +# +# Note utf-16, utf-32 missing because they are automatically +# generated based on le/be versions. +# TODO - out of range code point (note cannot be generated by \U notation) +lappend encUnencodableStrings {*}{ + ascii \u00e0 tcl8 3f -1 {} {unencodable} + ascii \u00e0 strict {} 0 {} {unencodable} + + iso8859-1 \u0141 tcl8 3f -1 {} unencodable + iso8859-1 \u0141 strict {} 0 {} unencodable + + utf-8 \uD800 tcl8 eda080 -1 {} High-surrogate + utf-8 \uD800 strict {} 0 {} High-surrogate + utf-8 \uDC00 tcl8 edb080 -1 {} High-surrogate + utf-8 \uDC00 strict {} 0 {} High-surrogate +} + + +# The icuUcmTests.tcl is generated by the tools/ucm2tests.tcl script +# and generates test vectors for the above tables for various encodings +# based on ICU UCM files. +# TODO - commented out for now as generating a lot of mismatches. +# source [file join [file dirname [info script]] icuUcmTests.tcl] -- cgit v0.12 From 99a24e7883c680bb555d044a04e458a57be677a1 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 24 Feb 2023 10:32:37 +0000 Subject: Raise error on invalid flags --- generic/tclEncoding.c | 24 +++++++++++++++++++++++- 1 file changed, 23 insertions(+), 1 deletion(-) diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index d969779..00ca5e8 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -1275,7 +1275,18 @@ Tcl_ExternalToUtfDStringEx( Tcl_Size dstLen; const char *srcStart = src; - Tcl_DStringInit(dstPtr); /* Must always be initialized before returning */ + /* DO FIRST - Must always be initialized before returning */ + Tcl_DStringInit(dstPtr); + + if (flags & (TCL_ENCODING_START|TCL_ENCODING_END)) { + /* TODO - what other flags are illegal? - See TIP 656 */ + Tcl_SetResult(interp, + "Parameter error: TCL_ENCODING_{START,STOP} bits set in flags.", + TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALFLAGS", NULL); + return TCL_ERROR; + } + dst = Tcl_DStringValue(dstPtr); dstLen = dstPtr->spaceAvl - 1; @@ -1559,7 +1570,18 @@ Tcl_UtfToExternalDStringEx( const char *srcStart = src; Tcl_Size dstLen; + /* DO FIRST - must always be initialized on return */ Tcl_DStringInit(dstPtr); + + if (flags & (TCL_ENCODING_START|TCL_ENCODING_END)) { + /* TODO - what other flags are illegal? - See TIP 656 */ + Tcl_SetResult(interp, + "Parameter error: TCL_ENCODING_{START,STOP} bits set in flags.", + TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALFLAGS", NULL); + return TCL_ERROR; + } + dst = Tcl_DStringValue(dstPtr); dstLen = dstPtr->spaceAvl - 1; -- cgit v0.12 From 58db3d68eb1d0fba5c0e0b3ffff602acbfb2a12a Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Fri, 24 Feb 2023 13:34:15 +0000 Subject: Add teststringobj newunicode command to test invalid input to Tcl_NewUnicodeObj --- generic/tclTestObj.c | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index c9a910a..fa91d67 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -1269,7 +1269,7 @@ TeststringobjCmd( static const char *const options[] = { "append", "appendstrings", "get", "get2", "length", "length2", "set", "set2", "setlength", "maxchars", "range", "appendself", - "appendself2", NULL + "appendself2", "newunicode", NULL }; if (objc < 3) { @@ -1513,7 +1513,24 @@ TeststringobjCmd( Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + length, size - length); Tcl_SetObjResult(interp, varPtr[varIndex]); break; - } + case 13: /* newunicode*/ + unicode = ckalloc((objc - 3) * sizeof(Tcl_UniChar)); + for (i = 0; i < (objc - 3); ++i) { + int val; + if (Tcl_GetIntFromObj(interp, objv[i + 3], &val) != TCL_OK) { + break; + } + unicode[i] = (Tcl_UniChar)val; + } + if (i < (objc-3)) { + ckfree(unicode); + return TCL_ERROR; + } + SetVarToObj(varPtr, varIndex, Tcl_NewUnicodeObj(unicode, objc - 3)); + Tcl_SetObjResult(interp, varPtr[varIndex]); + ckfree(unicode); + break; + } return TCL_OK; } -- cgit v0.12 From 8390c51fcaeaa278ec7ec40ec5d31ee187c25208 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 25 Feb 2023 07:35:21 +0000 Subject: Fix [1d074b177a]. Failure to read .tclshrc --- unix/tclAppInit.c | 11 ++++++----- win/tclAppInit.c | 7 +++++-- 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c index 05d25de..e3d95bc 100644 --- a/unix/tclAppInit.c +++ b/unix/tclAppInit.c @@ -158,15 +158,16 @@ Tcl_AppInit( * is the name of the application. If this line is deleted then no * user-specific startup file will be run under any conditions. */ - #ifdef DJGPP - Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", TCL_INDEX_NONE), NULL, - Tcl_NewStringObj("~/tclsh.rc", TCL_INDEX_NONE), TCL_GLOBAL_ONLY); +#define INITFILENAME "tclshrc.tcl" #else - Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", TCL_INDEX_NONE), NULL, - Tcl_NewStringObj("~/.tclshrc", TCL_INDEX_NONE), TCL_GLOBAL_ONLY); +#define INITFILENAME ".tclshrc" #endif + (void)Tcl_EvalEx(interp, + "set tcl_rcFileName [file tildeexpand ~/" INITFILENAME "]", + -1, + TCL_EVAL_GLOBAL); return TCL_OK; } diff --git a/win/tclAppInit.c b/win/tclAppInit.c index 30127fd..077500a 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -215,8 +215,11 @@ Tcl_AppInit( * user-specific startup file will be run under any conditions. */ - Tcl_ObjSetVar2(interp, Tcl_NewStringObj("tcl_rcFileName", TCL_INDEX_NONE), NULL, - Tcl_NewStringObj("~/tclshrc.tcl", TCL_INDEX_NONE), TCL_GLOBAL_ONLY); + (void)Tcl_EvalEx(interp, + "set tcl_rcFileName [file tildeexpand ~/tclshrc.tcl]", + -1, + TCL_EVAL_GLOBAL); + return TCL_OK; } -- cgit v0.12 From a826e66f11a2823847cb7788a1d929a9799c95ad Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 25 Feb 2023 08:58:31 +0000 Subject: Add tests for Bug [46dda6fc29] --- tests/dstring.test | 32 ++++++++++++++++++++++++++++++++ 1 file changed, 32 insertions(+) diff --git a/tests/dstring.test b/tests/dstring.test index 314cee8..8699a5e 100644 --- a/tests/dstring.test +++ b/tests/dstring.test @@ -211,6 +211,38 @@ test dstring-2.15 {appending list elements} -constraints testdstring -setup { } -cleanup { testdstring free } -result {x #} +test dstring-2.16 {appending list elements - bug [46dda6fc29] segfault} -constraints testdstring -setup { + testdstring free +} -body { + testdstring element "\\\n"; # Will setfault + testdstring get +} -cleanup { + testdstring free +} -result {} +test dstring-2.17 {appending list elements - bug [46dda6fc29] segfault} -constraints testdstring -setup { + testdstring free +} -body { + testdstring element "\\\{"; # Will setfault + testdstring get +} -cleanup { + testdstring free +} -result {} +test dstring-2.18 {appending list elements - bug [46dda6fc29] segfault} -constraints testdstring -setup { + testdstring free +} -body { + testdstring element "\\\}"; # Will setfault + testdstring get +} -cleanup { + testdstring free +} -result {} +test dstring-2.19 {appending list elements - bug [46dda6fc29] segfault} -constraints testdstring -setup { + testdstring free +} -body { + testdstring element "\\\\"; # Will setfault + testdstring get +} -cleanup { + testdstring free +} -result {} test dstring-3.1 {nested sublists} -constraints testdstring -setup { testdstring free -- cgit v0.12 From aa2b48262b02b2f6f23ba7f032f8ea1fb0bddbe3 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 25 Feb 2023 09:26:06 +0000 Subject: Fix and tests for [46dda6fc29] --- generic/tclUtil.c | 4 ++-- tests/dstring.test | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff