diff options
154 files changed, 4362 insertions, 4361 deletions
diff --git a/library/clock.tcl b/library/clock.tcl index 0696c47..0504d47 100644 --- a/library/clock.tcl +++ b/library/clock.tcl @@ -20,7 +20,7 @@ uplevel \#0 { package require msgcat 1.4 - if { $::tcl_platform(platform) eq {windows} } { + if { $::tcl_platform(platform) eq "windows" } { if { [catch { package require registry 1.1 }] } { namespace eval ::tcl::clock [list variable NoRegistry {}] } @@ -85,7 +85,7 @@ namespace eval ::tcl::clock { proc ::tcl::clock::Initialize {} { - rename ::tcl::clock::Initialize {} + rename ::tcl::clock::Initialize "" variable LibDir @@ -254,9 +254,9 @@ proc ::tcl::clock::Initialize {} { # Number of days in the months, in common years and leap years. variable DaysInRomanMonthInCommonYear \ - { 31 28 31 30 31 30 31 31 30 31 30 31 } + [list 31 28 31 30 31 30 31 31 30 31 30 31] variable DaysInRomanMonthInLeapYear \ - { 31 29 31 30 31 30 31 31 30 31 30 31 } + [list 31 29 31 30 31 30 31 31 30 31 30 31] variable DaysInPriorMonthsInCommonYear [list 0] variable DaysInPriorMonthsInLeapYear [list 0] set i 0 @@ -710,7 +710,7 @@ proc ::tcl::clock::format { args } { #---------------------------------------------------------------------- proc ::tcl::clock::ParseClockFormatFormat {procName format locale} { - if {[namespace which $procName] ne {}} { + if {[namespace which $procName] ne ""} { return $procName } @@ -734,7 +734,7 @@ proc ::tcl::clock::ParseClockFormatFormat {procName format locale} { } } -proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { +proc ::tcl::clock::ParseClockFormatFormat2 {a_format locale procName} { set didLocaleEra 0 set didLocaleNumerals 0 set preFormatCode \ @@ -746,23 +746,22 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { $TZData($timezone) \ @GREGORIAN_CHANGE_DATE@] }] - set formatString {} - set substituents {} - set state {} + set formatString "" + set substituents "" + set state "" + set format [LocalizeFormat $locale $a_format] - set format [LocalizeFormat $locale $format] - - foreach char [split $format {}] { + foreach char [split $format ""] { switch -exact -- $state { {} { - if { [string equal % $char] } { + if { "%" eq $char } { set state percent } else { append formatString $char } } percent { # Character following a '%' character - set state {} + set state "" switch -exact -- $char { % { # A literal character, '%' append formatString %% @@ -1031,11 +1030,11 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { } } percentE { # Character following %E - set state {} + set state "" switch -exact -- $char { E { append formatString %s - append substituents { } \ + append substituents " " \ [string map \ [list @BCE@ [list [mc BCE]] \ @CE@ [list [mc CE]]] \ @@ -1064,7 +1063,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { } } percentO { # Character following %O - set state {} + set state "" switch -exact -- $char { d - e { # Day of the month in alternative # numerals @@ -1142,6 +1141,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { } } } + default {} } } @@ -1157,6 +1157,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { percentO { append retval %%O } + default {} } proc $procName {clockval timezone} " @@ -1181,11 +1182,9 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { #---------------------------------------------------------------------- proc ::tcl::clock::scan { args } { - set format {} - # Check the count of args - if { [llength $args] < 1 || [llength $args] % 2 != 1 } { + if { ([llength $args] < 1) || (([llength $args] % 2) != 1) } { set cmdName "clock scan" return -code error \ -errorcode [list CLOCK wrongNumArgs] \ @@ -1200,7 +1199,7 @@ proc ::tcl::clock::scan { args } { set base [clock seconds] set string [lindex $args 0] - set format {} + set format "" set gmt 0 set locale c set timezone [GetSystemTimeZone] @@ -1208,7 +1207,7 @@ proc ::tcl::clock::scan { args } { # Pick up command line options. foreach { flag value } [lreplace $args 0 0] { - set saw($flag) {} + set saw($flag) "" switch -exact -- $flag { -b - -ba - -bas - -base { set base $value @@ -1325,6 +1324,8 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { # Parse the date. The parser will return a list comprising date, time, # time zone, relative month/day/seconds, relative weekday, ordinal month. + lassign "" parseDate parseTime parseZone parseRel \ + parseWeekday parseOrdinalMonth try { set scanned [Oldscan $string \ @@ -1356,7 +1357,7 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { dict set date year $y dict set date month $m dict set date dayOfMonth $d - if { $parseTime eq {} } { + if { $parseTime eq "" } { set parseTime 0 } } @@ -1370,7 +1371,7 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { if { [llength $parseZone] > 0 } { lassign $parseZone minEast dstFlag set timezone [FormatNumericTimeZone \ - [expr { 60 * $minEast + 3600 * $dstFlag }]] + [expr { (60 * $minEast) + (3600 * $dstFlag) }]] SetupTimeZone $timezone } dict set date tzName $timezone @@ -1378,13 +1379,13 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { # Assemble date, time, zone into seconds-from-epoch set date [GetJulianDayFromEraYearMonthDay $date[set date {}] 2361222] - if { $parseTime ne {} } { + if { $parseTime ne "" } { dict set date secondOfDay $parseTime - } elseif { [llength $parseWeekday] != 0 - || [llength $parseOrdinalMonth] != 0 - || ( [llength $parseRel] != 0 - && ( [lindex $parseRel 0] != 0 - || [lindex $parseRel 1] != 0 ) ) } { + } elseif { ([llength $parseWeekday] != 0) || + ([llength $parseOrdinalMonth] != 0) || + ( ([llength $parseRel] != 0) && + ( ([lindex $parseRel 0] != 0) || + ([lindex $parseRel 1] != 0) ) ) } { dict set date secondOfDay 0 } @@ -1487,11 +1488,11 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { # #---------------------------------------------------------------------- -proc ::tcl::clock::ParseClockScanFormat {formatString locale} { +proc ::tcl::clock::ParseClockScanFormat {a_formatString locale} { # Check whether the format has been parsed previously, and return the # existing recognizer if it has. - set procName scanproc'$formatString'$locale + set procName scanproc'$a_formatString'$locale set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName] if { [namespace which $procName] != {} } { return $procName @@ -1502,11 +1503,11 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { # Localize the %x, %X, etc. groups - set formatString [LocalizeFormat $locale $formatString] + set formatString [LocalizeFormat $locale $a_formatString] # Condense whitespace - regsub -all {[[:space:]]+} $formatString { } formatString + regsub -all {[[:space:]]+} $formatString " " formatString # Walk through the groups of the format string. In this loop, we # accumulate: @@ -1518,17 +1519,17 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { set re {^[[:space:]]*} set captureCount 0 - set postcode {} + set postcode "" set fieldSet [dict create] set fieldCount 0 - set postSep {} - set state {} + set postSep "" + set state "" - foreach c [split $formatString {}] { + foreach c [split $formatString ""] { switch -exact -- $state { {} { if { $c eq "%" } { - set state % + set state "%" } elseif { $c eq " " } { append re {[[:space:]]+} } else { @@ -1539,10 +1540,10 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { } } % { - set state {} + set state "" switch -exact -- $c { % { - append re % + append re "%" } { } { append re "\[\[:space:\]\]*" @@ -1782,12 +1783,12 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { \} \n \ } % { # Literal percent character - append re % + append re "%" } default { append re % if { ! [string is alnum $c] } { - append re \\ + append re "\\" } append re $c } @@ -1827,14 +1828,14 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { incr captureCount } default { - append re %E + append re "%E" if { ! [string is alnum $c] } { - append re \\ + append re "\\" } append re $c } } - set state {} + set state "" } %O { switch -exact -- $c { @@ -1918,15 +1919,16 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { [incr captureCount] \] \n } default { - append re %O + append re "%O" if { ! [string is alnum $c] } { - append re \\ + append re "\\" } append re $c } } - set state {} + set state "" } + default {} } } @@ -1956,8 +1958,8 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { # Set up the time zone before doing anything with a default base date # that might need a timezone to interpret it. - if { ![dict exists $fieldSet seconds] - && ![dict exists $fieldSet starDate] } { + if { (![dict exists $fieldSet seconds]) && + (![dict exists $fieldSet starDate]) } { if { [dict exists $fieldSet tzName] } { append procBody { set timeZone [dict get $date tzName] @@ -1980,8 +1982,8 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { # Convert to local time unless epoch seconds or stardate are # being processed - they're always absolute - if { ![dict exists $fieldSet seconds] - && ![dict exists $fieldSet starDate] } { + if { (![dict exists $fieldSet seconds]) + && (![dict exists $fieldSet starDate]) } { append procBody { if { [dict get $date julianDay] > 5373484 } { return -code error -errorcode [list CLOCK dateTooLarge] \ @@ -2091,8 +2093,8 @@ proc ::tcl::clock::UniquePrefixRegexp { data } { foreach { key value } $data { # Construct all prefixes of the key; - set prefix {} - foreach char [split $key {}] { + set prefix "" + foreach char [split $key ""] { set oldPrefix $prefix dict set successors $oldPrefix $char {} append prefix $char @@ -2159,25 +2161,25 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors set schars [lsort -ascii [dict keys [dict get $successors $prefixString]]] if { [llength $schars] == 0 } { - return {} + return "" } # If there is more than one successor character, or if the current prefix # is a unique prefix, surround the generated re with non-capturing # parentheses. - set re {} + set re "" if { [dict exists $uniquePrefixMapping $prefixString] - || [llength $schars] > 1 - } then { - append re "(?:" + || ([llength $schars] > 1) + } { + append re "\(?:" } # Generate a regexp that matches the successors. set sep "" - foreach { c } $schars { + foreach c $schars { set nextPrefix $prefixString$c regsub -all {[^[:alnum:]]} $c \\\\& rechar append re $sep $rechar \ @@ -2191,9 +2193,9 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors # close the non-capturing parentheses. if { [dict exists $uniquePrefixMapping $prefixString] } { - append re ")?" + append re "\)?" } elseif { [llength $schars] > 1 } { - append re ")" + append re "\)" } return $re @@ -2263,10 +2265,10 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { if { $prio == $currPrio } { foreach currPos $currFieldPos newPos $fPos { if { - ![string is integer $newPos] - || ![string is integer $currPos] - || $newPos > $currPos - } then { + (![string is integer $newPos]) + || (![string is integer $currPos]) + || ($newPos > $currPos) + } { break } if { $newPos < $currPos } { @@ -2313,12 +2315,14 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { proc ::tcl::clock::EnterLocale { locale oldLocaleVar } { upvar 1 $oldLocaleVar oldLocale + global tcl_platform + variable MsgDir variable McLoaded set oldLocale [mclocale] - if { $locale eq {system} } { - if { $::tcl_platform(platform) ne {windows} } { + if { $locale eq "system" } { + if { $tcl_platform(platform) ne "windows" } { # On a non-windows platform, the 'system' locale is the same as # the 'current' locale @@ -2344,7 +2348,7 @@ proc ::tcl::clock::EnterLocale { locale oldLocaleVar } { } } } - if { $locale eq {current}} { + if { $locale eq "current"} { set locale $oldLocale unset oldLocale } elseif { $locale eq $oldLocale } { @@ -2390,9 +2394,9 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { registry get "HKEY_CURRENT_USER\\Control Panel\\International" \ sShortDate } string] } { - set quote {} - set datefmt {} - foreach { unquoted quoted } [split $string '] { + set quote "" + set datefmt "" + foreach { unquoted quoted } [split $string "'"] { append datefmt $quote [string map { dddd %A ddd %a @@ -2407,7 +2411,7 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { y %y gg {} } $unquoted] - if { $quoted eq {} } { + if { $quoted eq "" } { set quote ' } else { set quote $quoted @@ -2420,9 +2424,9 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { registry get "HKEY_CURRENT_USER\\Control Panel\\International" \ sLongDate } string] } { - set quote {} - set ldatefmt {} - foreach { unquoted quoted } [split $string '] { + set quote "" + set ldatefmt "" + foreach { unquoted quoted } [split $string "'"] { append ldatefmt $quote [string map { dddd %A ddd %a @@ -2437,7 +2441,7 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { y %y gg {} } $unquoted] - if { $quoted eq {} } { + if { $quoted eq "" } { set quote ' } else { set quote $quoted @@ -2450,9 +2454,9 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { registry get "HKEY_CURRENT_USER\\Control Panel\\International" \ sTimeFormat } string] } { - set quote {} - set timefmt {} - foreach { unquoted quoted } [split $string '] { + set quote "" + set timefmt "" + foreach { unquoted quoted } [split $string "'"] { append timefmt $quote [string map { HH %H H %k @@ -2465,7 +2469,7 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { tt %p t %p } $unquoted] - if { $quoted eq {} } { + if { $quoted eq "" } { set quote ' } else { set quote $quoted @@ -2532,10 +2536,10 @@ proc ::tcl::clock::LocalizeFormat { locale format } { lappend list %Ex [string map $list [mc LOCALE_DATE_FORMAT]] lappend list %c [string map $list [mc DATE_TIME_FORMAT]] lappend list %Ec [string map $list [mc LOCALE_DATE_TIME_FORMAT]] - set format [string map $list $format] + set locFormat [string map $list $format] - dict set McLoaded $locale FORMAT $inFormat $format - return $format + dict set McLoaded $locale FORMAT $inFormat $locFormat + return $locFormat } #---------------------------------------------------------------------- @@ -2607,9 +2611,9 @@ proc ::tcl::clock::FormatStarDate { date } { # Convert day of year to a fractional year if { $lp } { - set fractYear [expr { 1000 * $doy / 366 }] + set fractYear [expr { (1000 * $doy) / 366 }] } else { - set fractYear [expr { 1000 * $doy / 365 }] + set fractYear [expr { (1000 * $doy) / 365 }] } # Put together the StarDate @@ -2617,7 +2621,7 @@ proc ::tcl::clock::FormatStarDate { date } { return [::format "Stardate %02d%03d.%1d" \ [expr { [dict get $date year] - $Roddenberry }] \ $fractYear \ - [expr { [dict get $date localSeconds] % 86400 + [expr { ([dict get $date localSeconds] % 86400) / ( 86400 / 10 ) }]] } @@ -2652,7 +2656,7 @@ proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { gregorian 1 \ era CE \ year [expr { $year + $Roddenberry }] \ - dayOfYear [expr { $fractYear * 365 / 1000 + 1 }]] + dayOfYear [expr { (($fractYear * 365) / 1000) + 1 }]] set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]] # Determine whether the given year is a leap year @@ -2664,19 +2668,19 @@ proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { if { $lp } { dict set date dayOfYear \ - [expr { $fractYear * 366 / 1000 + 1 }] + [expr { (($fractYear * 366) / 1000) + 1 }] } else { dict set date dayOfYear \ - [expr { $fractYear * 365 / 1000 + 1 }] + [expr { (($fractYear * 365) / 1000) + 1 }] } dict unset date julianDay dict unset date gregorian set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]] return [expr { - 86400 * [dict get $date julianDay] - - 210866803200 - + ( 86400 / 10 ) * $fractDay + ((86400 * [dict get $date julianDay]) + - 210866803200) + + (( 86400 / 10 ) * $fractDay) }] } @@ -2696,7 +2700,7 @@ proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { #---------------------------------------------------------------------- proc ::tcl::clock::ScanWide { str } { - set count [::scan $str {%ld %c} result junk] + set count [::scan $str "%ld %c" result junk] if { $count != 1 } { return -code error -errorcode [list CLOCK notAnInteger $str] \ "\"$str\" is not an integer" @@ -2979,8 +2983,8 @@ proc ::tcl::clock::InterpretHMSP { date } { proc ::tcl::clock::InterpretHMS { date } { return [expr { - ( [dict get $date hour] * 60 - + [dict get $date minute] ) * 60 + (( ([dict get $date hour] * 60) + + [dict get $date minute] ) * 60) + [dict get $date second] }] } @@ -3008,9 +3012,11 @@ proc ::tcl::clock::GetSystemTimeZone {} { variable CachedSystemTimeZone variable TimeZoneBad - if {[set result [getenv TCL_TZ]] ne {}} { + global tcl_platform + + if {[set result [getenv TCL_TZ]] ne ""} { set timezone $result - } elseif {[set result [getenv TZ]] ne {}} { + } elseif {[set result [getenv TZ]] ne ""} { set timezone $result } if {![info exists timezone]} { @@ -3018,11 +3024,11 @@ proc ::tcl::clock::GetSystemTimeZone {} { # expensive methods. if { [info exists CachedSystemTimeZone] } { set timezone $CachedSystemTimeZone - } elseif { $::tcl_platform(platform) eq {windows} } { + } elseif { $tcl_platform(platform) eq "windows" } { set timezone [GuessWindowsTimeZone] } elseif { [file exists /etc/localtime] - && ![catch {ReadZoneinfoFile \ - Tcl/Localtime /etc/localtime}] } { + && (![catch {ReadZoneinfoFile \ + Tcl/Localtime /etc/localtime}]) } { set timezone :Tcl/Localtime } else { set timezone :localtime @@ -3093,33 +3099,33 @@ proc ::tcl::clock::SetupTimeZone { timezone } { if {! [info exists TZData($timezone)] } { variable MINWIDE - if { $timezone eq {:localtime} } { + if { $timezone eq ":localtime" } { # Nothing to do, we'll convert using the localtime function } elseif { [regexp {^([-+])(\d\d)(?::?(\d\d)(?::?(\d\d))?)?} $timezone \ - -> s hh mm ss] - } then { + ___ s hh mm ss] + } { # Make a fixed offset ::scan $hh %d hh - if { $mm eq {} } { + if { $mm eq "" } { set mm 0 } else { ::scan $mm %d mm } - if { $ss eq {} } { + if { $ss eq "" } { set ss 0 } else { ::scan $ss %d ss } - set offset [expr { ( $hh * 60 + $mm ) * 60 + $ss }] - if { $s eq {-} } { + set offset [expr { (( ($hh * 60) + $mm ) * 60) + $ss }] + if { $s eq "-" } { set offset [expr { - $offset }] } set TZData($timezone) [list [list $MINWIDE $offset -1 $timezone]] - } elseif { [string index $timezone 0] eq {:} } { + } elseif { [string index $timezone 0] eq ":" } { # Convert using a time zone file if { @@ -3128,7 +3134,7 @@ proc ::tcl::clock::SetupTimeZone { timezone } { }] && [catch { LoadZoneinfoFile [string range $timezone 1 end] }] - } then { + } { return -code error \ -errorcode [list CLOCK badTimeZone $timezone] \ "time zone \"$timezone\" not found" @@ -3138,7 +3144,7 @@ proc ::tcl::clock::SetupTimeZone { timezone } { # This looks like a POSIX time zone - try to process it if { [catch {ProcessPosixTimeZone $tzfields} data opts] } { - if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } { + if { [lindex [dict get $opts -errorcode] 0] eq "CLOCK" } { dict unset opts -errorinfo } return -options $opts $data @@ -3150,8 +3156,8 @@ proc ::tcl::clock::SetupTimeZone { timezone } { # We couldn't parse this as a POSIX time zone. Try again with a # time zone file - this time without a colon - if { [catch { LoadTimeZoneFile $timezone }] - && [catch { LoadZoneinfoFile $timezone } - opts] } { + if { [catch { LoadTimeZoneFile $timezone }] && + [catch { LoadZoneinfoFile $timezone } ___ opts] } { dict unset opts -errorinfo return -options $opts "time zone $timezone not found" } @@ -3233,9 +3239,9 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { dict set TimeZoneBad $tzname [catch {SetupTimeZone $tzname}] } } else { - set tzname {} + set tzname "" } - if { $tzname eq {} || [dict get $TimeZoneBad $tzname] } { + if { ($tzname eq "") || [dict get $TimeZoneBad $tzname] } { lassign $data \ bias stdBias dstBias \ stdYear stdMonth stdDayOfWeek stdDayOfMonth \ @@ -3255,7 +3261,7 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { set hh [::format %02d [expr { $stdDelta / 3600 }]] set mm [::format %02d [expr { ($stdDelta / 60 ) % 60 }]] set ss [::format %02d [expr { $stdDelta % 60 }]] - set tzname {} + set tzname "" append tzname < $dispStdSignum $hh $mm > $stdSignum $hh : $mm : $ss if { $stdMonth >= 0 } { if { $dstDelta <= 0 } { @@ -3422,9 +3428,9 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { # Suck in all the data from the file set f [open $fname r] - fconfigure $f -translation binary - set d [read $f] - close $f + chan configure $f -translation binary + set d [chan read $f] + chan close $f # The file begins with a magic number, sixteen reserved bytes, and then # six 4-byte integers giving counts of fileds in the file. @@ -3451,16 +3457,16 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { if {$version eq "2"} { set seek [expr { 44 - + 5 * $nTime - + 6 * $nType - + 4 * $nLeap + + (5 * $nTime) + + (6 * $nType) + + (4 * $nLeap) + $nIsStd + $nIsGMT + $nChar }] binary scan $d @${seek}a4a1x15IIIIII \ magic version nIsGMT nIsStd nLeap nTime nType nChar - if {$magic ne {TZif}} { + if {$magic ne "TZif"} { return -code error "seek address $seek miscomputed, magic = $magic" } set iformat W @@ -3475,7 +3481,7 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { binary scan $d @${seek}${iformat}${nTime}c${nTime} times tempCodes incr seek [expr { ($ilen + 1) * $nTime }] set times [linsert $times 0 $MINWIDE] - set codes {} + set codes [list] foreach c $tempCodes { lappend codes [expr { $c & 0xff }] } @@ -3511,7 +3517,7 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { # Package up a list of tuples, each of which contains transition time, # seconds east of Greenwich, DST flag and time zone abbreviation. - set r {} + set r [list] set lastTime $MINWIDE foreach t $times c $codes { if { $t < $lastTime } { @@ -3528,10 +3534,10 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { # values (8 bytes each), # nIsStd standard/DST indicators and nIsGMT UTC/local indicators. - if {$version eq {2}} { - set seek [expr {$seek + 8 * $nLeap + $nIsStd + $nIsGMT + 1}] + if {$version eq "2"} { + set seek [expr {$seek + (8 * $nLeap) + $nIsStd + $nIsGMT + 1}] set last [string first \n $d $seek] - set posix [string range $d $seek [expr {$last-1}]] + set posix [string range $d $seek [expr {$last - 1}]] if {[llength $posix] > 0} { set posixFields [ParsePosixTimeZone $posix] foreach tuple [ProcessPosixTimeZone $posixFields] { @@ -3705,14 +3711,14 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { )? )? $ - } $tz -> x(stdName) x(stdSignum) x(stdHours) x(stdMinutes) x(stdSeconds) \ - x(dstName) x(dstSignum) x(dstHours) x(dstMinutes) x(dstSeconds) \ - x(startJ) x(startDayOfYear) \ - x(startMonth) x(startWeekOfMonth) x(startDayOfWeek) \ - x(startHours) x(startMinutes) x(startSeconds) \ - x(endJ) x(endDayOfYear) \ - x(endMonth) x(endWeekOfMonth) x(endDayOfWeek) \ - x(endHours) x(endMinutes) x(endSeconds)] } { + } $tz ___ x(stdName) x(stdSignum) x(stdHours) x(stdMinutes) x(stdSeconds) \ + x(dstName) x(dstSignum) x(dstHours) x(dstMinutes) x(dstSeconds) \ + x(startJ) x(startDayOfYear) \ + x(startMonth) x(startWeekOfMonth) x(startDayOfWeek) \ + x(startHours) x(startMinutes) x(startSeconds) \ + x(endJ) x(endDayOfYear) \ + x(endMonth) x(endWeekOfMonth) x(endDayOfWeek) \ + x(endHours) x(endMinutes) x(endSeconds)] } { # it's a good timezone return [array get x] @@ -3747,63 +3753,63 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { # Determine the standard time zone name and seconds east of Greenwich set stdName [dict get $z stdName] - if { [string index $stdName 0] eq {<} } { + if { [string index $stdName 0] eq "<" } { set stdName [string range $stdName 1 end-1] } - if { [dict get $z stdSignum] eq {-} } { + if { [dict get $z stdSignum] eq "-" } { set stdSignum +1 } else { set stdSignum -1 } set stdHours [lindex [::scan [dict get $z stdHours] %d] 0] - if { [dict get $z stdMinutes] ne {} } { + if { [dict get $z stdMinutes] ne "" } { set stdMinutes [lindex [::scan [dict get $z stdMinutes] %d] 0] } else { set stdMinutes 0 } - if { [dict get $z stdSeconds] ne {} } { + if { [dict get $z stdSeconds] ne "" } { set stdSeconds [lindex [::scan [dict get $z stdSeconds] %d] 0] } else { set stdSeconds 0 } set stdOffset [expr { - (($stdHours * 60 + $stdMinutes) * 60 + $stdSeconds) * $stdSignum + ((((($stdHours * 60) + $stdMinutes) * 60) + $stdSeconds) * $stdSignum) }] set data [list [list $MINWIDE $stdOffset 0 $stdName]] # If there's no daylight zone, we're done set dstName [dict get $z dstName] - if { $dstName eq {} } { + if { $dstName eq "" } { return $data } - if { [string index $dstName 0] eq {<} } { + if { [string index $dstName 0] eq "<" } { set dstName [string range $dstName 1 end-1] } # Determine the daylight name - if { [dict get $z dstSignum] eq {-} } { + if { [dict get $z dstSignum] eq "-" } { set dstSignum +1 } else { set dstSignum -1 } - if { [dict get $z dstHours] eq {} } { + if { [dict get $z dstHours] eq "" } { set dstOffset [expr { 3600 + $stdOffset }] } else { set dstHours [lindex [::scan [dict get $z dstHours] %d] 0] - if { [dict get $z dstMinutes] ne {} } { + if { [dict get $z dstMinutes] ne "" } { set dstMinutes [lindex [::scan [dict get $z dstMinutes] %d] 0] } else { set dstMinutes 0 } - if { [dict get $z dstSeconds] ne {} } { + if { [dict get $z dstSeconds] ne "" } { set dstSeconds [lindex [::scan [dict get $z dstSeconds] %d] 0] } else { set dstSeconds 0 } set dstOffset [expr { - (($dstHours*60 + $dstMinutes) * 60 + $dstSeconds) * $dstSignum + (((($dstHours * 60) + $dstMinutes) * 60) + $dstSeconds) * $dstSignum }] } @@ -3814,16 +3820,16 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { # EU end time is the last Sunday in October if { - [dict get $z startDayOfYear] eq {} - && [dict get $z startMonth] eq {} - } then { - if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} { + ([dict get $z startDayOfYear] eq "") + && ([dict get $z startMonth] eq "") + } { + if {(($stdSignum * $stdHours) >= 0) && (($stdSignum * $stdHours) <= 12)} { # EU dict set z startWeekOfMonth 5 - if {$stdHours>2} { + if {$stdHours > 2} { dict set z startHours 2 } else { - dict set z startHours [expr {$stdHours+1}] + dict set z startHours [expr {$stdHours + 1}] } } else { # US @@ -3836,17 +3842,17 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { dict set z startSeconds 0 } if { - [dict get $z endDayOfYear] eq {} - && [dict get $z endMonth] eq {} - } then { - if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} { + ([dict get $z endDayOfYear] eq "") + && ([dict get $z endMonth] eq "") + } { + if {(($stdSignum * $stdHours) >= 0) && (($stdSignum * $stdHours) <= 12)} { # EU dict set z endMonth 10 dict set z endWeekOfMonth 5 - if {$stdHours>2} { + if {$stdHours > 2} { dict set z endHours 3 } else { - dict set z endHours [expr {$stdHours+2}] + dict set z endHours [expr {$stdHours + 2}] } } else { # US @@ -3907,12 +3913,12 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { set date [dict create era CE year $y] set doy [dict get $z ${bound}DayOfYear] - if { $doy ne {} } { + if { $doy ne "" } { # Time was specified as a day of the year - if { [dict get $z ${bound}J] ne {} - && [IsGregorianLeapYear $y] - && ( $doy > $FEB_28 ) } { + if { ([dict get $z ${bound}J] ne "") && + [IsGregorianLeapYear $y] && + ($doy > $FEB_28) } { incr doy } dict set date dayOfYear $doy @@ -3933,28 +3939,28 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { set jd [dict get $date julianDay] set seconds [expr { - wide($jd) * wide(86400) - wide(210866803200) + ( wide($jd) * wide(86400) ) - wide(210866803200) }] set h [dict get $z ${bound}Hours] - if { $h eq {} } { + if { $h eq "" } { set h 2 } else { set h [lindex [::scan $h %d] 0] } set m [dict get $z ${bound}Minutes] - if { $m eq {} } { + if { $m eq "" } { set m 0 } else { set m [lindex [::scan $m %d] 0] } set s [dict get $z ${bound}Seconds] - if { $s eq {} } { + if { $s eq "" } { set s 0 } else { set s [lindex [::scan $s %d] 0] } - set tod [expr { ( $h * 60 + $m ) * 60 + $s }] + set tod [expr { ( (($h * 60) + $m ) * 60) + $s }] return [expr { $seconds + $tod }] } @@ -4032,6 +4038,7 @@ proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} { CE { set year [dict get $date year] } + default {} } set ym1 [expr { $year - 1 }] @@ -4039,12 +4046,12 @@ proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} { dict set date gregorian 1 set jd [expr { - 1721425 - + [dict get $date dayOfYear] - + ( 365 * $ym1 ) - + ( $ym1 / 4 ) - - ( $ym1 / 100 ) - + ( $ym1 / 400 ) + ((1721425 + + [dict get $date dayOfYear] + + ( 365 * $ym1 ) + + ( $ym1 / 4 )) - + ( $ym1 / 100 )) + + ( $ym1 / 400 ) }] # If the date is before the Gregorian change, use the Julian calendar. @@ -4103,7 +4110,7 @@ proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} { $changeover] set wd0 [WeekdayOnOrBefore [dict get $date dayOfWeek] \ [dict get $date2 julianDay]] - dict set date julianDay [expr { $wd0 + 7 * $week }] + dict set date julianDay [expr { $wd0 + (7 * $week) }] return $date } @@ -4134,14 +4141,15 @@ proc ::tcl::clock::IsGregorianLeapYear { date } { CE { set year [dict get $date year] } + default {} } - if { $year % 4 != 0 } { + if { ($year % 4) != 0 } { return 0 } elseif { ![dict get $date gregorian] } { return 1 - } elseif { $year % 400 == 0 } { + } elseif { ($year % 400) == 0 } { return 1 - } elseif { $year % 100 == 0 } { + } elseif { ($year % 100) == 0 } { return 0 } else { return 1 @@ -4169,7 +4177,7 @@ proc ::tcl::clock::IsGregorianLeapYear { date } { proc ::tcl::clock::WeekdayOnOrBefore { weekday j } { set k [expr { ( $weekday + 6 ) % 7 }] - return [expr { $j - ( $j - $k ) % 7 }] + return [expr { $j - ( ( $j - $k ) % 7 ) }] } #---------------------------------------------------------------------- @@ -4262,7 +4270,7 @@ proc ::tcl::clock::BSearch { list key } { #---------------------------------------------------------------------- proc ::tcl::clock::add { clockval args } { - if { [llength $args] % 2 != 0 } { + if { ([llength $args] % 2) != 0 } { set cmdName "clock add" return -code error \ -errorcode [list CLOCK wrongNumArgs] \ @@ -4270,11 +4278,11 @@ proc ::tcl::clock::add { clockval args } { \"$cmdName clockval ?number units?...\ ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?\"" } - if { [catch { expr {wide($clockval)} } result] } { + if { [catch { expr { wide ($clockval) } } result] } { return -code error $result } - set offsets {} + set offsets [list] set gmt 0 set locale c set timezone [GetSystemTimeZone] @@ -4558,16 +4566,16 @@ proc ::tcl::clock::ClearCaches {} { variable TimeZoneBad foreach p [info procs [namespace current]::scanproc'*] { - rename $p {} + rename $p "" } foreach p [info procs [namespace current]::formatproc'*] { - rename $p {} + rename $p "" } - catch {unset FormatProc} + unset -nocomplain FormatProc set LocaleNumeralCache {} set McLoaded {} - catch {unset CachedSystemTimeZone} + unset -nocomplain CachedSystemTimeZone set TimeZoneBad {} InitTZData } diff --git a/library/history.tcl b/library/history.tcl index 51d2404..1580576 100644 --- a/library/history.tcl +++ b/library/history.tcl @@ -74,9 +74,9 @@ proc ::tcl::HistAdd {event {exec {}}} { variable history if { - [prefix longest {exec {}} $exec] eq "" - && [llength [info level 0]] == 3 - } then { + ([::tcl::prefix longest {exec {}} $exec] eq "") && + ([llength [info level 0]] == 3) + } { return -code error "bad argument \"$exec\": should be \"exec\"" } @@ -114,7 +114,7 @@ proc ::tcl::HistKeep {{count {}}} { if {[llength [info level 0]] == 1} { return $history(keep) } - if {![string is integer -strict $count] || ($count < 0)} { + if {(![string is integer -strict $count]) || ($count < 0)} { return -code error "illegal keep count \"$count\"" } set oldold $history(oldest) @@ -124,7 +124,7 @@ proc ::tcl::HistKeep {{count {}}} { } set history(keep) $count } - + # tcl::HistClear -- # # Erase the history list @@ -166,9 +166,9 @@ proc ::tcl::HistInfo {{count {}}} { } elseif {![string is integer -strict $count]} { return -code error "bad integer \"$count\"" } - set result {} + set result "" set newline "" - for {set i [expr {$history(nextid) - $count + 1}]} \ + for {set i [expr {($history(nextid) - $count) + 1}]} \ {$i <= $history(nextid)} {incr i} { if {![info exists history($i)]} { continue @@ -179,7 +179,7 @@ proc ::tcl::HistInfo {{count {}}} { } return $result } - + # tcl::HistRedo -- # # Fetch the previous or specified event, execute it, and then replace @@ -225,7 +225,7 @@ proc ::tcl::HistRedo {{event -1}} { proc ::tcl::HistIndex {event} { variable history if {![string is integer -strict $event]} { - for {set i [expr {$history(nextid)-1}]} {[info exists history($i)]} \ + for {set i [expr {$history(nextid) - 1}]} {[info exists history($i)]} \ {incr i -1} { if {[string match $event* $history($i)]} { return $i diff --git a/library/http/http.tcl b/library/http/http.tcl index ddf066e..9441acc 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -55,7 +55,7 @@ namespace eval http { if {[info exists socketmap]} { # Close but don't remove open sockets on re-init foreach {url sock} [array get socketmap] { - catch {close $sock} + catch {chan close $sock} } } array set socketmap {} @@ -149,7 +149,7 @@ proc http::config {args} { set options [lsort [array names http -*]] set usage [join $options ", "] if {[llength $args] == 0} { - set result {} + set result [list] foreach name $options { lappend result $name $http($name) } @@ -189,7 +189,7 @@ proc http::config {args} { # Closes the socket proc http::Finish {token {errormsg ""} {skipCB 0}} { - variable $token + variable [set token] upvar 0 $token state global errorInfo errorCode if {$errormsg ne ""} { @@ -197,7 +197,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { set state(status) "error" } if { - ($state(status) eq "timeout") || ($state(status) eq "error") || + ($state(status) in "timeout error") || ([info exists state(connection)] && ($state(connection) eq "close")) } { CloseSocket $state(sock) $token @@ -205,10 +205,10 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { if {[info exists state(after)]} { after cancel $state(after) } - if {[info exists state(-command)] && !$skipCB - && ![info exists state(done-command-cb)]} { + if {[info exists state(-command)] && (!$skipCB) + && (![info exists state(done-command-cb)])} { set state(done-command-cb) yes - if {[catch {eval $state(-command) {$token}} err] && $errormsg eq ""} { + if {[catch {eval $state(-command) {$token}} err] && ($errormsg eq "")} { set state(error) [list $err $errorInfo $errorCode] set state(status) error } @@ -224,10 +224,10 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { proc ::http::CloseSocket {s {token {}}} { variable socketmap - catch {fileevent $s readable {}} - set conn_id {} + catch {chan event $s readable {}} + set conn_id "" if {$token ne ""} { - variable $token + variable [set token] upvar 0 $token state if {[info exists state(socketinfo)]} { set conn_id $state(socketinfo) @@ -240,15 +240,15 @@ proc ::http::CloseSocket {s {token {}}} { set conn_id [lindex $map $ndx] } } - if {$conn_id eq {} || ![info exists socketmap($conn_id)]} { + if {($conn_id eq "") || (![info exists socketmap($conn_id)])} { Log "Closing socket $s (no connection info)" - if {[catch {close $s} err]} { + if {[catch {chan close $s} err]} { Log "Error: $err" } } else { if {[info exists socketmap($conn_id)]} { Log "Closing connection $conn_id (sock $socketmap($conn_id))" - if {[catch {close $socketmap($conn_id)} err]} { + if {[catch {chan close $socketmap($conn_id)} err]} { Log "Error: $err" } unset socketmap($conn_id) @@ -270,11 +270,11 @@ proc ::http::CloseSocket {s {token {}}} { # See Finish proc http::reset {token {why reset}} { - variable $token + variable [set token] upvar 0 $token state set state(status) $why - catch {fileevent $state(sock) readable {}} - catch {fileevent $state(sock) writable {}} + catch {chan event $state(sock) readable {}} + catch {chan event $state(sock) writable {}} Finish $token if {[info exists state(error)]} { set errorlist $state(error) @@ -309,7 +309,7 @@ proc http::geturl {url args} { set http(uid) 0 } set token [namespace current]::[incr http(uid)] - variable $token + variable [set token] upvar 0 $token state reset $token @@ -363,16 +363,16 @@ proc http::geturl {url args} { if {[regexp -- $pat $flag]} { # Validate numbers if { - [info exists type($flag)] && - ![string is $type($flag) -strict $value] + [info exists type($flag)] && + (![string is $type($flag) -strict $value]) } { - unset $token + unset -- [set token] return -code error \ "Bad value for $flag ($value), must be $type($flag)" } set state($flag) $value } else { - unset $token + unset -- [set token] return -code error "Unknown option $flag, can be: $usage" } } @@ -382,7 +382,7 @@ proc http::geturl {url args} { set isQueryChannel [info exists state(-querychannel)] set isQuery [info exists state(-query)] if {$isQuery && $isQueryChannel} { - unset $token + unset -- [set token] return -code error "Can't combine -query and -querychannel options!" } @@ -443,8 +443,8 @@ proc http::geturl {url args} { } # Phase one: parse - if {![regexp -- $URLmatcher $url -> proto user host port srvurl]} { - unset $token + if {![regexp -- $URLmatcher $url ___ proto user host port srvurl]} { + unset -- [set token] return -code error "Unsupported URL: $url" } # Phase two: validate @@ -452,13 +452,13 @@ proc http::geturl {url args} { if {$host eq ""} { # Caller has to provide a host name; we do not have a "default host" # that would enable us to handle relative URLs. - unset $token + unset -- [set token] return -code error "Missing host part: $url" # Note that we don't check the hostname for validity here; if it's # invalid, we'll simply fail to resolve it later on. } - if {$port ne "" && $port > 65535} { - unset $token + if {($port ne "") && ($port > 65535)} { + unset -- [set token] return -code error "Invalid port number: $port" } # The user identification and resource identification parts of the URL can @@ -470,8 +470,8 @@ proc http::geturl {url args} { (?: [-\w.~!$&'()*+,;=:] | %[0-9a-f][0-9a-f] )+ $ } - if {$state(-strict) && ![regexp -- $validityRE $user]} { - unset $token + if {$state(-strict) && (![regexp -- $validityRE $user])} { + unset -- [set token] # Provide a better error message in this error case if {[regexp {(?i)%(?![0-9a-f][0-9a-f]).?.?} $user bad]} { return -code error \ @@ -490,8 +490,8 @@ proc http::geturl {url args} { (?: \? (?: [-\w.~!$&'()*+,;=:@/?] | %[0-9a-f][0-9a-f] )* )? $ } - if {$state(-strict) && ![regexp -- $validityRE $srvurl]} { - unset $token + if {$state(-strict) && (![regexp -- $validityRE $srvurl])} { + unset -- [set token] # Provide a better error message in this error case if {[regexp {(?i)%(?![0-9a-f][0-9a-f])..} $srvurl bad]} { return -code error \ @@ -500,24 +500,22 @@ proc http::geturl {url args} { return -code error "Illegal characters in URL path" } } else { - set srvurl / + set srvurl "/" } if {$proto eq ""} { set proto http } if {![info exists urlTypes($proto)]} { - unset $token + unset -- [set token] return -code error "Unsupported URL type \"$proto\"" } - set defport [lindex $urlTypes($proto) 0] - set defcmd [lindex $urlTypes($proto) 1] + lassign $urlTypes($proto) defport defcmd if {$port eq ""} { set port $defport } if {![catch {$http(-proxyfilter) $host} proxy]} { - set phost [lindex $proxy 0] - set pport [lindex $proxy 1] + lassign $proxy phost pport } # OK, now reassemble into a full URL @@ -559,18 +557,18 @@ proc http::geturl {url args} { if {$state(-keepalive)} { variable socketmap if {[info exists socketmap($state(socketinfo))]} { - if {[catch {fconfigure $socketmap($state(socketinfo))}]} { + if {[catch {chan configure $socketmap($state(socketinfo))}]} { Log "WARNING: socket for $state(socketinfo) was closed" unset socketmap($state(socketinfo)) } else { set sock $socketmap($state(socketinfo)) Log "reusing socket $sock for $state(socketinfo)" - catch {fileevent $sock writable {}} - catch {fileevent $sock readable {}} + catch {chan event $sock writable {}} + catch {chan event $sock readable {}} } } # don't automatically close this connection socket - set state(connection) {} + set state(connection) "" } if {![info exists sock]} { # Pass -myaddr directly to the socket command @@ -591,7 +589,7 @@ proc http::geturl {url args} { } set state(sock) $sock Log "Using $sock for $state(socketinfo)" \ - [expr {$state(-keepalive)?"keepalive":""}] + [expr {$state(-keepalive) ? "keepalive" : ""}] if {$state(-keepalive)} { set socketmap($state(socketinfo)) $sock } @@ -645,12 +643,12 @@ proc http::Connected { token proto phost srvurl} { # Send data in cr-lf format, but accept any line terminators - fconfigure $sock -translation {auto crlf} -buffersize $state(-blocksize) + chan configure $sock -translation {auto crlf} -buffersize $state(-blocksize) # The following is disallowed in safe interpreters, but the socket is # already in non-blocking mode in that case. - catch {fconfigure $sock -blocking off} + catch {chan configure $sock -blocking off} set how GET if {$isQuery} { set state(querylength) [string length $state(-query)] @@ -668,10 +666,10 @@ proc http::Connected { token proto phost srvurl} { set how POST # The query channel must be blocking for the async Write to # work properly. - fconfigure $state(-querychannel) -blocking 1 -translation binary + chan configure $state(-querychannel) -blocking 1 -translation binary set contDone 0 } - if {[info exists state(-method)] && $state(-method) ne ""} { + if {[info exists state(-method)] && ($state(-method) ne "")} { set how $state(-method) } # We cannot handle chunked encodings with -handler, so force HTTP/1.0 @@ -695,10 +693,10 @@ proc http::Connected { token proto phost srvurl} { } unset hdrs puts $sock "User-Agent: $http(-useragent)" - if {$state(-protocol) == 1.0 && $state(-keepalive)} { + if {($state(-protocol) == 1.0) && $state(-keepalive)} { puts $sock "Connection: keep-alive" } - if {$state(-protocol) > 1.0 && !$state(-keepalive)} { + if {($state(-protocol) > 1.0) && (!$state(-keepalive))} { puts $sock "Connection: close" ;# RFC2616 sec 8.1.2.1 } if {[info exists phost] && ($phost ne "") && $state(-keepalive)} { @@ -726,10 +724,10 @@ proc http::Connected { token proto phost srvurl} { puts $sock "$key: $value" } } - if {!$accept_encoding_seen && ![info exists state(-handler)]} { + if {(!$accept_encoding_seen) && (![info exists state(-handler)])} { puts $sock "Accept-Encoding: deflate,gzip,compress" } - if {$isQueryChannel && $state(querylength) == 0} { + if {$isQueryChannel && ($state(querylength) == 0)} { # Try to determine size of data in channel. If we cannot seek, the # surrounding catch will trap us @@ -759,18 +757,18 @@ proc http::Connected { token proto phost srvurl} { if {$isQuery || $isQueryChannel} { if {!$content_type_seen} { - puts $sock "Content-Type: $state(-type)" + chan puts $sock "Content-Type: $state(-type)" } if {!$contDone} { - puts $sock "Content-Length: $state(querylength)" + chan puts $sock "Content-Length: $state(querylength)" } - puts $sock "" - fconfigure $sock -translation {auto binary} - fileevent $sock writable [list http::Write $token] + chan puts $sock "" + chan configure $sock -translation {auto binary} + chan event $sock writable [list http::Write $token] } else { - puts $sock "" - flush $sock - fileevent $sock readable [list http::Event $sock $token] + chan puts $sock "" + chan flush $sock + chan event $sock readable [list http::Event $sock $token] } } err]} { @@ -793,25 +791,25 @@ proc http::Connected { token proto phost srvurl} { # Size - the size of the URL data proc http::data {token} { - variable $token + variable [set token] upvar 0 $token state return $state(body) } proc http::status {token} { - if {![info exists $token]} { + if {![info exists [set token]]} { return "error" } - variable $token + variable [set token] upvar 0 $token state return $state(status) } proc http::code {token} { - variable $token + variable [set token] upvar 0 $token state return $state(http) } proc http::ncode {token} { - variable $token + variable [set token] upvar 0 $token state if {[regexp {[0-9]{3}} $state(http) numeric_code]} { return $numeric_code @@ -820,17 +818,17 @@ proc http::ncode {token} { } } proc http::size {token} { - variable $token + variable [set token] upvar 0 $token state return $state(currentsize) } proc http::meta {token} { - variable $token + variable [set token] upvar 0 $token state return $state(meta) } proc http::error {token} { - variable $token + variable [set token] upvar 0 $token state if {[info exists state(error)]} { return $state(error) @@ -849,7 +847,7 @@ proc http::error {token} { # unsets the state array proc http::cleanup {token} { - variable $token + variable [set token] upvar 0 $token state if {[info exists state]} { unset state @@ -868,16 +866,16 @@ proc http::cleanup {token} { # the waiting geturl call proc http::Connect {token proto phost srvurl} { - variable $token + variable [set token] upvar 0 $token state set err "due to unexpected EOF" if { - [eof $state(sock)] || - [set err [fconfigure $state(sock) -error]] ne "" + [chan eof $state(sock)] || + ([set err [chan configure $state(sock) -error]] ne "") } { Finish $token "connect failed $err" } else { - fileevent $state(sock) writable {} + chan event $state(sock) writable {} ::http::Connected $token $proto $phost $srvurl } return @@ -894,7 +892,7 @@ proc http::Connect {token proto phost srvurl} { # Write the socket and handle callbacks. proc http::Write {token} { - variable $token + variable [set token] upvar 0 $token state set sock $state(sock) @@ -921,7 +919,7 @@ proc http::Write {token} { set outStr [read $state(-querychannel) $state(-queryblocksize)] puts -nonewline $sock $outStr incr state(queryoffset) [string length $outStr] - if {[eof $state(-querychannel)]} { + if {[chan eof $state(-querychannel)]} { set done 1 } } @@ -933,9 +931,9 @@ proc http::Write {token} { set done 1 } if {$done} { - catch {flush $sock} - fileevent $sock writable {} - fileevent $sock readable [list http::Event $sock $token] + catch {chan flush $sock} + chan event $sock writable {} + chan event $sock readable [list http::Event $sock $token] } # Callback to the client after we've completely handled everything. @@ -958,12 +956,12 @@ proc http::Write {token} { # Read the socket and handle callbacks. proc http::Event {sock token} { - variable $token + variable [set token] upvar 0 $token state if {![info exists state]} { Log "Event $sock with invalid token '$token' - remote close?" - if {![eof $sock]} { + if {![chan eof $sock]} { if {[set d [read $sock]] ne ""} { Log "WARNING: additional data left on closed socket" } @@ -972,18 +970,18 @@ proc http::Event {sock token} { return } if {$state(state) eq "connecting"} { - if {[catch {gets $sock state(http)} n]} { + if {[catch {chan gets $sock state(http)} n]} { return [Finish $token $n] } elseif {$n >= 0} { set state(state) "header" } } elseif {$state(state) eq "header"} { - if {[catch {gets $sock line} n]} { + if {[catch {chan gets $sock line} n]} { return [Finish $token $n] } elseif {$n == 0} { # We have now read all headers # We ignore HTTP/1.1 100 Continue returns. RFC2616 sec 8.2.3 - if {$state(http) == "" || ([regexp {^\S+\s(\d+)} $state(http) {} x] && $x == 100)} { + if {($state(http) == "") || ([regexp {^\S+\s(\d+)} $state(http) {} x] && $x == 100)} { return } @@ -1011,21 +1009,21 @@ proc http::Event {sock token} { } # We have to use binary translation to count bytes properly. - fconfigure $sock -translation binary + chan configure $sock -translation binary if { - $state(-binary) || ![string match -nocase text* $state(type)] + $state(-binary) || (![string match -nocase text* $state(type)]) } { # Turn off conversions for non-text data set state(binary) 1 } if {[info exists state(-channel)]} { if {$state(binary) || [llength [ContentEncoding $token]]} { - fconfigure $state(-channel) -translation binary + chan configure $state(-channel) -translation binary } if {![info exists state(-handler)]} { # Initiate a sequence of background fcopies - fileevent $sock readable {} + chan event $sock readable {} CopyStart $sock $token return } @@ -1039,11 +1037,11 @@ proc http::Event {sock token} { # grab the optional charset information if {[regexp -nocase \ {charset\s*=\s*\"((?:[^""]|\\\")*)\"} \ - $state(type) -> cs]} { + $state(type) ___ cs]} { set state(charset) [string map {{\"} \"} $cs] } else { regexp -nocase {charset\s*=\s*(\S+?);?} \ - $state(type) -> state(charset) + $state(type) ___ state(charset) } } content-length { @@ -1061,6 +1059,8 @@ proc http::Event {sock token} { set state(connection) \ [string trim [string tolower $value]] } + default { + } } lappend state(meta) $key [string trim $value] } @@ -1082,7 +1082,7 @@ proc http::Event {sock token} { } } elseif { [info exists state(transfer)] - && $state(transfer) eq "chunked" + && ($state(transfer) eq "chunked") } { set size 0 set chunk [getTextLine $sock] @@ -1090,10 +1090,10 @@ proc http::Event {sock token} { if {[string trim $chunk] ne ""} { scan $chunk %x size if {$size != 0} { - set bl [fconfigure $sock -blocking] - fconfigure $sock -blocking 1 + set bl [chan configure $sock -blocking] + chan configure $sock -blocking 1 set chunk [read $sock $size] - fconfigure $sock -blocking $bl + chan configure $sock -blocking $bl set n [string length $chunk] if {$n >= 0} { append state(body) $chunk @@ -1104,7 +1104,7 @@ proc http::Event {sock token} { } getTextLine $sock } else { - set state(transfer_final) {} + set state(transfer_final) "" } } } else { @@ -1138,8 +1138,8 @@ proc http::Event {sock token} { } # catch as an Eof above may have closed the socket already - if {![catch {eof $sock} eof] && $eof} { - if {[info exists $token]} { + if {(![catch {chan eof $sock} eof]) && $eof} { + if {[info exists [set token]]} { set state(connection) close Eof $token } else { @@ -1161,11 +1161,11 @@ proc http::Event {sock token} { # The line of text, without trailing newline proc http::getTextLine {sock} { - set tr [fconfigure $sock -translation] - set bl [fconfigure $sock -blocking] - fconfigure $sock -translation crlf -blocking 1 - set r [gets $sock] - fconfigure $sock -translation $tr -blocking $bl + set tr [chan configure $sock -translation] + set bl [chan configure $sock -blocking] + chan configure $sock -translation crlf -blocking 1 + set r [chan gets $sock] + chan configure $sock -translation $tr -blocking $bl return $r } @@ -1182,7 +1182,7 @@ proc http::getTextLine {sock} { proc http::CopyStart {sock token {initial 1}} { upvar #0 $token state - if {[info exists state(transfer)] && $state(transfer) eq "chunked"} { + if {[info exists state(transfer)] && ($state(transfer) eq "chunked")} { foreach coding [ContentEncoding $token] { lappend state(zlib) [zlib stream $coding] } @@ -1194,7 +1194,7 @@ proc http::CopyStart {sock token {initial 1}} { } } if {[catch { - fcopy $sock $state(-channel) -size $state(-blocksize) -command \ + chan copy $sock $state(-channel) -size $state(-blocksize) -command \ [list http::CopyDone $token] } err]} { Finish $token $err @@ -1223,7 +1223,7 @@ proc http::CopyChunk {token chunk} { foreach stream $state(zlib) { catch {set excess [$stream add -finalize $excess]} } - puts -nonewline $state(-channel) $excess + chan puts -nonewline $state(-channel) $excess foreach stream $state(zlib) { $stream close } unset state(zlib) } @@ -1243,7 +1243,7 @@ proc http::CopyChunk {token chunk} { # Invokes callbacks proc http::CopyDone {token count {error {}}} { - variable $token + variable [set token] upvar 0 $token state set sock $state(sock) incr state(currentsize) $count @@ -1254,7 +1254,7 @@ proc http::CopyDone {token count {error {}}} { # At this point the token may have been reset if {[string length $error]} { Finish $token $error - } elseif {[catch {eof $sock} iseof] || $iseof} { + } elseif {[catch {chan eof $sock} iseof] || $iseof} { Eof $token } else { CopyStart $sock $token 0 @@ -1272,7 +1272,7 @@ proc http::CopyDone {token count {error {}}} { # Clean up the socket proc http::Eof {token {force 0}} { - variable $token + variable [set token] upvar 0 $token state if {$state(state) eq "header"} { # Premature eof @@ -1320,12 +1320,12 @@ proc http::Eof {token {force 0}} { # The status after the wait. proc http::wait {token} { - variable $token + variable [set token] upvar 0 $token state - if {![info exists state(status)] || $state(status) eq ""} { + if {(![info exists state(status)]) || ($state(status) eq "")} { # We must wait on the original variable name, not the upvar alias - vwait ${token}(status) + vwait [set token](status) } return [status $token] @@ -1402,8 +1402,8 @@ proc http::ProxyRequired {host} { variable http if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} { if { - ![info exists http(-proxyport)] || - ![string length $http(-proxyport)] + (![info exists http(-proxyport)]) || + (![string length $http(-proxyport)]) } { set http(-proxyport) 8080 } @@ -1421,22 +1421,24 @@ proc http::CharsetToEncoding {charset} { variable encodings set charset [string tolower $charset] - if {[regexp {iso-?8859-([0-9]+)} $charset -> num]} { + if {[regexp {iso-?8859-([0-9]+)} $charset ___ num]} { set encoding "iso8859-$num" - } elseif {[regexp {iso-?2022-(jp|kr)} $charset -> ext]} { + } elseif {[regexp {iso-?2022-(jp|kr)} $charset ___ ext]} { set encoding "iso2022-$ext" } elseif {[regexp {shift[-_]?js} $charset]} { set encoding "shiftjis" - } elseif {[regexp {(?:windows|cp)-?([0-9]+)} $charset -> num]} { + } elseif {[regexp {(?:windows|cp)-?([0-9]+)} $charset ___ num]} { set encoding "cp$num" } elseif {$charset eq "us-ascii"} { set encoding "ascii" - } elseif {[regexp {(?:iso-?)?lat(?:in)?-?([0-9]+)} $charset -> num]} { + } elseif {[regexp {(?:iso-?)?lat(?:in)?-?([0-9]+)} $charset ___ num]} { switch -- $num { 5 {set encoding "iso8859-9"} 1 - 2 - 3 { set encoding "iso8859-$num" } + default { + } } } else { # other charset, like euc-xx, utf-8,... may directly map to encoding @@ -1453,9 +1455,9 @@ proc http::CharsetToEncoding {charset} { # Return the list of content-encoding transformations we need to do in order. proc http::ContentEncoding {token} { upvar 0 $token state - set r {} + set r [list] if {[info exists state(coding)]} { - foreach coding [split $state(coding) ,] { + foreach coding [split $state(coding) ","] { switch -exact -- $coding { deflate { lappend r inflate } gzip - x-gzip { lappend r gunzip } @@ -1477,11 +1479,11 @@ proc http::make-transformation-chunked {chan command} { yield while {1} { chan configure $chan -translation {crlf binary} - while {[gets $chan line] < 1} { yield } + while {[chan gets $chan line] < 1} { yield } chan configure $chan -translation {binary binary} if {[scan $line %x size] != 1} { return -code error "invalid size: \"$line\"" } set chunk "" - while {$size && ![chan eof $chan]} { + while {$size && (![chan eof $chan])} { set part [chan read $chan $size] incr size -[string length $part] append chunk $part diff --git a/library/opt/optparse.tcl b/library/opt/optparse.tcl index fc77fa1..d8d39e4 100644 --- a/library/opt/optparse.tcl +++ b/library/opt/optparse.tcl @@ -145,7 +145,7 @@ namespace eval ::tcl { proc ::tcl::OptKeyRegister {desc {key ""}} { variable OptDesc variable OptDescN - if {[string equal $key ""]} { + if {$key eq ""} { # in case a key given to us as a parameter was a number while {[info exists OptDesc($OptDescN)]} {incr OptDescN} set key $OptDescN @@ -157,20 +157,20 @@ proc ::tcl::OptKeyRegister {desc {key ""}} { # are we processing flags (which makes a single program step) set inflags 0 - set state {} + set state "" # flag used to detect that we just have a single (flags set) subprogram. set empty 1 foreach item $desc { - if {$state == "args"} { + if {$state eq "args"} { # more items after 'args'... return -code error "'args' special argument must be the last one" } set res [OptNormalizeOne $item] set state [lindex $res 0] if {$inflags} { - if {$state == "flags"} { + if {$state eq "flags"} { # add to 'subprogram' lappend flagsprg $res } else { @@ -184,7 +184,7 @@ proc ::tcl::OptKeyRegister {desc {key ""}} { set empty 0 } } else { - if {$state == "flags"} { + if {$state eq "flags"} { set inflags 1 # sub program counter + first sub program set flagsprg [list [list "P" 1] $res] @@ -247,7 +247,7 @@ proc ::tcl::OptParse {desc arglist} { # into local variable named "Args". proc ::tcl::OptProc {name desc body} { set namespace [uplevel 1 [list ::namespace current]] - if {[string match "::*" $name] || [string equal $namespace "::"]} { + if {[string match "::*" $name] || ($namespace eq "::")} { # absolute name or global namespace, name is the key set key $name } else { @@ -261,8 +261,8 @@ proc ::tcl::OptProc {name desc body} { # Check that a argument has been given # assumes that "OptProc" has been used as it will check in "Args" list proc ::tcl::OptProcArgGiven {argname} { - upvar Args alist - expr {[lsearch $alist $argname] >=0} + upvar 1 Args alist + expr {$argname in $alist} } ####### @@ -274,11 +274,11 @@ proc ::tcl::OptProcArgGiven {argname} { } # Is a (sub) program or a plain instruction ? proc OptIsPrg {lst} { - expr {[llength [OptInstr $lst]]>=2} + expr {[llength [OptInstr $lst]] >= 2} } # Is this instruction a program counter or a real instr proc OptIsCounter {item} { - expr {[lindex $item 0]=="P"} + expr {[lindex $item 0] eq "P"} } # Current program counter (2nd word of first word) proc OptGetPrgCounter {lst} { @@ -286,12 +286,12 @@ proc ::tcl::OptProcArgGiven {argname} { } # Current program counter (2nd word of first word) proc OptSetPrgCounter {lstName newValue} { - upvar $lstName lst + upvar 1 $lstName lst set lst [lreplace $lst 0 0 [concat "P" $newValue]] } # returns a list of currently selected items. proc OptSelection {lst} { - set res {} + set res [list] foreach idx [lrange [lindex $lst 0] 1 end] { lappend res [Lget $lst $idx] } @@ -318,7 +318,7 @@ proc ::tcl::OptProcArgGiven {argname} { return $item } # Current final instruction adress - proc OptCurAddr {descriptions {start {}}} { + proc OptCurAddr {descriptions {start ""}} { set adress [OptGetPrgCounter $descriptions] lappend start $adress set item [lindex $descriptions $adress] @@ -330,7 +330,7 @@ proc ::tcl::OptProcArgGiven {argname} { } # Set the value field of the current instruction proc OptCurSetValue {descriptionsName value} { - upvar $descriptionsName descriptions + upvar 1 $descriptionsName descriptions # get the current item full adress set adress [OptCurAddr $descriptions] # use the 3th field of the item (see OptValue / OptNewInst) @@ -369,15 +369,15 @@ proc ::tcl::OptProcArgGiven {argname} { # Loop over all descriptions, calling OptDoOne which will # eventually eat all the arguments. proc OptDoAll {descriptionsName argumentsName} { - upvar $descriptionsName descriptions - upvar $argumentsName arguments + upvar 1 $descriptionsName descriptions + upvar 1 $argumentsName arguments # puts "entered DoAll" # Nb: the places where "state" can be set are tricky to figure # because DoOne sets the state to flagsValue and return -continue # when needed... set state [OptCurState $descriptions] # We'll exit the loop in "OptDoOne" or when state is empty. - while 1 { + while {1} { set curitem [OptCurDesc $descriptions] # Do subprograms if needed, call ourselves on the sub branch while {[OptIsPrg $curitem]} { @@ -410,29 +410,29 @@ proc ::tcl::OptProcArgGiven {argname} { # Process one step for the state machine, # eventually consuming the current argument. proc OptDoOne {descriptionsName stateName argumentsName} { - upvar $argumentsName arguments - upvar $descriptionsName descriptions - upvar $stateName state + upvar 1 $argumentsName arguments + upvar 1 $descriptionsName descriptions + upvar 1 $stateName state # the special state/instruction "args" eats all # the remaining args (if any) - if {($state == "args")} { + if {($state eq "args")} { if {![Lempty $arguments]} { # If there is no additional arguments, leave the default value # in. OptCurSetValue descriptions $arguments - set arguments {} + set arguments [list] } # puts "breaking out ('args' state: consuming every reminding args)" return -code break } if {[Lempty $arguments]} { - if {$state == "flags"} { + if {$state eq "flags"} { # no argument and no flags : we're done # puts "returning to previous (sub)prg (no more args)" return -code return - } elseif {$state == "optValue"} { + } elseif {$state eq "optValue"} { set state next; # not used, for debug only # go to next state return @@ -443,7 +443,7 @@ proc ::tcl::OptProcArgGiven {argname} { set arg [OptCurrentArg $arguments] } - switch $state { + switch -- $state { flags { # A non-dash argument terminates the options, as does -- @@ -454,7 +454,7 @@ proc ::tcl::OptProcArgGiven {argname} { } # consume the flag OptNextArg arguments - if {[string equal "--" $arg]} { + if {"--" eq $arg} { # return from 'flags' state return -code return } @@ -488,7 +488,7 @@ proc ::tcl::OptProcArgGiven {argname} { # set the value OptCurSetValue descriptions $val # go to next state - if {$state == "flagValue"} { + if {$state eq "flagValue"} { set state flags return -code continue } else { @@ -511,6 +511,7 @@ proc ::tcl::OptProcArgGiven {argname} { set state next; # not used, for debug only return ; # will go on next step } + default {} } # If we reach this point: an unknown # state as been entered ! @@ -538,11 +539,11 @@ proc ::tcl::OptKeyParse {descKey arglist} { # Analyse the result # Walk through the tree: - OptTreeVars $desc "#[expr {[info level]-1}]" + OptTreeVars $desc "#[expr {[info level] - 1}]" } # determine string length for nice tabulated output - proc OptTreeVars {desc level {vnamesLst {}}} { + proc OptTreeVars {desc level {vnamesLst ""}} { foreach item $desc { if {[OptIsCounter $item]} continue if {[OptIsPrg $item]} { @@ -583,12 +584,12 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { return $arg } float { - return [expr {double($arg)}] + return [expr { double ($arg) }] } script - list { # if llength fail : malformed list - if {[llength $arg]==0 && [OptIsFlag $arg]} { + if {(![llength $arg]) && [OptIsFlag $arg]} { error "no values with leading -" } return $arg @@ -597,7 +598,7 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { if {![string is boolean -strict $arg]} { error "non canonic boolean" } - # convert true/false because expr/if is broken with "!,... + # convert true/false because expr/if is broken with "!,..." return [expr {$arg ? 1 : 0}] } choice { @@ -625,14 +626,14 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { # returns the number of flags matching the given arg # sets the (local) prg counter to the list of matches proc OptHits {descName arg} { - upvar $descName desc + upvar 1 $descName desc set hits 0 - set hitems {} + set hitems [list] set i 1 set larg [string tolower $arg] set len [string length $larg] - set last [expr {$len-1}] + set last [expr {$len - 1}] foreach item [lrange $desc 1 end] { set flag [OptName $item] @@ -640,12 +641,12 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { # (string length ought to be cheap) set lflag [string tolower $flag] if {$len == [string length $lflag]} { - if {[string equal $larg $lflag]} { + if {$larg eq $lflag} { # Exact match case OptSetPrgCounter desc $i return 1 } - } elseif {[string equal $larg [string range $lflag 0 $last]]} { + } elseif {$larg eq [string range $lflag 0 $last]} { lappend hitems $i incr hits } @@ -695,7 +696,7 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { lindex $item 5 } proc OptNeedValue {item} { - expr {![string equal [OptType $item] boolflag]} + expr {[OptType $item] ne "boolflag"} } proc OptDefaultValue {item} { set val [OptTypeArgs $item] @@ -705,12 +706,9 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { boolflag { # convert back false/true to 0/1 because expr !$bool # is broken.. - if {$val} { - return 1 - } else { - return 0 - } + return [expr {$val ? 1 : 0}] } + default {} } return $val } @@ -741,7 +739,7 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { set state "flags" } elseif {$isopt} { set state "optValue" - } elseif {![string equal $varname "args"]} { + } elseif {$varname ne "args"} { set state "value" } else { set state "args" @@ -751,7 +749,7 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { # description writer's life easy, and our's difficult : # let's guess the missing arguments :-) - switch $lg { + switch -- $lg { 1 { if {$isflag} { return [OptNewInst $state $varname boolflag false ""] @@ -763,7 +761,7 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { # varname default # varname help set type [OptGuessType $arg1] - if {[string equal $type "string"]} { + if {$type eq "string"} { if {$isflag} { set type boolflag set def false @@ -786,7 +784,7 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { # flags/optValue as they are optional, need a "value", # on the contrary, for a variable (non optional), # default value is pointless, 'cept for choices : - if {$isflag || $isopt || ($type == "choice")} { + if {$isflag || $isopt || ($type eq "choice")} { return [OptNewInst $state $varname $type $arg2 ""] } else { return [OptNewInst $state $varname $type "" $arg2] @@ -811,7 +809,7 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { # Auto magic lazy type determination proc OptGuessType {arg} { - if { $arg == "true" || $arg == "false" } { + if { $arg in "true false" } { return boolean } if {[string is integer -strict $arg]} { @@ -843,7 +841,7 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { return "parameter" } } - proc OptBadValue {item arg {err {}}} { + proc OptBadValue {item arg {err ""}} { # puts "bad val err = \"$err\"" OptError "bad value \"$arg\" for [OptParamType $item]"\ [list $item] @@ -862,9 +860,9 @@ proc ::tcl::OptKeyError {prefix descKey {header 0}} { # determine string length for nice tabulated output proc OptLengths {desc nlName tlName dlName} { - upvar $nlName nl - upvar $tlName tl - upvar $dlName dl + upvar 1 $nlName nl + upvar 1 $tlName tl + upvar 1 $dlName dl foreach item $desc { if {[OptIsCounter $item]} continue if {[OptIsPrg $item]} { @@ -873,12 +871,12 @@ proc ::tcl::OptKeyError {prefix descKey {header 0}} { SetMax nl [string length [OptName $item]] SetMax tl [string length [OptType $item]] set dv [OptTypeArgs $item] - if {[OptState $item] != "header"} { + if {[OptState $item] ne "header"} { set dv "($dv)" } set l [string length $dv] # limit the space allocated to potentially big "choices" - if {([OptType $item] != "choice") || ($l<=12)} { + if {([OptType $item] ne "choice") || ($l <= 12)} { SetMax dl $l } else { if {![info exists dl]} { @@ -897,7 +895,7 @@ proc ::tcl::OptKeyError {prefix descKey {header 0}} { append res [OptTree $item $nl $tl $dl] } else { set dv [OptTypeArgs $item] - if {[OptState $item] != "header"} { + if {[OptState $item] ne "header"} { set dv "($dv)" } append res [string trimright [format "\n %-*s %-*s %-*s %s" \ @@ -915,7 +913,7 @@ proc ::tcl::OptError {prefix desc {header 0}} { # add faked instruction set h [list [OptNewInst header Var/FlagName Type Value Help]] lappend h [OptNewInst header ------------ ---- ----- ----] - lappend h [OptNewInst header {(-help} "" "" {gives this help)}] + lappend h [OptNewInst header "\(-help" "" "" "gives this help\)"] set desc [concat $h $desc] } OptLengths $desc nl tl dl @@ -937,7 +935,7 @@ proc ::tcl::OptError {prefix desc {header 0}} { # Is that list empty ? proc ::tcl::Lempty {list} { - expr {[llength $list]==0} + expr {[llength $list] == 0} } # Gets the value of one leaf of a lists tree @@ -952,11 +950,11 @@ proc ::tcl::Lget {list indexLst} { # it would be even slower... needs to be written in C !) # (nb: there is a non trivial recursive problem with indexes 0, # which appear because there is no difference between a list -# of 1 element and 1 element alone : [list "a"] == "a" while +# of 1 element and 1 element alone : [list "a"] eq "a" while # it should be {a} and [listp a] should be 0 while [listp {a b}] would be 1 # and [listp "a b"] maybe 0. listp does not exist either...) proc ::tcl::Lvarset {listName indexLst newValue} { - upvar $listName list + upvar 1 $listName list if {[llength $indexLst] <= 1} { Lvarset1nc list $indexLst $newValue } else { @@ -975,12 +973,12 @@ proc ::tcl::Lvarset {listName indexLst newValue} { # (on level-1 of lists) variable emptyList {} proc ::tcl::Lvarset1 {listName index newValue} { - upvar $listName list + upvar 1 $listName list if {$index < 0} {return -code error "invalid negative index"} set lg [llength $list] if {$index >= $lg} { variable emptyList - for {set i $lg} {$i<$index} {incr i} { + for {set i $lg} {$i < $index} {incr i} { lappend list $emptyList } lappend list $newValue @@ -990,13 +988,13 @@ proc ::tcl::Lvarset1 {listName index newValue} { } # same as Lvarset1 but no bound checking / creation proc ::tcl::Lvarset1nc {listName index newValue} { - upvar $listName list + upvar 1 $listName list set list [lreplace $list $index $index $newValue] } # Increments the value of one leaf of a lists tree # (which must exists) proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} { - upvar $listName list + upvar 1 $listName list if {[llength $indexLst] <= 1} { Lvarincr1 list $indexLst $howMuch } else { @@ -1012,21 +1010,21 @@ proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} { } # Increments the value of one cell of a list proc ::tcl::Lvarincr1 {listName index {howMuch 1}} { - upvar $listName list - set newValue [expr {[lindex $list $index]+$howMuch}] + upvar 1 $listName list + set newValue [expr {[lindex $list $index] + $howMuch}] set list [lreplace $list $index $index $newValue] return $newValue } # Removes the first element of a list # and returns the new list value proc ::tcl::Lvarpop1 {listName} { - upvar $listName list + upvar 1 $listName list set list [lrange $list 1 end] } # Same but returns the removed element # (Like the tclX version) proc ::tcl::Lvarpop {listName} { - upvar $listName list + upvar 1 $listName list set el [lindex $list 0] set list [lrange $list 1 end] return $el @@ -1037,7 +1035,7 @@ proc ::tcl::Lassign {list args} { set i 0 set lg [llength $list] foreach vname $args { - if {$i>=$lg} break + if {$i >= $lg} break uplevel 1 [list ::set $vname [lindex $list $i]] incr i } @@ -1050,7 +1048,7 @@ proc ::tcl::Lassign {list args} { # or if varname is undefined proc ::tcl::SetMax {varname value} { upvar 1 $varname var - if {![info exists var] || $value > $var} { + if {(![info exists var]) || ($value > $var)} { set var $value } } @@ -1059,7 +1057,7 @@ proc ::tcl::SetMax {varname value} { # or if varname is undefined proc ::tcl::SetMin {varname value} { upvar 1 $varname var - if {![info exists var] || $value < $var} { + if {(![info exists var]) || ($value < $var)} { set var $value } } diff --git a/library/platform/platform.tcl b/library/platform/platform.tcl index a1a728b..d9b1aee 100644 --- a/library/platform/platform.tcl +++ b/library/platform/platform.tcl @@ -91,6 +91,7 @@ proc ::platform::generic {} { append cpu _32 } } + default {} } switch -- $plat { @@ -142,6 +143,7 @@ proc ::platform::generic {} { osf1 { set plat tru64 } + default {} } return "${plat}-${cpu}" @@ -158,11 +160,11 @@ proc ::platform::identify {} { global tcl_platform set id [generic] - regexp {^([^-]+)-([^-]+)$} $id -> plat cpu + regexp {^([^-]+)-([^-]+)$} $id ___ plat cpu switch -- $plat { solaris { - regsub {^5} $tcl_platform(osVersion) 2 text + regsub "^5" $tcl_platform(osVersion) 2 text append plat $text return "${plat}-${cpu}" } @@ -236,6 +238,7 @@ proc ::platform::identify {} { append plat -$v return "${plat}-${cpu}" } + default {} } return $id @@ -254,10 +257,10 @@ proc ::platform::LibcVersion {base _->_ vv} { # information. if {![catch { - set vdata [lindex [split [exec $libc] \n] 0] + set vdata [lindex [split [exec -- $libc] \n] 0] }]} { regexp {version ([0-9]+(\.[0-9]+)*), by} $vdata -> v - foreach {major minor} [split $v .] break + lassign [split $v "."] major minor set v glibc${major}.${minor} return 1 } else { @@ -265,7 +268,7 @@ proc ::platform::LibcVersion {base _->_ vv} { # inspecting its name to determine the version # number. This code by Larry McVoy. - if {[regexp -- {libc-([0-9]+)\.([0-9]+)} $libc -> major minor]} { + if {[regexp -- {libc-([0-9]+)\.([0-9]+)} $libc ___ major minor]} { set v glibc${major}.${minor} return 1 } @@ -295,9 +298,9 @@ proc ::platform::patterns {id} { switch -glob -- $id { solaris*-* { - if {[regexp {solaris([^-]*)-(.*)} $id -> v cpu]} { + if {[regexp {solaris([^-]*)-(.*)} $id ___ v cpu]} { if {$v eq ""} {return $id} - foreach {major minor} [split $v .] break + lassign [split $v "."] major minor incr minor -1 for {set j $minor} {$j >= 6} {incr j -1} { lappend res solaris${major}.${j}-${cpu} @@ -305,8 +308,8 @@ proc ::platform::patterns {id} { } } linux*-* { - if {[regexp {linux-glibc([^-]*)-(.*)} $id -> v cpu]} { - foreach {major minor} [split $v .] break + if {[regexp {linux-glibc([^-]*)-(.*)} $id ___ v cpu]} { + lassign [split $v "."] major minor incr minor -1 for {set j $minor} {$j >= 0} {incr j -1} { lappend res linux-glibc${major}.${j}-${cpu} @@ -315,19 +318,19 @@ proc ::platform::patterns {id} { } macosx*-* { # 10.5+ - if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} { + if {[regexp {macosx([^-]*)-(.*)} $id ___ v cpu]} { switch -exact -- $cpu { ix86 - x86_64 { set alt i386-x86_64 } - default { set alt {} } + default { set alt "" } } if {$v ne ""} { - foreach {major minor} [split $v .] break + lassign [split $v "."] major minor # Add 10.5 to 10.minor to patterns. - set res {} + set res [list] for {set j $minor} {$j >= 5} {incr j -1} { lappend res macosx${major}.${j}-${cpu} lappend res macosx${major}.${j}-universal @@ -359,6 +362,7 @@ proc ::platform::patterns {id} { macosx-ix86 { lappend res macosx-universal macosx-i386-x86_64 } + default {} } lappend res tcl ; # Pure tcl packages are always compatible. return $res diff --git a/library/platform/shell.tcl b/library/platform/shell.tcl index d37cdcd..63aa8e5 100644 --- a/library/platform/shell.tcl +++ b/library/platform/shell.tcl @@ -26,7 +26,7 @@ proc ::platform::shell::generic {shell} { CHECK $shell LOCATE base out - set code {} + set code [list] # Forget any pre-existing platform package, it might be in # conflict with this one. lappend code {package forget platform} @@ -39,7 +39,7 @@ proc ::platform::shell::generic {shell} { set arch [RUN $shell [join $code \n]] - if {$out} {file delete -force $base} + if {$out} {file delete -force -- $base} return $arch } @@ -51,7 +51,7 @@ proc ::platform::shell::identify {shell} { CHECK $shell LOCATE base out - set code {} + set code [list] # Forget any pre-existing platform package, it might be in # conflict with this one. lappend code {package forget platform} @@ -64,7 +64,7 @@ proc ::platform::shell::identify {shell} { set arch [RUN $shell [join $code \n]] - if {$out} {file delete -force $base} + if {$out} {file delete -force -- $base} return $arch } @@ -75,7 +75,7 @@ proc ::platform::shell::platform {shell} { CHECK $shell - set code {} + set code [list] lappend code {puts $tcl_platform(platform)} lappend code {exit 0} @@ -115,34 +115,34 @@ proc ::platform::shell::LOCATE {bv ov} { set out 0 if {[lindex [file system $base]] ne "native"} { set temp [TEMP] - file copy -force $base $temp + file copy -force -- $base $temp set base $temp set out 1 } return } -proc ::platform::shell::RUN {shell code} { +proc ::platform::shell::RUN {shell a_code} { set c [TEMP] set cc [open $c w] - puts $cc $code + puts $cc $a_code close $cc set e [TEMP] set code [catch { - exec $shell $c 2> $e + exec -- $shell $c 2> $e } res] - file delete $c + file delete -- $c if {$code} { append res \n[read [set chan [open $e r]]][close $chan] - file delete $e + file delete -- $e return -code error "Shell \"$shell\" is not executable ($res)" } - file delete $e + file delete -- $e return $res } @@ -166,7 +166,7 @@ proc ::platform::shell::TEMP {} { set newname $prefix for {set j 0} {$j < $nrand_chars} {incr j} { append newname [string index $chars \ - [expr {int(rand()*62)}]] + [expr { int ( ( rand ()) * 62)}]] } set newname [file join $tmpdir $newname] if {[file exists $newname]} { @@ -182,12 +182,12 @@ proc ::platform::shell::TEMP {} { } } else { # Success - close $channel + chan close $channel return [file normalize $newname] } } } - if {$channel != ""} { + if {$channel ne ""} { return -code error "Failed to open a temporary file: $channel" } else { return -code error "Failed to find an unused temporary file name" @@ -208,7 +208,7 @@ proc ::platform::shell::DIR {} { } } - switch $tcl_platform(platform) { + switch -- $tcl_platform(platform) { windows { lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP" } diff --git a/library/safe.tcl b/library/safe.tcl index 394aa97..c241309 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -33,11 +33,11 @@ namespace eval ::safe { # by -noStatics or -statics 0) proc ::safe::InterpStatics {} { foreach v {Args statics noStatics} { - upvar $v $v + upvar 1 $v [set v] } set flag [::tcl::OptProcArgGiven -noStatics] - if {$flag && (!$noStatics == !$statics) - && ([::tcl::OptProcArgGiven -statics])} { + if {$flag && ((!$noStatics) == (!$statics)) && + ([::tcl::OptProcArgGiven -statics])} { return -code error\ "conflicting values given for -statics and -noStatics" } @@ -52,12 +52,12 @@ proc ::safe::InterpStatics {} { # (either by -nestedLoadOk or -nested 1) proc ::safe::InterpNested {} { foreach v {Args nested nestedLoadOk} { - upvar $v $v + upvar 1 $v [set v] } set flag [::tcl::OptProcArgGiven -nestedLoadOk] # note that the test here is the opposite of the "InterpStatics" one # (it is not -noNested... because of the wanted default value) - if {$flag && (!$nestedLoadOk != !$nested) + if {$flag && ((!$nestedLoadOk) != (!$nested)) && ([::tcl::OptProcArgGiven -nested])} { return -code error\ "conflicting values given for -nested and -nestedLoadOk" @@ -95,7 +95,7 @@ proc ::safe::interpInit {args} { # Check that the given slave is "one of us" proc ::safe::CheckInterp {slave} { namespace upvar ::safe S$slave state - if {![info exists state] || ![::interp exists $slave]} { + if {(![info exists state]) || (![::interp exists $slave])} { return -code error \ "\"$slave\" is not an interpreter managed by ::safe::" } @@ -115,7 +115,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} { - switch [llength $args] { + switch -- [llength $args] { 1 { # If we have exactly 1 argument the semantic is to return all # the current configuration. We still call OptKeyParse though @@ -198,17 +198,17 @@ proc ::safe::interpConfigure {args} { set doreset 0 } if { - ![::tcl::OptProcArgGiven -statics] - && ![::tcl::OptProcArgGiven -noStatics] - } then { + (![::tcl::OptProcArgGiven -statics]) + && (![::tcl::OptProcArgGiven -noStatics]) + } { set statics $state(staticsok) } else { set statics [InterpStatics] } if { - [::tcl::OptProcArgGiven -nested] || + [::tcl::OptProcArgGiven -nested] || [::tcl::OptProcArgGiven -nestedLoadOk] - } then { + } { set nested [InterpNested] } else { set nested $state(nestedok) @@ -265,7 +265,7 @@ proc ::safe::InterpCreate { } { # Create the slave. if {$slave ne ""} { - ::interp create -safe $slave + ::interp create -safe -- $slave } else { # empty argument: generate slave name set slave [::interp create -safe] @@ -680,9 +680,11 @@ proc ::safe::CheckFileName {slave file} { # interpreters that are *almost* safe. In particular, it just acts to # prevent discovery of what home directories exist. -proc ::safe::AliasFileSubcommand {slave subcommand name} { - if {[string match ~* $name]} { - set name ./$name +proc ::safe::AliasFileSubcommand {slave subcommand a_name} { + if {[string match "~*" $a_name]} { + set name ./$a_name + } else { + set name $a_name } tailcall ::interp invokehidden $slave tcl:file:$subcommand $name } @@ -690,6 +692,7 @@ proc ::safe::AliasFileSubcommand {slave subcommand name} { # AliasGlob is the target of the "glob" alias in safe interpreters. proc ::safe::AliasGlob {slave args} { + global tcl_platform Log $slave "GLOB ! $args" NOTICE set cmd {} set at 0 @@ -701,7 +704,7 @@ proc ::safe::AliasGlob {slave args} { -- 0 } - if {$::tcl_platform(platform) eq "windows"} { + if {$tcl_platform(platform) eq "windows"} { set dirPartRE {^(.*)[\\/]([^\\/]*)$} } else { set dirPartRE {^(.*)/([^/]*)$} @@ -771,13 +774,13 @@ proc ::safe::AliasGlob {slave args} { # Process remaining pattern arguments set firstPattern [llength $cmd] foreach opt [lrange $args $at end] { - if {![regexp $dirPartRE $opt -> thedir thefile]} { + if {![regexp -- $dirPartRE $opt ___ thedir thefile]} { set thedir . - } elseif {[string match ~* $thedir]} { + } elseif {[string match "~*" $thedir]} { set thedir ./$thedir } - if {$thedir eq "*" && - ($thefile eq "pkgIndex.tcl" || $thefile eq "*.tm")} { + if {($thedir eq "*") && + ($thefile in "pkgIndex.tcl *.tm")} { set mapped 0 foreach d [glob -directory [TranslatePath $slave $virtualdir] \ -types d -tails *] { @@ -803,9 +806,10 @@ proc ::safe::AliasGlob {slave args} { Log $slave "GLOB = $cmd" NOTICE - if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} { + if {$got(-nocomplain) && ([llength $cmd] eq $firstPattern)} { return } + set entries [list] try { set entries [::interp invokehidden $slave glob {*}$cmd] } on error msg { @@ -816,11 +820,11 @@ proc ::safe::AliasGlob {slave args} { Log $slave "GLOB < $entries" NOTICE # Translate path back to what the slave should see. - set res {} + set res [list] set l [string length $dir] foreach p $entries { if {[string equal -length $l $dir $p]} { - set p [string replace $p 0 [expr {$l-1}] $virtualdir] + set p [string replace $p 0 [expr {$l - 1}] $virtualdir] } lappend res $p } @@ -845,7 +849,7 @@ proc ::safe::AliasSource {slave args} { } } else { set at 0 - set encoding {} + set encoding "" } if {$argc != 1} { set msg "wrong # args: should be \"source ?-encoding E? fileName\"" @@ -885,12 +889,12 @@ proc ::safe::AliasSource {slave args} { set replacementMsg "script error" set code [catch { set f [open $realfile] - fconfigure $f -eofchar \032 + chan configure $f -eofchar \032 if {$encoding ne ""} { - fconfigure $f -encoding $encoding + chan configure $f -encoding $encoding } - set contents [read $f] - close $f + set contents [chan read $f] + chan close $f ::interp eval $slave [list info script $file] } msg opt] if {$code == 0} { diff --git a/tests/all.tcl b/tests/all.tcl index 05d3024..5872d54 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -15,5 +15,5 @@ package require Tcl 8.5 package require tcltest 2.2 namespace import tcltest::* configure {*}$argv -testdir [file dir [info script]] -runAllTests -proc exit args {} +runAllTests +proc exit {args} {} diff --git a/tests/append.test b/tests/append.test index 69c6381..53023fa 100644 --- a/tests/append.test +++ b/tests/append.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -92,7 +92,7 @@ test append-4.7 {lappend command} { test append-4.8 {lappend command} { set x "\\\{" lappend x abc -} "\\{ abc" +} "\\\{ abc" test append-4.9 {lappend command} -returnCodes error -body { set x " \{" lappend x abc diff --git a/tests/appendComp.test b/tests/appendComp.test index f85c3ba..a9d10cb 100644 --- a/tests/appendComp.test +++ b/tests/appendComp.test @@ -11,11 +11,11 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } -catch {unset x} +unset -nocomplain x test appendComp-1.1 {append command} -setup { unset -nocomplain x @@ -132,7 +132,7 @@ test appendComp-4.8 {lappend command} { lappend x abc } foo -} "\\{ abc" +} "\\\{ abc" test appendComp-4.9 {lappend command} -returnCodes error -body { proc foo {} { set x " \{" @@ -439,7 +439,7 @@ test appendComp-9.3 {bug 3057639, append direct eval, read trace on non-existing unset -nocomplain ::env(__DUMMY__) } -result {0 {new value}} -catch {unset i x result y} +unset -nocomplain i x result y catch {rename foo ""} catch {rename bar ""} catch {rename check ""} diff --git a/tests/apply.test b/tests/apply.test index ba19b81..9329359 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.2 namespace import -force ::tcltest::* } @@ -21,7 +21,7 @@ if {[info commands ::apply] eq {}} { return } -testConstraint memory [llength [info commands memory]] +tcltest::testConstraint memory [llength [info commands memory]] # Tests for wrong number of arguments @@ -163,7 +163,7 @@ test apply-6.3 {info level} { # Tests for correct namespace scope namespace eval ::testApply { - proc testApply args {return testApply} + proc testApply {args} {return testApply} } test apply-7.1 {namespace access} { diff --git a/tests/assemble.test b/tests/assemble.test index 7d4e5d1..b49992e 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -31,8 +31,8 @@ proc fillTables {} { return $s } -testConstraint memory [llength [info commands memory]] -if {[testConstraint memory]} { +tcltest::testConstraint memory [llength [info commands memory]] +if {[tcltest::testConstraint memory]} { proc getbytes {} { set lines [split [memory info] \n] return [lindex $lines 3 3] @@ -1882,7 +1882,7 @@ test assemble-17.15 {multiple passes of code resizing} { for {set i 0} {$i < 15} {incr i} { append body "label b" $i \ "; push b; concat 2; nop; nop; jump a" \ - [expr {$i+1}] \n + [expr {$i + 1}] \n } append body {label c; push -; concat 2; nop; nop; nop; jump d} \n append body {label b15; push b; concat 2; nop; nop; jump c} \n @@ -1893,8 +1893,8 @@ test assemble-17.15 {multiple passes of code resizing} { x } -cleanup { - catch {unset body} - catch {rename x {}} + unset -nocomplain body + catch {rename x ""} } -result -abababababababababababababababab- } diff --git a/tests/async.test b/tests/async.test index cb67cc2..03cacd3 100644 --- a/tests/async.test +++ b/tests/async.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } diff --git a/tests/autoMkindex.test b/tests/autoMkindex.test index 8f29131..d02a134 100644 --- a/tests/autoMkindex.test +++ b/tests/autoMkindex.test @@ -14,7 +14,7 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } -makeFile {# Test file for: +::tcltest::makeFile {# Test file for: # auto_mkindex # # This file provides example cases for testing the Tcl autoloading facility. @@ -324,7 +324,7 @@ if {[info exists saveCommands]} { } rename AutoMkindexTestReset "" -removeFile autoMkindex.tcl +::tcltest::removeFile autoMkindex.tcl if {[file exists tclIndex]} { file delete -force tclIndex } diff --git a/tests/binary.test b/tests/binary.test index ccd0f29..c342ecc 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -2678,7 +2678,7 @@ test binary-74.4 {binary encode uuencode} -body { } -result [string repeat 86)C 20] test binary-74.5 {binary encode uuencode} -body { binary encode uuencode \0\1\2\3\4\0\1\2\3 -} -result "``\$\"`P0``0(#" +} -result "``\$\"`P0``0\(#" test binary-74.6 {binary encode uuencode} -body { binary encode uuencode \0 } -result {````} @@ -2708,10 +2708,10 @@ test binary-75.3 {binary decode uuencode} -body { binary decode uuencode {} } -result {} test binary-75.4 {binary decode uuencode} -body { - binary decode uuencode [string repeat "86)C" 20] + binary decode uuencode [string repeat "86\)C" 20] } -result [string repeat abc 20] test binary-75.5 {binary decode uuencode} -body { - binary decode uuencode "``\$\"`P0``0(#" + binary decode uuencode "``\$\"`P0``0\(#" } -result "\0\1\2\3\4\0\1\2\3" test binary-75.6 {binary decode uuencode} -body { string length [binary decode uuencode {`}] @@ -2734,7 +2734,7 @@ test binary-75.11 {binary decode uuencode} -body { binary decode uuencode $s } -result [string repeat abc 20] test binary-75.12 {binary decode uuencode} -body { - binary decode uuencode -strict "|86)C" + binary decode uuencode -strict "|86\)C" } -returnCodes error -match glob -result {invalid uuencode character "|" at position 0} test binary-75.13 {binary decode uuencode} -body { set s "[string repeat 86)C 10]|[string repeat 86)C 10]" @@ -2761,11 +2761,11 @@ test binary-75.23 {binary decode uuencode} -body { list [string length $r] $r } -result {3 abc} test binary-75.24 {binary decode uuencode} -body { - set s "04)\# " + set s "04\)\# " binary decode uuencode $s } -result ABC test binary-75.25 {binary decode uuencode} -body { - set s "04)\#z" + set s "04\)\#z" binary decode uuencode $s } -returnCodes error -match glob -result {invalid uuencode character "z" at position 4} test binary-75.26 {binary decode uuencode} -body { diff --git a/tests/case.test b/tests/case.test index 6d63cea..6798bbb 100644 --- a/tests/case.test +++ b/tests/case.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } diff --git a/tests/chan.test b/tests/chan.test index d8390e2..85f0dff 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -109,7 +109,7 @@ test chan-15.1 {chan command: truncate subcommand} -body { test chan-15.2 {chan command: truncate subcommand} -setup { set file [makeFile {} testTruncate] set f [open $file w+] - fconfigure $f -translation binary + chan configure $f -translation binary } -body { seek $f 0 puts -nonewline $f 12345 @@ -190,7 +190,7 @@ test chan-16.9 {chan command: pending input subcommand} -setup { } set ::server [socket -server chan-16.9-accept -myaddr 127.0.0.1 0] - set ::client [socket 127.0.0.1 [lindex [fconfigure $::server -sockname] 2]] + set ::client [socket 127.0.0.1 [lindex [chan configure $::server -sockname] 2]] set ::chan-16.9-data [list] set ::chan-16.9-done 0 } -body { @@ -245,8 +245,8 @@ test chan-17.2 {chan command: pipe subcommand} -body { test chan-17.3 {chan command: pipe subcommand} -body { set l [chan pipe] - foreach {pr pw} $l break - list [llength $l] [fconfigure $pr -blocking] [fconfigure $pw -blocking] + lassign $l pr pw + list [llength $l] [chan configure $pr -blocking] [chan configure $pw -blocking] } -result [list 2 1 1] -cleanup { close $pw close $pr @@ -254,7 +254,7 @@ test chan-17.3 {chan command: pipe subcommand} -body { test chan-17.4 {chan command: pipe subcommand} -body { set ::done 0 - foreach {::pr ::pw} [chan pipe] break + lassign [chan pipe] ::pr ::pw after 100 {puts $::pw foo;flush $::pw} fileevent $::pr readable {set ::done 1} after 500 {set ::done -1} @@ -267,7 +267,7 @@ test chan-17.4 {chan command: pipe subcommand} -body { close $::pr } -cleanupTests +::tcltest::cleanupTests return # Local Variables: diff --git a/tests/chanio.test b/tests/chanio.test index 665df50..025bb14 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -51,11 +51,11 @@ 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 ~/_test_]) && [file writable ~]}] # set up a long data file for some of the following tests - set path(longfile) [makeFile {} longfile] + set path(longfile) [tcltest::makeFile {} longfile] set f [open $path(longfile) w] chan configure $f -eofchar {} -translation lf for { set i 0 } { $i < 100 } { incr i} { @@ -65,9 +65,9 @@ namespace eval ::tcl::test::io { } chan close $f - set path(cat) [makeFile { + set path(cat) [tcltest::makeFile { set f stdin - if {$argv != ""} { + if {$argv ne ""} { set f [open [lindex $argv 0]] } chan configure $f -encoding binary -translation lf -blocking 0 -eofchar \x1a @@ -102,7 +102,7 @@ namespace eval ::tcl::test::io { test chan-io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} { # no test, need to cause an async error. } {} -set path(test1) [makeFile {} test1] +set path(test1) [tcltest::makeFile {} test1] test chan-io-1.6 {Tcl_WriteChars: WriteBytes} { set f [open $path(test1) w] chan configure $f -encoding binary @@ -117,7 +117,7 @@ test chan-io-1.7 {Tcl_WriteChars: WriteChars} { chan close $f contents $path(test1) } "a\x93\xe1\x00" -set path(test2) [makeFile {} test2] +set path(test2) [tcltest::makeFile {} test2] test chan-io-1.8 {Tcl_WriteChars: WriteChars} { # This test written for SF bug #506297. # @@ -129,7 +129,7 @@ test chan-io-1.8 {Tcl_WriteChars: WriteChars} { chan puts -nonewline $f [format %s%c [string repeat " " 4] 12399] chan close $f contents $path(test2) -} " \x1b\$B\$O\x1b(B" +} " \x1b\$B\$O\x1b\(B" test chan-io-1.9 {Tcl_WriteChars: WriteChars} { # When closing a channel with an encoding that appends escape bytes, check # for the case where the escape bytes overflow the current IO buffer. The @@ -1363,7 +1363,7 @@ test chan-io-12.4 {ReadChars: split-up char} -setup { test chan-io-12.5 {ReadChars: chan events on partial characters} -setup { variable x {} } -constraints {stdio openpipe fileevent} -body { - set path(test1) [makeFile { + set path(test1) [tcltest::makeFile { chan configure stdout -encoding binary -buffering none chan gets stdin; chan puts -nonewline "\xe7" chan gets stdin; chan puts -nonewline "\x89" @@ -1573,7 +1573,7 @@ test chan-io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} -setup { } -cleanup { interp delete x } -result {line line none} -set path(test3) [makeFile {} test3] +set path(test3) [tcltest::makeFile {} test3] test chan-io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} -constraints {exec openpipe} -body { set f [open $path(test1) w] chan puts -nonewline $f { @@ -1667,7 +1667,7 @@ test chan-io-14.7 {Tcl_GetChannel: stdio name translation} -setup { } -cleanup { interp delete z } -result {{} {} {can not find channel named "stderr"}} -set path(script) [makeFile {} script] +set path(script) [tcltest::makeFile {} script] test chan-io-14.8 {reuse of stdio special channels} -setup { file delete $path(script) file delete $path(test1) @@ -1877,7 +1877,7 @@ test chan-io-20.3 {Tcl_CreateChannel: initial settings} -constraints {unix} -bod chan close $f } -result {{{} {}} {auto lf}} test chan-io-20.5 {Tcl_CreateChannel: install channel in empty slot} -setup { - set path(stdout) [makeFile {} stdout] + set path(stdout) [tcltest::makeFile {} stdout] } -constraints {stdio openpipe} -body { set f [open $path(script) w] chan puts -nonewline $f { @@ -2033,8 +2033,8 @@ test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan cl chan close $f lappend l [file size $path(test1)] } -result {0 60 72} -set path(pipe) [makeFile {} pipe] -set path(output) [makeFile {} output] +set path(pipe) [tcltest::makeFile {} pipe] +set path(output) [tcltest::makeFile {} output] test chan-io-27.6 {FlushChannel, async flushing, async chan close} -setup { file delete $path(pipe) file delete $path(output) @@ -2175,8 +2175,8 @@ test chan-io-28.5 {Tcl_Chan Close vs standard handles} -setup { lsort $l } -result {file1 file2} test chan-io-28.6 {Tcl_CloseEx (half-close) pipe} -setup { - set cat [makeFile { - fconfigure stdout -buffering line + set cat [tcltest::makeFile { + chan configure stdout -buffering line while {[gets stdin line] >= 0} {puts $line} puts DONE exit 0 @@ -2203,13 +2203,13 @@ test chan-io-28.6 {Tcl_CloseEx (half-close) pipe} -setup { removeFile cat.tcl } -result {Succeeded {Hey DONE}} test chan-io-28.7 {Tcl_CloseEx (half-close) socket} -setup { - set echo [makeFile { + set echo [tcltest::makeFile { proc accept {s args} {set ::sok $s} set s [socket -server accept 0] - puts [lindex [fconfigure $s -sockname] 2] + puts [lindex [chan configure $s -sockname] 2] flush stdout vwait ::sok - fconfigure $sok -buffering line + chan configure $sok -buffering line while {[gets $sok line]>=0} {puts $sok $line} puts $sok DONE exit 0 @@ -3038,7 +3038,7 @@ test chan-io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} -setup { string length [chan read $f] } -cleanup { chan close $f -} -result [expr 700*15+1] +} -result [expr {(700 * 15) + 1}] test chan-io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} -setup { file delete $path(test1) } -body { @@ -3055,7 +3055,7 @@ test chan-io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} -setup { string length [chan read $f] } -cleanup { chan close $f -} -result [expr 700*15+1] +} -result [expr {(700 * 15) + 1}] test chan-io-30.15 {Tcl_Write mixed, Tcl_Read auto} -setup { file delete $path(test1) } -body { @@ -3897,7 +3897,7 @@ test chan-io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} -setup { } chan close $f string length $c -} -result [expr 700*15+1] +} -result [expr {(700 * 15) + 1}] test chan-io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} -setup { file delete $path(test1) set c "" @@ -3917,7 +3917,7 @@ test chan-io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} -setup { } chan close $f string length $c -} -result [expr 700*15+1] +} -result [expr {(700 * 15) + 1}] # Test Tcl_Read and buffering. @@ -4178,7 +4178,7 @@ test chan-io-33.7 {Tcl_Gets and bad variable} -setup { chan puts $f "Line 1" chan puts $f "Line 2" chan close $f - catch {unset x} + unset -nocomplain x set f [open $path(test3) r] } -body { set x 24 @@ -4355,7 +4355,7 @@ test chan-io-34.9 {Tcl_Seek, testing buffered input flushing} -setup { } -cleanup { chan close $f } -result {a d a l Y {} b} -set path(test3) [makeFile {} test3] +set path(test3) [tcltest::makeFile {} test3] test chan-io-34.10 {Tcl_Seek testing flushing of buffered input} { set f [open $path(test3) w] chan configure $f -translation lf @@ -5335,7 +5335,7 @@ test chan-io-40.3 {POSIX open access modes: CREAT} -setup { chan close [open $path(test3) {WRONLY CREAT}] file stat $path(test3) stats format "0%o" [expr $stats(mode)&0o777] -} -result [format %04o [expr {0o666 & ~ $umaskValue}]] +} -result [format %04o [expr {0o666 & ( ~ $umaskValue)}]] test chan-io-40.4 {POSIX open access modes: CREAT} -setup { file delete $path(test3) } -body { @@ -5435,7 +5435,7 @@ test chan-io-40.12 {POSIX open access modes: WRONLY} -match regexp -body { open $path(test3) WRONLY } -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory} test chan-io-40.13 {POSIX open access modes: WRONLY} -body { - makeFile xyzzy test3 + tcltest::makeFile xyzzy test3 set f [open $path(test3) WRONLY] chan configure $f -eofchar {} chan puts -nonewline $f "ab" @@ -5449,7 +5449,7 @@ test chan-io-40.14 {POSIX open access modes: RDWR} -match regexp -body { open $path(test3) RDWR } -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory} test chan-io-40.15 {POSIX open access modes: RDWR} { - makeFile xyzzy test3 + tcltest::makeFile xyzzy test3 set f [open $path(test3) RDWR] chan puts -nonewline $f "ab" chan seek $f 0 current @@ -5458,7 +5458,7 @@ test chan-io-40.15 {POSIX open access modes: RDWR} { lappend x [viewFile test3] } {zzy abzzy} test chan-io-40.16 {tilde substitution in open} -constraints makeFileInHome -setup { - makeFile {Some text} _test_ ~ + tcltest::makeFile {Some text} _test_ ~ } -body { file exists [file join $::env(HOME) _test_] } -cleanup { @@ -5493,7 +5493,7 @@ test chan-io-41.5 {Tcl_FileeventCmd: errors} -constraints fileevent -body { # Test chan event on a file # -set path(foo) [makeFile {} foo] +set path(foo) [tcltest::makeFile {} foo] set f [open $path(foo) w+] test chan-io-42.1 {Tcl_FileeventCmd: creating, deleting, querying} {fileevent} { @@ -5645,7 +5645,7 @@ test chan-io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpi } {initial foo eof} chan close $f -makeFile "foo bar" foo +tcltest::makeFile "foo bar" foo test chan-io-45.1 {DeleteFileEvent, cleanup on chan close} {fileevent} { set f [open $path(foo) r] @@ -5849,7 +5849,7 @@ test chan-io-47.6 {file events on shared files, deleting file events} -setup { chan close $f } -result {{script 1} {}} -set path(bar) [makeFile {} bar] +set path(bar) [tcltest::makeFile {} bar] test chan-io-48.1 {testing readability conditions} {fileevent} { set f [open $path(bar) w] @@ -5898,7 +5898,7 @@ test chan-io-48.2 {testing readability conditions} {nonBlockFiles fileevent} { vwait [namespace which -variable x] list $x $l } {done {called called called called called called called}} -set path(my_script) [makeFile {} my_script] +set path(my_script) [tcltest::makeFile {} my_script] test chan-io-48.3 {testing readability conditions} -setup { set l "" } -constraints {stdio unix nonBlockFiles openpipe fileevent} -body { @@ -6714,9 +6714,9 @@ test chan-io-52.8 {TclCopyChannel} -setup { list $s0 [file size $path(test1)] } -result {40 40} # Empty files, to register them with the test facility -set path(kyrillic.txt) [makeFile {} kyrillic.txt] -set path(utf8-fcopy.txt) [makeFile {} utf8-fcopy.txt] -set path(utf8-rp.txt) [makeFile {} utf8-rp.txt] +set path(kyrillic.txt) [tcltest::makeFile {} kyrillic.txt] +set path(utf8-fcopy.txt) [tcltest::makeFile {} utf8-fcopy.txt] +set path(utf8-rp.txt) [tcltest::makeFile {} utf8-rp.txt] # Create kyrillic file, use lf translation to avoid os eol issues set out [open $path(kyrillic.txt) w] chan configure $out -encoding koi8-r -translation lf @@ -6871,10 +6871,10 @@ test chan-io-53.4 {CopyData: background write overflow} -setup { vwait [namespace which -variable x] return $x } -cleanup { - set big {} + set big "" chan close $f1 } -result done -set result {} +set result "" proc FcopyTestAccept {sock args} { after 1000 "chan close $sock" } @@ -6891,7 +6891,7 @@ test chan-io-53.5 {CopyData: error during chan copy} {socket fcopy} { set listen [socket -server [namespace code FcopyTestAccept] -myaddr 127.0.0.1 0] set in [open $thisScript] ;# 126 K set out [socket 127.0.0.1 [lindex [chan configure $listen -sockname] 2]] - catch {unset fcopyTestDone} + unset -nocomplain fcopyTestDone chan close $listen ;# This means the socket open never really succeeds chan copy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone @@ -6906,7 +6906,7 @@ test chan-io-53.6 {CopyData: error during chan copy} -setup { variable fcopyTestDone file delete $path(pipe) file delete $path(test1) - catch {unset fcopyTestDone} + unset -nocomplain fcopyTestDone } -constraints {stdio openpipe fcopy} -body { set f1 [open $path(pipe) w] chan puts $f1 "exit 1" @@ -6940,7 +6940,7 @@ proc doFcopy {in out {bytes 0} {error {}}} { test chan-io-53.7 {CopyData: Flooding chan copy from pipe} -setup { variable fcopyTestDone file delete $path(pipe) - catch {unset fcopyTestDone} + unset -nocomplain fcopyTestDone } -constraints {stdio openpipe fcopy} -body { set fcopyTestCount 0 set f1 [open $path(pipe) w] @@ -6986,11 +6986,11 @@ test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -se return } # Files we use for our channels - set foo [makeFile ashgdfashdgfasdhgfasdhgf foo] - set bar [makeFile {} bar] + set foo [tcltest::makeFile ashgdfashdgfasdhgfasdhgf foo] + set bar [tcltest::makeFile {} bar] # Channels to copy between - set f [open $foo r] ; fconfigure $f -translation binary - set g [open $bar w] ; fconfigure $g -translation binary -buffering none + set f [open $foo r] ; chan configure $f -translation binary + set g [open $bar w] ; chan configure $g -translation binary -buffering none } -constraints {stdio openpipe fcopy} -body { # Record input size, so that result is always defined lappend ::RES [file size $bar] @@ -7012,9 +7012,8 @@ test chan-io-53.8 {CopyData: async callback and error handling, Bug 1932639} -se } -cleanup { chan close $f chan close $g - catch {unset ::RES} - catch {unset ::forever} - rename ::bgerror {} + unset -nocomplain ::RES ::forever + rename ::bgerror "" removeFile foo removeFile bar } -result {0 sync/OK 0 {CMD 2} {bgerror/OK !STOP}} @@ -7026,8 +7025,8 @@ test chan-io-53.8a {CopyData: async callback and error handling, Bug 1932639, at return } # Files we use for our channels - set foo [makeFile ashgdfashdgfasdhgfasdhgf foo] - set bar [makeFile {} bar] + set foo [tcltest::makeFile ashgdfashdgfasdhgfasdhgf foo] + set bar [tcltest::makeFile {} bar] # Channels to copy between set f [open $foo r] ; chan configure $f -translation binary set g [open $bar w] ; chan configure $g -translation binary -buffering none @@ -7052,14 +7051,13 @@ test chan-io-53.8a {CopyData: async callback and error handling, Bug 1932639, at } -cleanup { chan close $f chan close $g - catch {unset ::RES} - catch {unset ::forever} + unset -nocomplain ::RES ::forever removeFile foo removeFile bar } -result {1 sync/OK {CMD 0}} test chan-io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { - set out [makeFile {} out] - set err [makeFile {} err] + set out [tcltest::makeFile {} out] + set err [tcltest::makeFile {} err] set pipe [open "|[list [info nameofexecutable] 2> $err]" r+] chan configure $pipe -translation binary -buffering line chan puts $pipe { @@ -7107,10 +7105,10 @@ test chan-io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { catch {close $out} catch {removeFile out} catch {removeFile err} - catch {unset ::forever} + unset -nocomplain ::forever } -result OK test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { - set err [makeFile {} err] + set err [tcltest::makeFile {} err] set pipe [open "|[list [info nameofexecutable] 2> $err]" r+] chan configure $pipe -translation binary -buffering line chan puts $pipe { @@ -7133,7 +7131,7 @@ test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { lappend l $sok if {[llength $l] == 2} { chan close $srv - foreach {a b} $l break + lassign $l a b chan copy $a $b -command [list geof $a] chan copy $b $a -command [list geof $b] chan puts stderr 2COPY @@ -7178,7 +7176,7 @@ test chan-io-53.10 {Bug 1350564, multi-directional fcopy} -setup { after 1000 ;# Give Windows time to kill the process } removeFile err - catch {unset ::forever} + unset -nocomplain ::forever } -result {AB BA} test chan-io-54.1 {Recursive channel events} {socket fileevent} { @@ -7285,7 +7283,7 @@ test chan-io-54.2 {Testing for busy-wait in recursive channel events} -setup { if {$accept ne {}} {chan close $accept} } -result 1 -set path(fooBar) [makeFile {} fooBar] +set path(fooBar) [tcltest::makeFile {} fooBar] test chan-io-55.1 {ChannelEventScriptInvoker: deletion} -constraints { fileevent @@ -7452,7 +7450,7 @@ test chan-io-60.1 {writing illegal utf sequences} {openpipe fileevent} { } {1 {gets {} catch {error writing "stdout": invalid argument}}} test chan-io-61.1 {Reset eof state after changing the eof char} -setup { - set datafile [makeFile {} eofchar] + set datafile [tcltest::makeFile {} eofchar] set f [open $datafile w] chan configure $f -translation binary chan puts -nonewline $f [string repeat "Ho hum\n" 11] @@ -7483,7 +7481,7 @@ test chan-io-61.1 {Reset eof state after changing the eof char} -setup { # used for that here. test chan-io-70.0 {Cutting & Splicing channels} -setup { - set f [makeFile {... dummy ...} cutsplice] + set f [tcltest::makeFile {... dummy ...} cutsplice] set res {} } -constraints {testchannel} -body { set c [open $f r] @@ -7498,7 +7496,7 @@ test chan-io-70.0 {Cutting & Splicing channels} -setup { } -result {0 1 0} test chan-io-70.1 {Transfer channel} -setup { - set f [makeFile {... dummy ...} cutsplice] + set f [tcltest::makeFile {... dummy ...} cutsplice] set res {} } -constraints {testchannel thread} -body { set c [open $f r] @@ -7683,7 +7681,7 @@ foreach {n msg expected} { f3 {-code boss -code 0 -level X -f ba} {-code 1 -level 0 -f ba} } { test chan-io-71.$n {Tcl_SetChannelError} -setup { - set f [makeFile {... dummy ...} cutsplice] + set f [tcltest::makeFile {... dummy ...} cutsplice] } -constraints {testchannel} -body { set c [open $f r] testchannel setchannelerror $c [lrange $msg 0 end] @@ -7692,7 +7690,7 @@ foreach {n msg expected} { removeFile cutsplice } -result [lrange $expected 0 end] test chan-io-72.$n {Tcl_SetChannelErrorInterp} -setup { - set f [makeFile {... dummy ...} cutsplice] + set f [tcltest::makeFile {... dummy ...} cutsplice] } -constraints {testchannel} -body { set c [open $f r] testchannel setchannelerrorinterp $c [lrange $msg 0 end] @@ -7712,8 +7710,8 @@ test chan-io-73.1 {channel Tcl_Obj SetChannelFromAny} -body { # cleanup foreach file [list fooBar longfile script output test1 pipe my_script \ test2 test3 cat kyrillic.txt utf8-fcopy.txt utf8-rp.txt] { - removeFile $file + tcltest::removeFile $file } -cleanupTests +tcltest::cleanupTests } namespace delete ::tcl::test::io diff --git a/tests/clock.test b/tests/clock.test index 0202fc7..0d7d23e 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -238,7 +238,6 @@ namespace eval ::testClock { DaylightStart \x00\x00\x03\x00\x02\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00]] } - proc ::testClock::registry { cmd path key } { variable reg if { $cmd ne {get} } { @@ -21058,7 +21057,6 @@ test clock-10.8 {parse ccyyddd} { clock scan {2001 365} -format {%Y %j} -locale en_US_roman -gmt 1 } 1009756800 - test clock-10.9 {seconds take precedence over ccyyddd} { list [clock scan {0 2000001} -format {%s %Y%j} -gmt true] \ [clock scan {2000001 0} -format {%Y%j %s} -gmt true] @@ -35850,7 +35848,6 @@ test clock-35.3 {clock seconds tests} { expr "$end > $start" } {1} - test clock-36.1 {clock scan next monthname} { clock format [clock scan "next june" -base [clock scan "june 1, 2000"]] \ -format %m.%Y @@ -35925,7 +35922,6 @@ test clock-38.2 {make sure TZ is not cached after unset} \ } \ -result 1 - test clock-39.1 {regression - synonym timezones} { clock format 0 -format {%H:%M:%S} -timezone :US/Eastern } {19:00:00} @@ -36704,12 +36700,12 @@ test clock-58.1 {clock l10n - Japanese localisation} {*}{ -setup { proc backslashify { string } { - set retval {} - foreach char [split $string {}] { + set retval "" + foreach char [split $string ""] { scan $char %c ccode - if { $ccode >= 0x0020 && $ccode < 0x007f - && $char ne "\{" && $char ne "\}" && $char ne "\[" - && $char ne "\]" && $char ne "\\" && $char ne "\$" } { + if { ($ccode >= 0x0020) && + ($ccode < 0x007f) && + ($char ni "\{ \} \[ \] \\ \$") } { append retval $char } else { append retval \\u [format %04x $ccode] @@ -36860,10 +36856,10 @@ test clock-61.2 {overflow of a wide integer on output} {*}{ } test clock-61.3 {near-miss overflow of a wide integer on output} { clock format 0x7fffffffffffffff -format %s -gmt true -} [expr 0x7fffffffffffffff] +} [expr {0x7fffffffffffffff}] test clock-61.4 {near-miss overflow of a wide integer on output} { clock format -0x8000000000000000 -format %s -gmt true -} [expr -0x8000000000000000] +} [expr {-0x8000000000000000}] test clock-62.1 {Bug 1902423} {*}{ -setup {::tcl::clock::ClearCaches} diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 3051bfb..0782465 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -22,9 +22,9 @@ testConstraint testchmod [llength [info commands testchmod]] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint linkDirectory [expr { - ![testConstraint win] || - ([string index $tcl_platform(osVersion) 0] >= 5 - && [lindex [file system [temporaryDirectory]] 1] eq "NTFS") + (![testConstraint win]) || + (([string index $tcl_platform(osVersion) 0] >= 5) && + ([lindex [file system [tcltest::temporaryDirectory]] 1] eq "NTFS")) }] global env @@ -36,15 +36,15 @@ proc waitForEvenSecondForFAT {} { # data in its timestamps for even per-second-accurate timings. :^( # This procedure based on work by Helmut Giese if { - [testConstraint win] && - [lindex [file system [temporaryDirectory]] 1] ne "NTFS" - } then { + [tcltest::testConstraint win] && + ([lindex [file system [tcltest::temporaryDirectory]] 1] ne "NTFS") + } { # Assume non-NTFS means FAT{12,16,32} and hence in need of special # help... set start [clock seconds] while {1} { set now [clock seconds] - if {$now!=$start && !($now & 1)} { + if {($now != $start) && (!($now & 1))} { break } after 50 @@ -80,7 +80,7 @@ test cmdAH-1.5 {Bug 3595576} { test cmdAH-2.1 {Tcl_CdObjCmd} -returnCodes error -body { cd foo bar } -result {wrong # args: should be "cd ?dirName?"} -set foodir [file join [temporaryDirectory] foo] +set foodir [file join [::tcltest::temporaryDirectory] foo] test cmdAH-2.2 {Tcl_CdObjCmd} -setup { file delete -force $foodir set oldpwd [pwd] @@ -649,10 +649,10 @@ test cmdAH-10.34 {Tcl_FileObjCmd: rootname} testsetplatform { file rootname a\\b.c\\ } a\\b.c\\ set num 35 -foreach outer { {} a .a a. a.a } { - foreach inner { {} a .a a. a.a } { +foreach outer { "" a .a a. a.a } { + foreach inner { "" a .a a. a.a } { set thing [format %s/%s $outer $inner] - ;test cmdAH-10.$num {Tcl_FileObjCmd: rootname and extension options} testsetplatform " + test cmdAH-10.$num {Tcl_FileObjCmd: rootname and extension options} testsetplatform " testsetplatform unix [list format %s%s [file rootname $thing] [file ext $thing]] " $thing @@ -817,8 +817,8 @@ test cmdAH-15.1 {Tcl_FileObjCmd} -constraints testsetplatform -body { catch {testsetplatform $platform} # readable -set gorpfile [makeFile abcde gorp.file] -set dirfile [makeDirectory dir.file] +set gorpfile [tcltest::makeFile abcde gorp.file] +set dirfile [tcltest::makeDirectory dir.file] test cmdAH-16.1 {Tcl_FileObjCmd: readable} { -returnCodes error -body {file readable a b} @@ -857,10 +857,10 @@ test cmdAH-17.3 {Tcl_FileObjCmd: writable} { } # executable -removeFile $gorpfile -removeDirectory $dirfile -set dirfile [makeDirectory dir.file] -set gorpfile [makeFile abcde gorp.file] +tcltest::removeFile $gorpfile +tcltest::removeDirectory $dirfile +set dirfile [tcltest::makeDirectory dir.file] +set gorpfile [tcltest::makeFile abcde gorp.file] test cmdAH-18.1 {Tcl_FileObjCmd: executable} -returnCodes error -body { file executable a b } -result {wrong # args: should be "file executable name"} @@ -894,10 +894,10 @@ test cmdAH-18.6 {Tcl_FileObjCmd: executable} {} { file exe $dirfile } 1 -removeDirectory $dirfile -removeFile $gorpfile -set linkfile [file join [temporaryDirectory] link.file] -file delete $linkfile +tcltest::removeDirectory $dirfile +tcltest::removeFile $gorpfile +set linkfile [file join [tcltest::temporaryDirectory] link.file] +file delete -- $linkfile # exists test cmdAH-19.1 {Tcl_FileObjCmd: exists} -returnCodes error -body { @@ -905,12 +905,12 @@ test cmdAH-19.1 {Tcl_FileObjCmd: exists} -returnCodes error -body { } -result {wrong # args: should be "file exists name"} test cmdAH-19.2 {Tcl_FileObjCmd: exists} {file exists $gorpfile} 0 test cmdAH-19.3 {Tcl_FileObjCmd: exists} { - file exists [file join [temporaryDirectory] dir.file gorp.file] + file exists [file join [tcltest::temporaryDirectory] dir.file gorp.file] } 0 catch { - set gorpfile [makeFile abcde gorp.file] - set dirfile [makeDirectory dir.file] - set subgorp [makeFile 12345 [file join $dirfile gorp.file]] + set gorpfile [tcltest::makeFile abcde gorp.file] + set dirfile [tcltest::makeDirectory dir.file] + set subgorp [tcltest::makeFile 12345 [file join $dirfile gorp.file]] } test cmdAH-19.4 {Tcl_FileObjCmd: exists} { file exists $gorpfile @@ -958,15 +958,15 @@ test cmdAH-19.11 {Tcl_FileObjCmd: exists} -constraints {unix notRoot} -setup { # Stat related commands catch {testsetplatform $platform} -removeFile $gorpfile -set gorpfile [makeFile "Test string" gorp.file] +tcltest::removeFile $gorpfile +set gorpfile [tcltest::makeFile "Test string" gorp.file] catch {file attributes $gorpfile -permissions 0765} # avoid problems with non-local filesystems -if {[testConstraint unix] && [file exists /tmp]} { - set file [makeFile "data" touch.me /tmp] +if {[tcltest::testConstraint unix] && [file exists /tmp]} { + set file [tcltest::makeFile "data" touch.me /tmp] } else { - set file [makeFile "data" touch.me] + set file [tcltest::makeFile "data" touch.me] } # atime @@ -1012,10 +1012,10 @@ test cmdAH-20.6 {Tcl_FileObjCmd: atime touch} -setup { expr {$newatime == $modatime ? 1 : "$newatime != $modatime"} } -result 1 -if {[testConstraint unix] && [file exists /tmp]} { - removeFile touch.me /tmp +if {[::tcltest::testConstraint unix] && [file exists /tmp]} { + ::tcltest::removeFile touch.me /tmp } else { - removeFile touch.me + ::tcltest::removeFile touch.me } # isdirectory @@ -1065,8 +1065,8 @@ test cmdAH-23.6 {Tcl_FileObjCmd: lstat errors} -setup { } -result {1 {can't set "x(dev)": variable isn't array} {TCL LOOKUP VARNAME x}} unset -nocomplain stat # mkdir -set dirA [file join [temporaryDirectory] a] -set dirB [file join [temporaryDirectory] a] +set dirA [file join [::tcltest::temporaryDirectory] a] +set dirB [file join [::tcltest::temporaryDirectory] a] test cmdAH-23.7 {Tcl_FileObjCmd: mkdir} -setup { catch {file delete -force $dirA} } -body { @@ -1106,7 +1106,7 @@ test cmdAH-23.11 {Tcl_FileObjCmd: mkdir} { file mkdir } {} -set file [makeFile "data" touch.me] +set file [::tcltest::makeFile "data" touch.me] # mtime test cmdAH-24.1 {Tcl_FileObjCmd: mtime} -returnCodes error -body { file mtime a b c @@ -1283,7 +1283,7 @@ test cmdAH-27.1 {Tcl_FileObjCmd: size} -returnCodes error -body { test cmdAH-27.2 {Tcl_FileObjCmd: size} { set oldsize [file size $gorpfile] set f [open $gorpfile a] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts $f "More text" close $f expr {[file size $gorpfile] - $oldsize} @@ -1572,10 +1572,10 @@ unset -nocomplain platform # Tcl_ForObjCmd is tested in for.test catch {file attributes $dirfile -permissions 0777} -removeDirectory $dirfile -removeFile $gorpfile +tcltest::removeDirectory $dirfile +tcltest::removeFile $gorpfile # No idea how well [removeFile] copes with links... -file delete $linkfile +file delete -- $linkfile cd $cmdAHwd diff --git a/tests/cmdIL.test b/tests/cmdIL.test index 721773f..c34a6a6 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -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. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index 2d68138..9368b0e 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -289,8 +289,8 @@ test cmdMZ-4.9 {Tcl_SplitObjCmd: basic split commands} { } {{} {} {} {}} test cmdMZ-4.10 {Tcl_SplitObjCmd: basic split commands} { apply {{} { - set x {} - foreach f [split {]\n} {}] { + set x "" + foreach f [split {]\n} ""] { append x $f } return $x diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test index bae26a0..058dade 100644 --- a/tests/compExpr-old.test +++ b/tests/compExpr-old.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -20,7 +20,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} { +if {[catch {expr T1()} msg] && ($msg eq {invalid command name "tcl::mathfunc::T1"})} { testConstraint testmathfunctions 0 } else { testConstraint testmathfunctions 1 @@ -84,8 +84,8 @@ proc testIEEE {} { } testConstraint ieeeFloatingPoint [testIEEE] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] +testConstraint longIs32bit [expr { ( int (0x80000000) ) < 0}] +testConstraint longIs64bit [expr { ( int (0x8000000000000000) ) < 0}] # procedures used below @@ -98,32 +98,33 @@ proc hello_world {} { global a set a "" set L1 [set l0 [set h_1 [set q 0]]] - for {put_hello_char [expr [put_hello_char [expr [set h 7]*10+2]]+29]} {$l0?[put_hello_char $l0] - :!$h_1} {put_hello_char $ll;expr {$L1==2?[set ll [expr 32+0-0+[set bar 0]]]:0}} {expr {[incr L1]==[expr 1+([string length "abc"]-[string length "abc"])] - ?[set ll [set l0 [expr 54<<1]]]:$ll==108&&$L1<3? - [incr ll [expr 1|1<<1]; set ll $ll; set ll $ll; set ll $ll; set ll $ll; set l0 [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]; set l0; set l0 $l0; set l0; set l0]:$L1==4&&$ll==32?[set ll [expr 19+$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+[set foo [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]]]] - :[set q [expr $q-$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]};expr {$L1==5?[incr ll -8; set ll $ll; set ll]:$q&&$h1&&1};expr {$L1==4+2 - ?[incr ll 3]:[expr ([string length "abc"]-[string length "abc"])+1]};expr {$ll==($h<<4)+2+0&&$L1!=6?[incr ll -6]:[set h1 [expr 100+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]} - expr {$L1!=1<<3?[incr q [expr ([string length "abc"]-[string length "abc"])-1]]:[set h_1 [set ll $h1]]} + for {put_hello_char [expr [put_hello_char [expr [set h 7] * 10 + 2]]+29]} {$l0 ? [put_hello_char $l0] + : (!$h_1)} {put_hello_char $ll;expr {($L1 == 2) ? [set ll [expr 32 + 0 - 0 + [set bar 0]]] : 0}} { + expr {([incr L1] == [expr 1 + ([string length "abc"] - [string length "abc"])]) + ? [set ll [set l0 [expr 54 << 1]]] : (($ll == 108) && ($L1 < 3)) ? + [incr ll [expr 1 | 1 << 1]; set ll $ll; set ll $ll; set ll $ll; set ll $ll; set l0 [expr ([string length "abc"] - [string length "abc"]) + ([string length "abc"] - [string length "abc"]) - ([string length "abc"] - [string length "abc"]) + ([string length "abc"] - [string length "abc"])]; set l0; set l0 $l0; set l0; set l0] : (($L1 == 4) && ($ll == 32)) ? [set ll [expr 19 + $h1 + ([string length "abc"] - [string length "abc"]) - ([string length "abc"] - [string length "abc"]) + ([string length "abc"] - [string length "abc"]) - ([string length "abc"] - [string length "abc"]) + [set foo [expr ([string length "abc"] - [string length "abc"]) + ([string length "abc"] - [string length "abc"]) + ([string length "abc"] - [string length "abc"])]]]] + : [set q [expr $q - $h1 + ([string length "abc"] - [string length "abc"]) - ([string length "abc"] - [string length "abc"])]]};expr {($L1 == 5) ? [incr ll -8; set ll $ll; set ll] : ($q && $h1 && 1)};expr {($L1 == (4 + 2)) + ? [incr ll 3] : [expr ([string length "abc"] - [string length "abc"]) + 1]};expr {(($ll == (($h << 4) + 2 + 0)) && ($L1 != 6)) ? [incr ll -6] : [set h1 [expr 100 + ([string length "abc"] - [string length "abc"]) - ([string length "abc"] - [string length "abc"])]]} + expr {($L1 != (1 << 3)) ? [incr q [expr ([string length "abc"] - [string length "abc"]) - 1]] : [set h_1 [set ll $h1]]} } set a } proc 12days {a b c} { global xxx - expr {1<$a?[expr {$a<3?[12days -79 -13 [string range $c [12days -87 \ - [expr 1-$b] [string range $c [12days -86 0 [string range $c 1 end]] \ - end]] end]]:1};expr {$a<$b?[12days [expr $a+1] $b $c]:3};expr {[12days \ - -94 [expr $a-27] $c]&&$a==2?$b<13?[12days 2 [expr $b+1] "%s %d %d\n"]:9 - :16}]:$a<0?$a<-72?[12days $b $a "@n'+,#'/*\{\}w+/w#cdnr/+,\{\}r/*de\}+,/*\{*+,/w\{%+,/w#q#n+,/#\{l+,/n\{n+,/+#n+,/#;#q#n+,/+k#;*+,/'r :'d*'3,\}\{w+K w'K:'+\}e#';dq#'l q#'+d'K#!/+k#;q#'r\}eKK#\}w'r\}eKK\{nl\]'/#;#q#n')\{)#\}w')\{)\{nl\]'/+#n';d\}rw' i;# )\{nl\]!/n\{n#'; r\{#w'r nc\{nl\]'/#\{l,+'K \{rw' iK\{;\[\{nl\]'/w#q#n'wk nw' iwk\{KK\{nl\]!/w\{%'l##w#' i; :\{nl\]'/*\{q#'ld;r'\}\{nlwb!/*de\}'c ;;\{nl'-\{\}rw\]'/+,\}##'*\}#nc,',#nw\]'/+kd'+e\}+;#'rdq#w! nr'/ ') \}+\}\{rl#'\{n' ')# \}'+\}##(!!/"] - :$a<-50?[string compare [format %c $b] [string index $c 0]]==0?[append \ + expr {(1 < $a) ? [expr {($a < 3) ? [12days -79 -13 [string range $c [12days -87 \ + [expr 1 - $b] [string range $c [12days -86 0 [string range $c 1 end]] \ + end]] end]] : 1}; expr {($a < $b) ? [12days [expr ($a + 1)] $b $c] : 3}; expr {([12days \ + -94 [expr $a - 27] $c] && ($a == 2)) ? ($b < 13) ? [12days 2 [expr $b + 1] "%s %d %d\n"] : 9 + : 16}] : ($a < 0) ? ($a < -72) ? [12days $b $a "@n'+,#'/*\{\}w+/w#cdnr/+,\{\}r/*de\}+,/*\{*+,/w\{%+,/w#q#n+,/#\{l+,/n\{n+,/+#n+,/#;#q#n+,/+k#;*+,/'r :'d*'3,\}\{w+K w'K:'+\}e#';dq#'l q#'+d'K#!/+k#;q#'r\}eKK#\}w'r\}eKK\{nl\]'/#;#q#n')\{)#\}w')\{)\{nl\]'/+#n';d\}rw' i;# )\{nl\]!/n\{n#'; r\{#w'r nc\{nl\]'/#\{l,+'K \{rw' iK\{;\[\{nl\]'/w#q#n'wk nw' iwk\{KK\{nl\]!/w\{%'l##w#' i; :\{nl\]'/*\{q#'ld;r'\}\{nlwb!/*de\}'c ;;\{nl'-\{\}rw\]'/+,\}##'*\}#nc,',#nw\]'/+kd'+e\}+;#'rdq#w! nr'/ ') \}+\}\{rl#'\{n' ')# \}'+\}##(!!/"] + : ($a < -50) ? ([string compare [format %c $b] [string index $c 0]] == 0) ? [append \ xxx [string index $c 31];scan [string index $c 31] %c x;set x] - :[12days -65 $b [string range $c 1 end]]:[12days [expr ([string compare \ - [string index $c 0] "/"]==0)+$a] $b [string range $c 1 end]]:0<$a - ?[12days 2 2 "%s"]:[string compare [string index $c 0] "/"]==0|| + :[12days -65 $b [string range $c 1 end]] : [12days [expr ([string compare \ + [string index $c 0] "/"] == 0) + $a] $b [string range $c 1 end]] : (0 < $a) + ? [12days 2 2 "%s"] : (([string compare [string index $c 0] "/"] == 0) || [12days 0 [12days -61 [scan [string index $c 0] %c x; set x] \ "!ek;dc i@bK'(q)-\[w\]*%n+r3#l,\{\}:\nuwloca-O;m .vpbks,fxntdCeghiry"] \ - [string range $c 1 end]]} + [string range $c 1 end]])} } proc do_twelve_days {} { global xxx @@ -136,7 +137,7 @@ proc do_twelve_days {} { # start of tests -catch {unset a b i x} +unset -nocomplain a b i x test compExpr-old-1.1 {TclCompileExprCmd: no expression} { list [catch {expr } msg] $msg @@ -332,7 +333,6 @@ test compExpr-old-8.11 {CompileEqualityExpr: error compiling equality arm} -body expr 2!=x } -returnCodes error -match glob -result * - test compExpr-old-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12 test compExpr-old-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63 test compExpr-old-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1 @@ -490,13 +490,13 @@ test compExpr-old-14.12 {CompilePrimaryExpr: var reference primary} { list [expr {$i}] [expr $i] } {789 789} test compExpr-old-14.13 {CompilePrimaryExpr: var reference primary} { - catch {unset a} + unset -nocomplain a set a(foo) foo set a(bar) bar set a(123) 123 set result "" lappend result [expr $a(123)] [expr {$a(bar)<$a(foo)}] - catch {unset a} + unset -nocomplain a set result } {123 1} test compExpr-old-14.14 {CompilePrimaryExpr: var reference primary} { @@ -619,11 +619,11 @@ test compExpr-old-15.11 {CompileMathFuncCall: call registered math function} tes } -17.5 test compExpr-old-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} { - catch {unset a} + unset -nocomplain a set a(VALUE) ff15 set i 123 if {[expr 0x$a(VALUE)] & 16} { - set i {} + set i "" } set i } {} diff --git a/tests/compExpr.test b/tests/compExpr.test index 14c875d..f5d2bf8 100644 --- a/tests/compExpr.test +++ b/tests/compExpr.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} { +if {[catch {expr T1()} msg] && ($msg eq {invalid command name "tcl::mathfunc::T1"})} { testConstraint testmathfunctions 0 } else { testConstraint testmathfunctions 1 @@ -25,7 +25,7 @@ if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1" # Constrain memory leak tests testConstraint memory [llength [info commands memory]] -catch {unset a} +unset -nocomplain a test compExpr-1.1 {TclCompileExpr procedure, successful expr parse and compile} { expr 1+2 @@ -385,8 +385,7 @@ test compExpr-7.2 {[Bug 1869989]: expr parser memleak} -constraints memory -setu } -result 0 # cleanup -catch {unset a} -catch {unset b} +unset -nocomplain a b ::tcltest::cleanupTests return diff --git a/tests/compile.test b/tests/compile.test index 4d91940..a5609d9 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -26,13 +26,11 @@ testConstraint testevalex [llength [info commands testevalex]] catch {rename p ""} catch {namespace delete test_ns_compile} -catch {unset x} -catch {unset y} -catch {unset a} +unset -nocomplain x y a test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} -setup { catch {namespace delete test_ns_compile} - catch {unset x} + unset -nocomplain x } -body { set x 123 namespace eval test_ns_compile { @@ -52,13 +50,13 @@ test compile-1.2 {TclCompileString, error result is reset if TclGetLong determin } {1 {wrong # args: should be "p x"}} test compile-2.1 {TclCompileDollarVar: global scalar name with ::s} -setup { - catch {unset x} + unset -nocomplain x } -body { set x 123 list $::x [expr {"x" in [info globals]}] } -result {123 1} test compile-2.2 {TclCompileDollarVar: global scalar name with ::s} -setup { - catch {unset y} + unset -nocomplain y } -body { proc p {} { set ::y 789 @@ -67,13 +65,13 @@ test compile-2.2 {TclCompileDollarVar: global scalar name with ::s} -setup { list [p] $::y [expr {"y" in [info globals]}] } -result {789 789 1} test compile-2.3 {TclCompileDollarVar: global array name with ::s} -setup { - catch {unset a} + unset -nocomplain a } -body { set ::a(1) 2 list $::a(1) [set ::a($::a(1)) 3] $::a(2) [expr {"a" in [info globals]}] } -result {2 3 3 1} test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} -setup { - catch {unset a} + unset -nocomplain a } -body { proc p {} { set ::a(1) 1 @@ -82,7 +80,7 @@ test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} -setup { list [p] $::a(1) [expr {"a" in [info globals]}] } -result {1 1 1} test compile-2.5 {TclCompileDollarVar: global array, called as ${arrName(0)}} -setup { - catch {unset a} + unset -nocomplain a } -body { proc p {} { global a @@ -93,7 +91,7 @@ test compile-2.5 {TclCompileDollarVar: global array, called as ${arrName(0)}} -s } -result {111 1 1} test compile-3.1 {TclCompileCatchCmd: only catch cmds with scalar vars are compiled inline} -setup { - catch {unset a} + unset -nocomplain a } -body { set a(1) xyzzyx proc p {} { @@ -196,8 +194,7 @@ test compile-5.2 {TclCompileForeachCmd: non-local variables} { } 3 test compile-6.1 {TclCompileSetCmd: global scalar names with ::s} -setup { - catch {unset x} - catch {unset y} + unset -nocomplain x y } -body { set x 123 proc p {} { @@ -208,7 +205,7 @@ test compile-6.1 {TclCompileSetCmd: global scalar names with ::s} -setup { [p] $::y [expr {"y" in [info globals]}] } -result {123 1 789 789 1} test compile-6.2 {TclCompileSetCmd: global array names with ::s} -setup { - catch {unset a} + unset -nocomplain a } -body { set ::a(1) 2 proc p {} { @@ -219,7 +216,7 @@ test compile-6.2 {TclCompileSetCmd: global array names with ::s} -setup { } -result {2 1 3 3 1} test compile-6.3 {TclCompileSetCmd: namespace var names with ::s} -setup { catch {namespace delete test_ns_compile} - catch {unset x} + unset -nocomplain x } -body { namespace eval test_ns_compile { variable v hello @@ -248,14 +245,14 @@ test compile-8.2 {CollectArgInfo: binary data} { list [catch "string length foo\000" msg] $msg } {0 4} test compile-8.3 {CollectArgInfo: handle "]" at end of command properly} { - set x ] -} {]} + set x "\]" +} "\]" test compile-9.1 {UpdateStringOfByteCode: called for duplicate of compiled empty object} { proc p {} { - set x {} + set x "" eval $x - append x { } + append x " " eval $x } p @@ -349,7 +346,7 @@ test compile-12.2 {testing error on literal deletion} -constraints {memory exec} # Test to catch buffer overrun in TclCompileTokens from buf 530320 test compile-12.3 {check for a buffer overrun} -body { proc crash {} { - puts $array([expr {a+2}]) + puts $array([expr {a + 2}]) } crash } -returnCodes error -cleanup { @@ -452,12 +449,12 @@ test compile-15.5 {proper TCL_RETURN code from [return]} { for {set noComp 0} {$noComp <= 1} {incr noComp} { -if $noComp { - interp alias {} run {} testevalex +if {$noComp} { + interp alias "" run "" testevalex set constraints testevalex } else { - interp alias {} run {} if 1 - set constraints {} + interp alias "" run "" if 1 + set constraints "" } test compile-16.1.$noComp {TclCompileScript: word expansion} $constraints { @@ -534,30 +531,30 @@ test compile-16.17.$noComp {TclCompileScript: word expansion} $constraints { # suite. # test compile-16.18.$noComp {TclCompileScript: word expansion} -body { - proc LongList {} {return [lrepeat [expr {1<<10}] x]} - llength [run "list [string repeat {{*}[LongList] } [expr {1<<10}]]"] + proc LongList {} {return [lrepeat [expr {1 << 10}] x]} + llength [run "list [string repeat {{*}[LongList] } [expr {1 << 10}]]"] } -constraints [linsert $constraints 0 knownBug] -cleanup { rename LongList {} -} -returnCodes ok -result [expr {1<<20}] +} -returnCodes ok -result [expr {1 << 20}] test compile-16.19.$noComp {TclCompileScript: word expansion} -body { - proc LongList {} {return [lrepeat [expr {1<<11}] x]} - llength [run "list [string repeat {{*}[LongList] } [expr {1<<11}]]"] + proc LongList {} {return [lrepeat [expr {1 << 11}] x]} + llength [run "list [string repeat {{*}[LongList] } [expr {1 << 11}]]"] } -constraints [linsert $constraints 0 knownBug] -cleanup { rename LongList {} -} -returnCodes ok -result [expr {1<<22}] +} -returnCodes ok -result [expr {1 << 22}] test compile-16.20.$noComp {TclCompileScript: word expansion} -body { - proc LongList {} {return [lrepeat [expr {1<<12}] x]} - llength [run "list [string repeat {{*}[LongList] } [expr {1<<12}]]"] + proc LongList {} {return [lrepeat [expr {1 << 12}] x]} + llength [run "list [string repeat {{*}[LongList] } [expr {1 << 12}]]"] } -constraints [linsert $constraints 0 knownBug] -cleanup { - rename LongList {} -} -returnCodes ok -result [expr {1<<24}] + rename LongList "" +} -returnCodes ok -result [expr {1 << 24}] # This is the one that should cause overflow test compile-16.21.$noComp {TclCompileScript: word expansion} -body { - proc LongList {} {return [lrepeat [expr {1<<16}] x]} - llength [run "list [string repeat {{*}[LongList] } [expr {1<<16}]]"] + proc LongList {} {return [lrepeat [expr {1 << 16}] x]} + llength [run "list [string repeat {{*}[LongList] } [expr {1 << 16}]]"] } -constraints [linsert $constraints 0 knownBug] -cleanup { rename LongList {} -} -returnCodes ok -result [expr {wide(1)<<32}] +} -returnCodes ok -result [expr { ( wide (1) ) << 32}] test compile-16.22.$noComp { Bug 845412: TclCompileScript: word expansion not mandatory } -body { @@ -712,9 +709,7 @@ test compile-18.19 {disassembler - basics} -setup { # cleanup catch {rename p ""} catch {namespace delete test_ns_compile} -catch {unset x} -catch {unset y} -catch {unset a} +unset -nocomplain x y a ::tcltest::cleanupTests return diff --git a/tests/config.test b/tests/config.test index d14837e..cc1c13b 100644 --- a/tests/config.test +++ b/tests/config.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -29,7 +29,6 @@ test pkgconfig-1.3 {query value multiple times} { [::tcl::pkgconfig get bindir,install] } 0 - test pkgconfig-2.0 {error: missing subcommand} { catch {::tcl::pkgconfig} msg set msg diff --git a/tests/coroutine.test b/tests/coroutine.test index 8272717..e009dac 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } diff --git a/tests/dict.test b/tests/dict.test index 72a336c..4b54c07 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -17,7 +17,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] if {[testConstraint memory]} { - proc memtest script { + proc memtest {script} { set end [lindex [split [memory info] \n] 3 3] for {set i 0} {$i < 5} {incr i} { uplevel 1 $script diff --git a/tests/encoding.test b/tests/encoding.test index 0374e2d..91056e0 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -92,12 +92,12 @@ test encoding-3.1 {Tcl_GetEncodingName, NULL} -setup { encoding system $old } -result {shiftjis} test encoding-3.2 {Tcl_GetEncodingName, non-null} -setup { - set old [fconfigure stdout -encoding] + set old [chan configure stdout -encoding] } -body { - fconfigure stdout -encoding jis0208 - fconfigure stdout -encoding + chan configure stdout -encoding jis0208 + chan configure stdout -encoding } -cleanup { - fconfigure stdout -encoding $old + chan configure stdout -encoding $old } -result {jis0208} test encoding-4.1 {Tcl_GetEncodingNames} -constraints {testencoding} -setup { @@ -105,8 +105,7 @@ test encoding-4.1 {Tcl_GetEncodingNames} -constraints {testencoding} -setup { makeDirectory [file join tmp encoding] set path [encoding dirs] encoding dirs {} - catch {unset encodings} - catch {unset x} + unset -nocomplain encodings x } -body { foreach encoding [encoding names] { set encodings($encoding) 1 @@ -178,11 +177,11 @@ test encoding-7.2 {Tcl_UtfToExternalDString: big buffer} { test encoding-8.1 {Tcl_ExternalToUtf} { set f [open [file join [temporaryDirectory] dummy] w] - fconfigure $f -translation binary -encoding iso8859-1 + chan configure $f -translation binary -encoding iso8859-1 puts -nonewline $f "ab\x8c\xc1g" close $f set f [open [file join [temporaryDirectory] dummy] r] - fconfigure $f -translation binary -encoding shiftjis + chan configure $f -translation binary -encoding shiftjis set x [read $f] close $f file delete [file join [temporaryDirectory] dummy] @@ -206,11 +205,11 @@ 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 + chan configure $f -translation binary -encoding shiftjis puts -nonewline $f "ab\u4e4eg" close $f set f [open [file join [temporaryDirectory] dummy] r] - fconfigure $f -translation binary -encoding iso8859-1 + chan configure $f -translation binary -encoding iso8859-1 set x [read $f] close $f file delete [file join [temporaryDirectory] dummy] @@ -219,7 +218,7 @@ test encoding-10.1 {Tcl_UtfToExternal} { proc viewable {str} { set res "" - foreach c [split $str {}] { + foreach c [split $str ""] { if {[string is print $c] && [string is ascii $c]} { append res $c } else { @@ -265,7 +264,7 @@ test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} makeDirectory tmp makeDirectory [file join tmp encoding] set f [open [file join tmp encoding splat.enc] w] - fconfigure $f -translation binary + chan configure $f -translation binary puts $f "abcdefghijklmnop" close $f encoding convertto splat \u4e4e @@ -366,7 +365,7 @@ set iso2022uniData2 "\u79c1\u3069\u3082\u3067\u306f\u3001\u30c1\u30c3\u30d7\u305 cd [temporaryDirectory] set fid [open iso2022.txt w] -fconfigure $fid -encoding binary +chan configure $fid -encoding binary puts -nonewline $fid $iso2022encData close $fid @@ -377,7 +376,7 @@ test encoding-23.2 {iso2022-jp escape encoding test} { # This checks that 'gets' isn't resetting the encoding inappropriately. # [Bug #523988] set fid [open iso2022.txt r] - fconfigure $fid -encoding iso2022-jp + chan configure $fid -encoding iso2022-jp set out "" set count 0 while {[set num [gets $fid line]] >= 0} { @@ -397,12 +396,12 @@ test encoding-23.2 {iso2022-jp escape encoding test} { test encoding-23.3 {iso2022-jp escape encoding test} { # read $fis <size> reads size in chars, not raw bytes. set fid [open iso2022.txt r] - fconfigure $fid -encoding iso2022-jp + chan configure $fid -encoding iso2022-jp set data [read $fid 50] close $fid return $data } [string range $iso2022uniData 0 49] ; # 0 .. 49 inclusive == 50 -cd [workingDirectory] +cd [::tcltest::workingDirectory] # Code to make the next few tests more intelligible; the code being tested # should be in the body of the test! @@ -418,7 +417,7 @@ proc runInSubprocess {contents {filename iso2022.tcl}} { test encoding-24.1 {EscapeFreeProc on open channels} exec { runInSubprocess { set f [open [file join [file dirname [info script]] iso2022.txt]] - fconfigure $f -encoding iso2022-jp + chan configure $f -encoding iso2022-jp gets $f } } {} @@ -426,7 +425,7 @@ test encoding-24.2 {EscapeFreeProc on open channels} {exec} { # Bug #524674 output viewable [runInSubprocess { encoding system cp1252; # Bug #2891556 crash revelator - fconfigure stdout -encoding iso2022-jp + chan configure stdout -encoding iso2022-jp puts ab\u4e4e\u68d9g set env(TCL_FINALIZE_ON_EXIT) 1 exit @@ -441,14 +440,14 @@ test encoding-24.3 {EscapeFreeProc on open channels} {stdio} { puts $a } iso2022.tcl] set f [open "|[list [interpreter] $file]"] - fconfigure $f -encoding iso2022-jp + chan configure $f -encoding iso2022-jp set count [gets $f line] close $f removeFile iso2022.tcl list $count [viewable $line] } [list 3 "\u4e4e\u4e5e\u4e5f (\\u4e4e\\u4e5e\\u4e5f)"] -file delete [file join [temporaryDirectory] iso2022.txt] +file delete -- [file join [temporaryDirectory] iso2022.txt] # # Begin jajp encoding round-trip conformity tests @@ -478,17 +477,17 @@ proc foreach-jisx0208 {varName command} { } { if {[llength $range] == 2} { # for adhoc range. simple {first last}. inclusive. - scan $range %x%x first last + scan $range "%x%x" first last for {set i $first} {$i <= $last} {incr i} { set code $i uplevel 1 $command } } elseif {[llength $range] == 4} { # for uniform range. - scan $range %x%x%x%x h0 l0 hend lend + scan $range "%x%x%x%x" h0 l0 hend lend for {set hi $h0} {$hi <= $hend} {incr hi} { for {set lo $l0} {$lo <= $lend} {incr lo} { - set code [expr {$hi << 8 | ($lo & 0xff)}] + set code [expr {($hi << 8) | ($lo & 0xff)}] uplevel 1 $command } } @@ -507,20 +506,20 @@ proc gen-jisx0208-iso2022-jp {code} { } proc gen-jisx0208-cp932 {code} { set c1 [expr {($code >> 8) | 0x80}] - set c2 [expr {($code & 0xff)| 0x80}] + set c2 [expr {($code & 0xff) | 0x80}] if {$c1 % 2} { - set c1 [expr {($c1 >> 1) + ($c1 < 0xdf ? 0x31 : 0x71)}] + 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 } proc channel-diff {fa fb} { set diff {} - while {[gets $fa la] >= 0 && [gets $fb lb] >= 0} { - if {[string compare $la $lb] == 0} continue + while {([chan gets $fa la] >= 0) && ([chan gets $fb lb] >= 0)} { + if {$la eq $lb} continue # lappend diff $la $lb # For more readable (easy to analyze) output. @@ -536,7 +535,7 @@ proc channel-diff {fa fb} { cd [temporaryDirectory] foreach enc {cp932 euc-jp iso2022-jp} { set f [open $enc.chars w] - fconfigure $f -encoding binary + chan configure $f -encoding binary foreach-jisx0208 code { puts $f [format "%04X %s" $code [gen-jisx0208-$enc $code]] } @@ -552,9 +551,9 @@ foreach from {cp932 shiftjis euc-jp iso2022-jp} { cd [temporaryDirectory] } -body { set f [open $from.chars] - fconfigure $f -encoding $from + chan configure $f -encoding $from set out [open $from.$to.tcltestout w] - fconfigure $out -encoding $to + chan configure $out -encoding $to puts -nonewline $out [read $f] close $out close $f diff --git a/tests/env.test b/tests/env.test index e75d517..8f22f53 100644 --- a/tests/env.test +++ b/tests/env.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -26,7 +26,7 @@ testConstraint exec [llength [info commands exec]] # test env-1.1 {propagation of env values to child interpreters} -setup { catch {interp delete child} - catch {unset env(test)} + unset -nocomplain env(test) } -body { interp create child set env(test) garbage @@ -40,7 +40,7 @@ test env-1.1 {propagation of env values to child interpreters} -setup { # runs. # test env-1.2 {lappend to env value} -setup { - catch {unset env(test)} + unset -nocomplain env(test) } -body { set env(test) aaaaaaaaaaaaaaaa append env(test) bbbbbbbbbbbbbb @@ -48,14 +48,14 @@ test env-1.2 {lappend to env value} -setup { } test env-1.3 {reflection of env by "array names"} -setup { catch {interp delete child} - catch {unset env(test)} + unset -nocomplain env(test) } -body { interp create child child eval {set env(test) garbage} expr {"test" in [array names env]} } -cleanup { interp delete child - catch {unset env(test)} + unset -nocomplain env(test) } -result {1} set printenvScript [makeFile { @@ -103,9 +103,9 @@ set printenvScript [makeFile { # processes. proc getenv {} { global printenvScript tcltest - catch {exec [interpreter] $printenvScript} out + catch {exec -- [interpreter] $printenvScript} out if {$out eq "child process exited abnormally"} { - set out {} + set out "" } return $out } diff --git a/tests/error.test b/tests/error.test index 97bcc0a..b3ebe63 100644 --- a/tests/error.test +++ b/tests/error.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -135,11 +135,11 @@ test error-3.2 {errors in catch command} { list [catch {catch a b c} msg] $msg } {0 1} test error-3.3 {errors in catch command} { - catch {unset a} + unset -nocomplain a set a(0) 22 list [catch {catch {format 44} a} msg] $msg } {1 {can't set "a": variable is array}} -catch {unset a} +unset -nocomplain a # More tests related to errorInfo and errorCode @@ -532,7 +532,7 @@ foreach level {0 1 2 3} { # Following cases have different -errorinfo; avoid false alarms # TODO: examine whether these difference are as they ought to be. - if {$level == 0 && $code == 1} continue + if {($level == 0) && ($code == 1)} continue foreach extras {{} {-bar soom}} { @@ -823,7 +823,7 @@ test error-19.5 {multiple unrelated fallthroughs #2} { } set RES } {err} -proc addmsg msg { +proc addmsg {msg} { variable RES lappend RES $msg } diff --git a/tests/event.test b/tests/event.test index 0d1b06c..ddf436c 100644 --- a/tests/event.test +++ b/tests/event.test @@ -18,7 +18,6 @@ catch { set ::tcltestlib [lindex [package ifneeded Tcltest [info patchlevel]] 1] } - testConstraint testfilehandler [llength [info commands testfilehandler]] testConstraint testexithandler [llength [info commands testexithandler]] testConstraint testfilewait [llength [info commands testfilewait]] @@ -514,7 +513,7 @@ test event-11.2 {Tcl_VwaitCmd procedure} -returnCodes error -body { vwait a b } -result {wrong # args: should be "vwait name"} test event-11.3 {Tcl_VwaitCmd procedure} -setup { - catch {unset x} + unset -nocomplain x } -body { set x 1 vwait x(1) @@ -549,7 +548,7 @@ test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} -set } set s1 [socket -server accept -myaddr 127.0.0.1 0] after 1000 - set s2 [socket 127.0.0.1 [lindex [fconfigure $s1 -sockname] 2]] + set s2 [socket 127.0.0.1 [lindex [chan configure $s1 -sockname] 2]] close $s1 set x 0 set y 0 diff --git a/tests/exec.test b/tests/exec.test index 871c0c5..a354440 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -37,7 +37,7 @@ set path(cat) [makeFile { if {$argv eq ""} { set argv - } - fconfigure stdout -translation binary + chan configure stdout -translation binary foreach name $argv { if {$name eq "-"} { set f stdin @@ -45,8 +45,8 @@ set path(cat) [makeFile { puts stderr $f continue } - fconfigure $f -translation binary - while {[eof $f] == 0} { + chan configure $f -translation binary + while {[chan eof $f] == 0} { puts -nonewline [read $f] } if {$f ne "stdin"} { @@ -108,10 +108,10 @@ set path(exit) [makeFile { exit $argv } exit] -proc readfile filename { +proc readfile {filename} { set f [open $filename] - set d [read $f] - close $f + set d [chan read $f] + chan close $f return [string trimright $d \n] } @@ -174,7 +174,7 @@ test exec-2.6 {redirecting input from immediate source, with UTF} -setup { # I/O redirection: output to file. set path(gorp.file) [makeFile {} gorp.file] -file delete $path(gorp.file) +file delete -- $path(gorp.file) test exec-3.1 {redirecting output to file} {exec} { exec [interpreter] $path(echo) "Some simple words" > $path(gorp.file) @@ -215,7 +215,7 @@ test exec-3.7 {redirecting output to file} {exec} { # I/O redirection: output and stderr to file. -file delete $path(gorp.file) +file delete -- $path(gorp.file) test exec-4.1 {redirecting output and stderr to file} {exec} { exec [interpreter] $path(echo) "test output" >& $path(gorp.file) @@ -254,7 +254,7 @@ test exec-4.5 {redirecting output and stderr to file} {exec} { # I/O redirection: input from file. if {[testConstraint exec]} { - exec [interpreter] $path(echo) "Just a few thoughts" > $path(gorp.file) + exec -- [interpreter] $path(echo) "Just a few thoughts" > $path(gorp.file) } test exec-5.1 {redirecting input from file} {exec} { exec [interpreter] $path(cat) < $path(gorp.file) @@ -299,8 +299,8 @@ test exec-6.3 {redirecting stderr through a pipeline} {exec stdio} { # I/O redirection: combinations. -set path(gorp.file2) [makeFile {} gorp.file2] -file delete $path(gorp.file2) +set path(gorp.file2) [makeFile "" gorp.file2] +file delete -- $path(gorp.file2) test exec-7.1 {multiple I/O redirections} {exec} { exec << "command input" > $path(gorp.file2) [interpreter] $path(cat) < $path(gorp.file) @@ -465,7 +465,7 @@ test exec-11.5 {commands in background} {exec} { if {[testConstraint exec] && [testConstraint nonPortable]} { after 1300 - exec [interpreter] $path(sleep) 1 + exec -- [interpreter] $path(sleep) 1 } test exec-12.1 {reaping background processes} {exec unix nonPortable} { for {set i 0} {$i < 20} {incr i} { diff --git a/tests/execute.test b/tests/execute.test index 94af158..42a793e 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -24,17 +24,15 @@ catch [list package require -exact Tcltest [info patchlevel]] catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename foo ""} -catch {unset x} -catch {unset y} -catch {unset msg} +unset -nocomplain x y msg testConstraint testobj [expr { - [llength [info commands testobj]] - && [llength [info commands testdoubleobj]] - && [llength [info commands teststringobj]] + [llength [info commands testobj]] && + [llength [info commands testdoubleobj]] && + [llength [info commands teststringobj]] }] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] +testConstraint longIs32bit [expr { ( int (0x80000000) ) < 0}] testConstraint testexprlongobj [llength [info commands testexprlongobj]] # Tests for the omnibus TclExecuteByteCode function: @@ -1053,9 +1051,7 @@ catch {rename foo ""} catch {rename p ""} catch {rename {} ""} catch {rename { } ""} -catch {unset x} -catch {unset y} -catch {unset msg} +unset -nocomplain x y msg ::tcltest::cleanupTests return diff --git a/tests/expr.test b/tests/expr.test index 6ad7208..7d340b4 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.1 namespace import -force ::tcltest::* } @@ -25,10 +25,10 @@ testConstraint testmathfunctions [expr { # Determine if "long int" type is a 32 bit number and if the wide # type is a 64 bit number on this machine. -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] +testConstraint longIs32bit [expr { ( int (0x80000000) ) < 0}] +testConstraint longIs64bit [expr { ( int (0x8000000000000000) ) < 0}] testConstraint wideIs64bit \ - [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] + [expr {( ( wide (0x80000000) ) > 0) && ( ( wide (0x8000000000000000) ) < 0)}] # Big test for correct ordering of data in [expr] @@ -103,32 +103,34 @@ proc hello_world {} { global a set a "" set L1 [set l0 [set h_1 [set q 0]]] - for {put_hello_char [expr [put_hello_char [expr [set h 7]*10+2]]+29]} {$l0?[put_hello_char $l0] - :!$h_1} {put_hello_char $ll;expr {$L1==2?[set ll [expr 32+0-0+[set bar 0]]]:0}} {expr {[incr L1]==[expr 1+([string length "abc"]-[string length "abc"])] - ?[set ll [set l0 [expr 54<<1]]]:$ll==108&&$L1<3? - [incr ll [expr 1|1<<1]; set ll $ll; set ll $ll; set ll $ll; set ll $ll; set l0 [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]; set l0; set l0 $l0; set l0; set l0]:$L1==4&&$ll==32?[set ll [expr 19+$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])+[set foo [expr ([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])+([string length "abc"]-[string length "abc"])]]]] - :[set q [expr $q-$h1+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]};expr {$L1==5?[incr ll -8; set ll $ll; set ll]:$q&&$h1&&1};expr {$L1==4+2 - ?[incr ll 3]:[expr ([string length "abc"]-[string length "abc"])+1]};expr {$ll==($h<<4)+2+0&&$L1!=6?[incr ll -6]:[set h1 [expr 100+([string length "abc"]-[string length "abc"])-([string length "abc"]-[string length "abc"])]]} - expr {$L1!=1<<3?[incr q [expr ([string length "abc"]-[string length "abc"])-1]]:[set h_1 [set ll $h1]]} + for {put_hello_char [expr {[put_hello_char [expr {([set h 7] * 10) + 2}]] + 29}]} {$l0 ? [put_hello_char $l0] : (!$h_1)} {put_hello_char $ll;expr {($L1 == 2) ? [set ll [expr {((32 + 0) - 0) + [set bar 0]}]] : 0}} { + expr {([incr L1] == [expr {1 + ([string length "abc"] - [string length "abc"])}]) + ? [set ll [set l0 [expr {54 << 1}]]] : (($ll == 108) && ($L1 < 3)) ? + [incr ll [expr {1 | (1 << 1)}]; set ll $ll; set ll $ll; set ll $ll; set ll $ll; set l0 [expr {((([string length "abc"] - [string length "abc"]) + ([string length "abc"] - [string length "abc"])) - ([string length "abc"] - [string length "abc"])) + ([string length "abc"] - [string length "abc"])}]; set l0; set l0 $l0; set l0; set l0] : (($L1 == 4) && ($ll == 32)) ? [set ll [expr {(((19 + $h1 + ([string length "abc"] - [string length "abc"])) - ([string length "abc"] - [string length "abc"])) + ([string length "abc"] - [string length "abc"])) - ([string length "abc"] - [string length "abc"]) + [set foo [expr {([string length "abc"] - [string length "abc"]) + ([string length "abc"] - [string length "abc"]) + ([string length "abc"] - [string length "abc"])}]]}]] + : [set q [expr {(($q - $h1) + ([string length "abc"] - [string length "abc"])) - ([string length "abc"] - [string length "abc"])}]]} + expr {($L1 == 5) ? [incr ll -8; set ll $ll; set ll] : ($q && $h1 && 1)} + expr {($L1 == (4 + 2)) ? [incr ll 3] : [expr {([string length "abc"] - [string length "abc"]) + 1}]} + expr {(($ll == (($h << 4) + 2 + 0)) && ($L1 != 6)) ? [incr ll -6] : [set h1 [expr {(100 + ([string length "abc"] - [string length "abc"])) - ([string length "abc"] - [string length "abc"])}]]} + expr {($L1 != (1 << 3)) ? [incr q [expr {([string length "abc"] - [string length "abc"]) - 1}]] : [set h_1 [set ll $h1]]} } set a } proc 12days {a b c} { global xxx - expr {1<$a?[expr {$a<3?[12days -79 -13 [string range $c [12days -87 \ - [expr 1-$b] [string range $c [12days -86 0 [string range $c 1 end]] \ - end]] end]]:1};expr {$a<$b?[12days [expr $a+1] $b $c]:3};expr {[12days \ - -94 [expr $a-27] $c]&&$a==2?$b<13?[12days 2 [expr $b+1] "%s %d %d\n"]:9 - :16}]:$a<0?$a<-72?[12days $b $a "@n'+,#'/*\{\}w+/w#cdnr/+,\{\}r/*de\}+,/*\{*+,/w\{%+,/w#q#n+,/#\{l+,/n\{n+,/+#n+,/#;#q#n+,/+k#;*+,/'r :'d*'3,\}\{w+K w'K:'+\}e#';dq#'l q#'+d'K#!/+k#;q#'r\}eKK#\}w'r\}eKK\{nl\]'/#;#q#n')\{)#\}w')\{)\{nl\]'/+#n';d\}rw' i;# )\{nl\]!/n\{n#'; r\{#w'r nc\{nl\]'/#\{l,+'K \{rw' iK\{;\[\{nl\]'/w#q#n'wk nw' iwk\{KK\{nl\]!/w\{%'l##w#' i; :\{nl\]'/*\{q#'ld;r'\}\{nlwb!/*de\}'c ;;\{nl'-\{\}rw\]'/+,\}##'*\}#nc,',#nw\]'/+kd'+e\}+;#'rdq#w! nr'/ ') \}+\}\{rl#'\{n' ')# \}'+\}##(!!/"] - :$a<-50?[string compare [format %c $b] [string index $c 0]]==0?[append \ + expr {(1 < $a) ? [expr {($a < 3) ? [12days -79 -13 [string range $c [12days -87 \ + [expr {1 - $b}] [string range $c [12days -86 0 [string range $c 1 end]] \ + end]] end]] : 1};expr {($a < $b) ? [12days [expr {$a + 1}] $b $c] : 3};expr {(([12days \ + -94 [expr {$a - 27}] $c]) && ($a == 2)) ? ($b < 13) ? [12days 2 [expr {$b + 1}] "%s %d %d\n"] : 9 + : 16}] : ($a < 0) ? ($a < -72) ? [12days $b $a "@n'+,#'/*\{\}w+/w#cdnr/+,\{\}r/*de\}+,/*\{*+,/w\{%+,/w#q#n+,/#\{l+,/n\{n+,/+#n+,/#;#q#n+,/+k#;*+,/'r :'d*'3,\}\{w+K w'K:'+\}e#';dq#'l q#'+d'K#!/+k#;q#'r\}eKK#\}w'r\}eKK\{nl\]'/#;#q#n')\{)#\}w')\{)\{nl\]'/+#n';d\}rw' i;# )\{nl\]!/n\{n#'; r\{#w'r nc\{nl\]'/#\{l,+'K \{rw' iK\{;\[\{nl\]'/w#q#n'wk nw' iwk\{KK\{nl\]!/w\{%'l##w#' i; :\{nl\]'/*\{q#'ld;r'\}\{nlwb!/*de\}'c ;;\{nl'-\{\}rw\]'/+,\}##'*\}#nc,',#nw\]'/+kd'+e\}+;#'rdq#w! nr'/ ') \}+\}\{rl#'\{n' ')# \}'+\}##(!!/"] + : ($a < -50) ? ([format %c $b] eq [string index $c 0]) ? [append \ xxx [string index $c 31];scan [string index $c 31] %c x;set x] - :[12days -65 $b [string range $c 1 end]]:[12days [expr ([string compare \ - [string index $c 0] "/"]==0)+$a] $b [string range $c 1 end]]:0<$a - ?[12days 2 2 "%s"]:[string compare [string index $c 0] "/"]==0|| + : [12days -65 $b [string range $c 1 end]] : [12days [expr {([string compare \ + [string index $c 0] "/"] == 0) + $a}] $b [string range $c 1 end]] : (0 < $a) + ? [12days 2 2 "%s"] : (([string compare [string index $c 0] "/"] == 0) || [12days 0 [12days -61 [scan [string index $c 0] %c x; set x] \ "!ek;dc i@bK'(q)-\[w\]*%n+r3#l,\{\}:\nuwloca-O;m .vpbks,fxntdCeghiry"] \ - [string range $c 1 end]]} + [string range $c 1 end]])} } proc do_twelve_days {} { global xxx @@ -141,7 +143,7 @@ proc do_twelve_days {} { # start of tests -catch {unset a b i x} +unset -nocomplain a b i x test expr-1.1 {TclCompileExprCmd: no expression} { list [catch {expr } msg] $msg @@ -573,13 +575,13 @@ test expr-14.12 {CompilePrimaryExpr: var reference primary} { list [expr {$i}] [expr $i] } {789 789} test expr-14.13 {CompilePrimaryExpr: var reference primary} { - catch {unset a} + unset -nocomplain a set a(foo) foo set a(bar) bar set a(123) 123 set result "" lappend result [expr $a(123)] [expr {$a(bar)<$a(foo)}] - catch {unset a} + unset -nocomplain a set result } {123 1} test expr-14.14 {CompilePrimaryExpr: var reference primary} { @@ -721,13 +723,12 @@ test expr-15.17 {ExprCallMathFunc: non-numeric arg} -constraints { expr T3(0,"a") } -returnCodes error -result {argument to math function didn't have numeric value} - test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} { - catch {unset a} + unset -nocomplain a set a(VALUE) ff15 set i 123 if {[expr 0x$a(VALUE)] & 16} { - set i {} + set i "" } set i } {} @@ -779,11 +780,7 @@ test expr-19.1 {expr and interpreter result object resetting} { # Test for incorrect "double evaluation" semantics test expr-20.1 {wrong brace matching} { - catch {unset l} - catch {unset r} - catch {unset q} - catch {unset cmd} - catch {unset a} + unset -nocomplain l r q cmd a set l "\{"; set r "\}"; set q "\"" set cmd "expr $l$q|$q == $q$r$q$r" list [catch $cmd a] $a @@ -812,7 +809,7 @@ test expr-20.3 {broken substitution of integer digits} { list [set a 000; expr 0x1$a] [set a 1; expr ${a}000] } {4096 1000} test expr-20.4 {proper double evaluation compilation, error case} { - catch {unset a}; # make sure $a doesn't exist + unset -nocomplain a; # make sure $a doesn't exist list [catch {expr 1?{$a}:0} msg] $msg } {1 {can't read "a": no such variable}} test expr-20.5 {proper double evaluation compilation, working case} { @@ -969,17 +966,17 @@ test expr-23.38 {INST_EXPON: big integer} {expr {10**19}} 1[string repeat 0 19] test expr-23.39 {INST_EXPON: big integer} { expr 1[string repeat 0 30]**2 } 1[string repeat 0 60] -test expr-23.40 {INST_EXPON: overflow to big integer} {expr {(-10)**3}} -1000 -test expr-23.41 {INST_EXPON: overflow to big integer} {expr 2**64} [expr 1<<64] -test expr-23.42 {INST_EXPON: overflow to big integer} {expr 4**32} [expr 1<<64] -test expr-23.43 {INST_EXPON: overflow to big integer} {expr 16**16} [expr 1<<64] -test expr-23.44 {INST_EXPON: overflow to big integer} {expr 256**8} [expr 1<<64] -test expr-23.45 {INST_EXPON: Bug 1555371} {expr 2**1} 2 +test expr-23.40 {INST_EXPON: overflow to big integer} {expr {(-10) ** 3}} -1000 +test expr-23.41 {INST_EXPON: overflow to big integer} {expr {2 ** 64}} [expr {1 << 64}] +test expr-23.42 {INST_EXPON: overflow to big integer} {expr {4 ** 32}} [expr {1 << 64}] +test expr-23.43 {INST_EXPON: overflow to big integer} {expr {16 ** 16}} [expr {1 << 64}] +test expr-23.44 {INST_EXPON: overflow to big integer} {expr {256 ** 8}} [expr {1 << 64}] +test expr-23.45 {INST_EXPON: Bug 1555371} {expr {2 ** 1}} 2 test expr-23.46 {INST_EXPON: Bug 1561260} -body { - expr 5**28 + expr {5 ** 28} } -match glob -result *5 test expr-23.47 {INST_EXPON: Bug 1561260} { - expr 2**32*5**32 + expr {(2 ** 32) * (5 ** 32)} } 1[string repeat 0 32] test expr-23.48 {INST_EXPON: TIP 274: right assoc} { expr 2**3**4 @@ -5684,7 +5681,7 @@ foreach s {yes true on} { test expr-31.$i.2 {boolean conversion} {expr bool("$s")} 1 test expr-31.$i.3 {boolean conversion} {expr bool(!"$s")} 0 set j 1 - while {$j < [string length $s]-1} { + while {$j < ([string length $s] - 1)} { test expr-31.$i.4.$j {boolean conversion} { expr bool([string range $s 0 $j]) } 1 @@ -5711,7 +5708,7 @@ foreach s {no false off} { test expr-31.$i.2 {boolean conversion} {expr bool("$s")} 0 test expr-31.$i.3 {boolean conversion} {expr bool(!"$s")} 1 set j 1 - while {$j < [string length $s]-1} { + while {$j < ([string length $s] - 1)} { test expr-31.$i.4.$j {boolean conversion} { expr bool([string range $s 0 $j]) } 0 @@ -5818,17 +5815,17 @@ test expr-32.2 {expr div basics} { ] test expr-32.3 {Bug 1585704} { - expr 1%(1<<63) + expr {1 % (1 << 63)} } 1 test expr-32.4 {Bug 1585704} { - expr -1%(1<<63) -} [expr (1<<63)-1] + expr {-1 % (1 << 63)} +} [expr {(1 << 63) - 1}] test expr-32.5 {Bug 1585704} { - expr (1<<32)%(1<<63) -} [expr 1<<32] + expr {(1 << 32) % (1 << 63)} +} [expr {1 << 32}] test expr-32.6 {Bug 1585704} { - expr -(1<<32)%(1<<63) -} [expr (1<<63)-(1<<32)] + expr {-(1 << 32) % (1 << 63)} +} [expr {(1 << 63) - (1 << 32)}] test expr-33.1 {parse largest long value} longIs32bit { set max_long_str 2147483647 @@ -5844,7 +5841,7 @@ test expr-33.1 {parse largest long value} longIs32bit { [expr {$max_long + 0}] \ [expr {2147483647 + 0}] \ [expr {$max_long == $max_long_hex}] \ - [expr {int(2147483647 + 1) < 0}] \ + [expr { int (2147483647 + 1) < 0}] \ } {2147483647 2147483647 2147483647 2147483647 1 1} test expr-33.2 {parse smallest long value} longIs32bit { @@ -5864,7 +5861,7 @@ test expr-33.2 {parse smallest long value} longIs32bit { [expr {$min_long + 0}] \ [expr {-2147483648 + 0}] \ [expr {$min_long == $min_long_hex}] \ - [expr {int(-2147483648 - 1) == 0x7FFFFFFF}] \ + [expr { int (-2147483648 - 1) == 0x7FFFFFFF}] \ } {-2147483648 -2147483648 -2147483648 -2147483648 1 1} test expr-33.3 {parse largest wide value} wideIs64bit { @@ -5881,7 +5878,7 @@ test expr-33.3 {parse largest wide value} wideIs64bit { [expr {$max_wide + 0}] \ [expr {9223372036854775807 + 0}] \ [expr {$max_wide == $max_wide_hex}] \ - [expr {wide(9223372036854775807 + 1) < 0}] \ + [expr { wide (9223372036854775807 + 1) < 0}] \ } {9223372036854775807 9223372036854775807 9223372036854775807 9223372036854775807 1 1} test expr-33.4 {parse smallest wide value} wideIs64bit { @@ -5901,7 +5898,7 @@ test expr-33.4 {parse smallest wide value} wideIs64bit { [expr {$min_wide + 0}] \ [expr {-9223372036854775808 + 0}] \ [expr {$min_wide == $min_wide_hex}] \ - [expr {wide(-9223372036854775808 - 1) == 0x7FFFFFFFFFFFFFFF}] \ + [expr { wide (-9223372036854775808 - 1) == 0x7FFFFFFFFFFFFFFF}] \ } {-9223372036854775808 -9223372036854775808 -9223372036854775808 -9223372036854775808 1 1} @@ -6814,48 +6811,48 @@ test expr-39.25 {Tcl_ExprDoubleObj and NaN} \ } {1 {domain error: argument not in valid range}} test expr-40.1 {large octal shift} { - expr 0o100000000000000000000000000000000 -} [expr 0x1000000000000000000000000] + expr {0o100000000000000000000000000000000} +} [expr {0x1000000000000000000000000}] test expr-40.2 {large octal shift} { - expr 0o100000000000000000000000000000001 -} [expr 0x1000000000000000000000001] + expr {0o100000000000000000000000000000001} +} [expr {0x1000000000000000000000001}] test expr-41.1 {exponent overflow} { - expr 1.0e2147483630 + expr {1.0e2147483630} } Inf test expr-41.2 {exponent underflow} { - expr 1.0e-2147483630 + expr {1.0e-2147483630} } 0.0 test expr-42.1 {denormals} ieeeFloatingPoint { - expr 7e-324 + expr {7e-324} } 5e-324 # TIP 114 test expr-43.1 {0b notation} { - expr 0b0 + expr {0b0} } 0 test expr-43.2 {0b notation} { - expr 0b1 + expr {0b1} } 1 test expr-43.3 {0b notation} { - expr 0b10 + expr {0b10} } 2 test expr-43.4 {0b notation} { - expr 0b11 + expr {0b11} } 3 test expr-43.5 {0b notation} { - expr 0b100 + expr {0b100} } 4 test expr-43.6 {0b notation} { - expr 0b101 + expr {0b101} } 5 test expr-43.7 {0b notation} { - expr 0b1000 + expr {0b1000} } 8 test expr-43.8 {0b notation} { - expr 0b1001 + expr {0b1001} } 9 test expr-43.9 {0b notation} { expr 0b1[string repeat 0 31] @@ -6874,31 +6871,31 @@ test expr-43.13 {0b notation} { } 18446744073709551617 test expr-44.1 {0o notation} { - expr 0o0 + expr {0o0} } 0 test expr-44.2 {0o notation} { - expr 0o1 + expr {0o1} } 1 test expr-44.3 {0o notation} { - expr 0o7 + expr {0o7} } 7 test expr-44.4 {0o notation} { - expr 0o10 + expr {0o10} } 8 test expr-44.5 {0o notation} { - expr 0o11 + expr {0o11} } 9 test expr-44.6 {0o notation} { - expr 0o100 + expr {0o100} } 64 test expr-44.7 {0o notation} { - expr 0o101 + expr {0o101} } 65 test expr-44.8 {0o notation} { - expr 0o1000 + expr {0o1000} } 512 test expr-44.9 {0o notation} { - expr 0o1001 + expr {0o1001} } 513 test expr-44.10 {0o notation} { expr 0o1[string repeat 7 21] @@ -6913,25 +6910,25 @@ test expr-44.12 {0o notation} { # TIP 237 again test expr-45.1 {entier} { - expr entier(0) + expr {entier(0)} } 0 test expr-45.2 {entier} { - expr entier(0.5) + expr {entier(0.5)} } 0 test expr-45.3 {entier} { - expr entier(1.0) + expr {entier(1.0)} } 1 test expr-45.4 {entier} { - expr entier(1.5) + expr {entier(1.5)} } 1 test expr-45.5 {entier} { - expr entier(2.0) + expr {entier(2.0)} } 2 test expr-45.6 {entier} { - expr entier(1e+22) + expr {entier(1e+22)} } 10000000000000000000000 test expr-45.7 {entier} { - list [catch {expr entier(Inf)} result] $result + list [catch {expr { entier (Inf)}} result] $result } {1 {integer value too large to represent}} test expr-45.8 {entier} ieeeFloatingPoint { list [catch {expr {entier($ieeeValues(NaN))}} result] $result @@ -6941,7 +6938,7 @@ test expr-45.9 {entier} ieeeFloatingPoint { } {1 {floating point value is Not a Number}} test expr-46.1 {round() rounds to +-infinity} { - expr round(0.5) + expr {round(0.5)} } 1 test expr-46.2 {round() rounds to +-infinity} { expr round(1.5) @@ -7021,7 +7018,7 @@ test expr-46.14 {round() boundary case - round up} { test expr-46.15 {round() boundary case - round up to wide} { expr {round(2147483647 + 0.50)} -} [expr {wide(2147483647) + 1}] +} [expr { ( wide (2147483647) ) + 1}] test expr-46.16 {round() boundary case - round up} { expr {round(-2147483648 + 0.51)} @@ -7032,7 +7029,7 @@ test expr-46.17 {round() boundary case - round down} { } -2147483648 test expr-46.18 {round() boundary case - round down to wide} { expr {round(-2147483648 - 0.50)} -} [expr {wide(-2147483648) - 1}] +} [expr { ( wide (-2147483648) ) - 1}] test expr-46.19 {round() handling of long/bignum boundary} { expr {round(double(0x7fffffffffffffff))} @@ -7171,7 +7168,7 @@ test expr-49.1 {Bug 2823282} { } 1 test expr-50.1 {test sqrt() of bignums with non-Inf answer} { - expr {sqrt("1[string repeat 0 616]") == 1e308} + expr { sqrt ("1[string repeat 0 616]") == 1e308} } 1 @@ -7180,8 +7177,7 @@ test expr-50.1 {test sqrt() of bignums with non-Inf answer} { if {[info exists a]} { unset a } -catch {unset min} -catch {unset max} +unset -nocomplain min max ::tcltest::cleanupTests return diff --git a/tests/fCmd.test b/tests/fCmd.test index 325b374..c93b121 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -53,20 +53,20 @@ if {[testConstraint unix]} { testConstraint foundGroup 1 } - proc dev dir { + proc dev {dir} { file stat $dir stat return $stat(dev) } - if {[catch {makeDirectory tcl[pid] /tmp} tmpspace] == 0} { - testConstraint xdev [expr {([dev .] != [dev $tmpspace])}] + if {[catch {::tcltest::makeDirectory tcl[pid] /tmp} tmpspace] == 0} { + ::tcltest::testConstraint xdev [expr {([dev .] != [dev $tmpspace])}] } } # Also used in winFCmd... if {[testConstraint win]} { set major [string index $tcl_platform(osVersion) 0] - if {[testConstraint nt] && $major > 4} { + if {[testConstraint nt] && ($major > 4)} { if {$major > 5} { testConstraint winVista 1 } elseif {$major == 5} { @@ -76,9 +76,9 @@ if {[testConstraint win]} { } testConstraint darwin9 [expr { - [testConstraint unix] - && $tcl_platform(os) eq "Darwin" - && [package vsatisfies 1.$tcl_platform(osVersion) 1.9] + [testConstraint unix] && + ($tcl_platform(os) eq "Darwin") && + [package vsatisfies 1.$tcl_platform(osVersion) 1.9] }] testConstraint notDarwin9 [expr {![testConstraint darwin9]}] @@ -95,7 +95,7 @@ if {[testConstraint unix]} { } if {$user eq ""} { catch { - regexp {^[^(]*\(([^)]*)\)} [exec id] -> user + regexp {^[^(]*\(([^)]*)\)} [exec id] ___ user } } if {$user eq ""} { @@ -117,10 +117,11 @@ proc createfile {file {string a}} { # if the file does not exist, or has a different content # proc checkcontent {file matchString} { + set fileString "" try { set f [open $file] - set fileString [read $f] - close $f + set fileString [chan read $f] + chan close $f } on error {} { return 0 } @@ -149,7 +150,7 @@ proc cleanup {args} { if { [catch {file delete -force -- $file}] && [testConstraint testchmod] - } then { + } { catch {openup $file} catch {file delete -force -- $file} } @@ -159,12 +160,11 @@ proc cleanup {args} { proc contents {file} { set f [open $file] - set r [read $f] - close $f + set r [chan read $f] + chan close $f return $r } - set root [lindex [file split [pwd]] 0] # A really long file name. @@ -2314,10 +2314,10 @@ test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} -setup { } -result {} if { - [testConstraint win] && - ([string index $tcl_platform(osVersion) 0] < 5 - || [lindex [file system [temporaryDirectory]] 1] ne "NTFS") -} then { + [testConstraint win] && + (([string index $tcl_platform(osVersion) 0] < 5) || + ([lindex [file system [temporaryDirectory]] 1] ne "NTFS")) +} { testConstraint linkDirectory 0 testConstraint linkFile 0 } @@ -2334,12 +2334,12 @@ test fCmd-28.3 {file link} -returnCodes error -body { test fCmd-28.4 {file link} -returnCodes error -body { file link -abc b c } -result {bad switch "-abc": must be -symbolic or -hard} -cd [workingDirectory] -makeDirectory abc.dir -makeDirectory abc2.dir -makeFile contents abc.file -makeFile contents abc2.file -cd [temporaryDirectory] +cd [::tcltest::workingDirectory] +::tcltest::makeDirectory abc.dir +::tcltest::makeDirectory abc2.dir +::tcltest::makeFile contents abc.file +::tcltest::makeFile contents abc2.file +cd [::tcltest::temporaryDirectory] test fCmd-28.5 {file link: source already exists} -setup { cd [temporaryDirectory] } -constraints {linkDirectory} -body { @@ -2388,9 +2388,9 @@ test fCmd-28.9.1 {file link: success with file} -setup { } -cleanup { cd [workingDirectory] } -result {1 0 abc.file 2} -cd [temporaryDirectory] +cd [::tcltest::temporaryDirectory] catch {file delete -force abc.link} -cd [workingDirectory] +cd [::tcltest::workingDirectory] test fCmd-28.10 {file link: linking to nonexistent path} -setup { cd [temporaryDirectory] file delete -force abc.link @@ -2481,7 +2481,7 @@ test fCmd-28.15.2 {file link: copies link not dir} -setup { } -cleanup { cd [workingDirectory] } -result {link abc.dir} -cd [temporaryDirectory] +cd [::tcltest::temporaryDirectory] file delete -force abc.link file delete -force abc2.link cd abc.dir @@ -2490,7 +2490,7 @@ file delete -force abc2.file cd .. file copy abc.file abc.dir file copy abc2.file abc.dir -cd [workingDirectory] +cd [::tcltest::workingDirectory] test fCmd-28.16 {file link: glob inside link} -setup { cd [temporaryDirectory] file delete -force abc.link @@ -2559,10 +2559,10 @@ try { } finally { cd [workingDirectory] } -removeFile abc2.file -removeFile abc.file -removeDirectory abc2.dir -removeDirectory abc.dir +::tcltest::removeFile abc2.file +::tcltest::removeFile abc.file +::tcltest::removeDirectory abc2.dir +::tcltest::removeDirectory abc.dir test fCmd-29.1 {weird memory corruption fault} -body { open [file join ~a_totally_bogus_user_id/foo bar] @@ -2592,8 +2592,8 @@ test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {win} -body { # cleanup cleanup -if {[testConstraint unix]} { - removeDirectory tcl[pid] /tmp +if {[::tcltest::testConstraint unix]} { + ::tcltest::removeDirectory tcl[pid] /tmp } ::tcltest::cleanupTests return diff --git a/tests/fileName.test b/tests/fileName.test index 51f00d1..e256815 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -23,8 +23,8 @@ testConstraint testtranslatefilename [llength [info commands testtranslatefilena testConstraint linkDirectory 1 testConstraint symbolicLinkFile 1 if {[testConstraint win]} { - if {[string index $tcl_platform(osVersion) 0] < 5 \ - || [lindex [file system [temporaryDirectory]] 1] ne "NTFS"} { + if {([string index $tcl_platform(osVersion) 0] < 5) || + ([lindex [file system [temporaryDirectory]] 1] ne "NTFS")} { testConstraint linkDirectory 0 } testConstraint symbolicLinkFile 0 @@ -38,7 +38,7 @@ customMatch compareWords {apply {{a b} { expr {$a eq "equal" ? $w1 eq $w2 : $w1 ne $w2} }}} -proc touch filename {catch {close [open $filename w]}} +proc touch {filename} {catch {chan close [open $filename w]}} global env if {[testConstraint testsetplatform]} { set platform [testgetplatform] @@ -915,7 +915,7 @@ test filename-11.21.1 {Tcl_GlobCmd} -body { # Get rid of file/dir if it exists, since it will have been left behind by a # previous failed run. if {[file exists $horribleglobname]} { - file delete -force $horribleglobname + file delete -force -- $horribleglobname } file rename globTest $horribleglobname set globname $horribleglobname @@ -1076,24 +1076,24 @@ test filename-11.49 {Tcl_GlobCmd} -returnCodes error -body { glob -types abcde -path foo -join * * } -result {bad argument to "-types": abcde} -file rename $horribleglobname globTest +file rename -- $horribleglobname globTest set globname globTest unset horribleglobname test filename-12.1 {simple globbing} {unixOrPc} { - glob {} + glob "" } {.} test filename-12.1.1 {simple globbing} -constraints {unixOrPc} -body { - glob -types f {} + glob -types f "" } -returnCodes error -result {no files matched glob pattern ""} test filename-12.1.2 {simple globbing} {unixOrPc} { - glob -types d {} + glob -types d "" } {.} test filename-12.1.3 {simple globbing} {unix} { - glob -types hidden {} + glob -types hidden "" } {.} test filename-12.1.4 {simple globbing} -constraints {win} -body { - glob -types hidden {} + glob -types hidden "" } -returnCodes error -result {no files matched glob pattern ""} test filename-12.1.5 {simple globbing} -constraints {win} -body { glob -types hidden c:/ @@ -1141,7 +1141,7 @@ test filename-12.10 {globbing with volume relative paths} -setup { test filename-13.1 {globbing with brace substitution} { glob globTest/\{\} -} "$globPreResult" +} $globPreResult test filename-13.2 {globbing with brace substitution} -body { glob globTest/\{ } -returnCodes error -result {unmatched open-brace in file name} @@ -1620,9 +1620,9 @@ catch {removeDirectory tcl[pid]} set env(HOME) $oldhome if {[testConstraint testsetplatform]} { testsetplatform $platform - catch {unset platform} + unset -nocomplain platform } -catch {unset oldhome temp result globPreResult} +unset -nocomplain oldhome temp result globPreResult ::tcltest::cleanupTests return diff --git a/tests/fileSystem.test b/tests/fileSystem.test index b098f35..e46e411 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -16,7 +16,7 @@ namespace eval ::tcl::test::fileSystem { catch { file delete -force link.file file delete -force dir.link - file delete -force [file join dir.dir linkinside.file] + file delete -force -- [file join dir.dir linkinside.file] } testConstraint loaddll 0 @@ -252,7 +252,7 @@ file delete -force dir2.file file delete -force dir2.link file delete -force link.file dir.link file delete -force dir2 -file delete -force [file join dir.dir dirinside.link] +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 diff --git a/tests/for-old.test b/tests/for-old.test index a11a791..6f1a76f 100644 --- a/tests/for-old.test +++ b/tests/for-old.test @@ -12,14 +12,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } # Check "for" and its use of continue and break. -catch {unset a i} +unset -nocomplain a i test for-old-1.1 {for tests} { set a {} for {set i 1} {$i<6} {set i [expr $i+1]} { diff --git a/tests/for.test b/tests/for.test index ff4dc0e..daad937 100644 --- a/tests/for.test +++ b/tests/for.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -24,7 +24,7 @@ test for-1.2 {TclCompileForCmd: error in initial command} -body { } -match glob -result {1 {wrong # args: should be "for start test next command"} {wrong # args: should be "for start test next command" while *ing "for {set}"}} -catch {unset i} +unset -nocomplain i test for-1.3 {TclCompileForCmd: missing test expression} { catch {for {set i 0}} msg set msg @@ -53,7 +53,7 @@ test for-1.8 {TclCompileForCmd: error compiling command body} -body { } -match glob -result {wrong # args: should be "set varName ?newValue?" while *ing "set"*} -catch {unset a} +unset -nocomplain a test for-1.9 {TclCompileForCmd: simple command body} { set a {} for {set i 1} {$i<6} {set i [expr $i+1]} { @@ -68,9 +68,7 @@ test for-1.10 {TclCompileForCmd: command body in quotes} { set a } {xxxxx} test for-1.11 {TclCompileForCmd: computed command body} { - catch {unset x1} - catch {unset bb} - catch {unset x2} + unset -nocomplain x1 bb x2 set x1 {append a x1; } set bb {break} set x2 {; append a x2} @@ -89,27 +87,27 @@ test for-1.13 {TclCompileForCmd: long command body} { for {set i 1} {$i<6} {set i [expr $i+1]} { if $i==4 break if $i>5 continue - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg @@ -168,27 +166,27 @@ test for-2.6 {continue tests, long command body} { if $i==2 continue if $i==4 break if $i>5 continue - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg @@ -244,28 +242,28 @@ test for-3.5 {break tests, long command body} { if $i==2 continue if $i==5 break if $i>5 continue - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } if $i==4 break - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg @@ -356,9 +354,7 @@ proc formatMail {} { set quote 0 } set breakrange {6.42 78.0} - set F1 [lindex $breakrange 0] - set F2 [lindex $breakrange 1] - set breakrange [lrange $breakrange 2 end] + set breakrange [lassign $breakrange F1 F2] if {[string length $F1] == 0} { set F1 -1 set break 0 @@ -382,7 +378,7 @@ proc formatMail {} { continue } } - if $inheaders { + if {$inheaders} { set limit 55 } else { set limit 55 @@ -390,18 +386,16 @@ proc formatMail {} { # Decide whether or not to break the body line if {$plen > 0} { - if {[string first {> } $line] == 0} { + if {[string first "> " $line] == 0} { # This is quoted text from previous message, don't reformat append result $line $NL - if {$quote && !$inheaders} { + if {$quote && (!$inheaders)} { # Fix from <sarr@umich.edu> to handle text/enriched - if {$L > $L1 && $L < $L2 && $line != {}} { + if {(($L > $L1) && ($L < $L2) && $line) ne ""} { # enriched requires two newlines for each one. append result $NL } elseif {$L > $L2} { - set L1 [lindex $ranges 0] - set L2 [lindex $ranges 1] - set ranges [lrange $ranges 2 end] + set ranges [lassign $ranges L1 L2] set quote [llength $L1] } } @@ -418,9 +412,7 @@ proc formatMail {} { continue } elseif {$L > $F2} { # Past formatted block - set F1 [lindex $breakrange 0] - set F2 [lindex $breakrange 1] - set breakrange [lrange $breakrange 2 end] + set breakrange [lassign $breakrange F1 F2] append result $line $NL if {[string length $F1] == 0} { set F1 -1 @@ -428,23 +420,23 @@ proc formatMail {} { continue } } - set climit [expr $limit-1] + set climit [expr {$limit - 1}] set cutoff 50 set continuation 0 while {[string length $line] > $limit} { - for {set c [expr $limit-1]} {$c >= $cutoff} {incr c -1} { + for {set c [expr {$limit - 1}]} {$c >= $cutoff} {incr c -1} { set char [string index $line $c] - if {$char == " " || $char == "\t"} { + if {($char eq " ") || ($char eq "\t")} { break } - if {$char == ">"} { ;# Hack for enriched formatting + if {$char eq ">"} { ;# Hack for enriched formatting break } } if {$c < $cutoff} { - if {! $inheaders} { - set c [expr $limit-1] + if {!$inheaders} { + set c [expr {$limit - 1}] } else { set c [string length $line] } @@ -468,14 +460,12 @@ proc formatMail {} { } } else { append result $line $NL - if {$quote && !$inheaders} { - if {$L > $L1 && $L < $L2 && $line != {}} { + if {$quote && (!$inheaders)} { + if {($L > $L1) && ($L < $L2) && ($line ne "")} { # enriched requires two newlines for each one. append result "" $NL } elseif {$L > $L2} { - set L1 [lindex $ranges 0] - set L2 [lindex $ranges 1] - set ranges [lrange $ranges 2 end] + set ranges [lassign $ranges L1 L2] set quote [llength $L1] } } @@ -594,10 +584,9 @@ test for-4.1 {break must reset the interp result} { test for-5.1 {possible delayed substitution of increment command} { # Increment should be 5, and lappend should always append $a - catch {unset a} - catch {unset i} + unset -nocomplain a i set a 5 - set i {} + set i [list] for {set a 1} {$a < 12} "incr a $a" {lappend i $a} set i } {1 6 11} @@ -607,7 +596,7 @@ test for-5.2 {possible delayed substitution of increment command} { catch {rename p ""} proc p {} { set a 5 - set i {} + set i [list] for {set a 1} {$a < 12} "incr a $a" {lappend i $a} set i } @@ -616,7 +605,7 @@ test for-5.2 {possible delayed substitution of increment command} { test for-5.3 {possible delayed substitution of body command} { # Increment should be $a, and lappend should always append 5 set a 5 - set i {} + set i "" for {set a 1} {$a < 12} {incr a $a} "lappend i $a" set i } {5 5 5 5} @@ -625,7 +614,7 @@ test for-5.4 {possible delayed substitution of body command} { catch {rename p ""} proc p {} { set a 5 - set i {} + set i [list] for {set a 1} {$a < 12} {incr a $a} "lappend i $a" set i } @@ -708,14 +697,12 @@ test for-6.11 {Tcl_ForObjCmd: command body in quotes} { } {xxxxx} test for-6.12 {Tcl_ForObjCmd: computed command body} { set z for - catch {unset x1} - catch {unset bb} - catch {unset x2} + unset -nocomplain x1 bb x2 set x1 {append a x1; } set bb {break} set x2 {; append a x2} - set a {} - $z {set i 1} {$i<6} {set i [expr $i+1]} $x1$bb$x2 + set a "" + $z {set i 1} {$i < 6} {set i [expr {$i + 1}]} $x1$bb$x2 set a } {x1} test for-6.13 {Tcl_ForObjCmd: error in "next" command} -body { @@ -734,27 +721,27 @@ test for-6.14 {Tcl_ForObjCmd: long command body} { $z {set i 1} {$i<6} {set i [expr $i+1]} { if $i==4 break if $i>5 continue - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg diff --git a/tests/foreach.test b/tests/foreach.test index 6c69b29..c91cc98 100644 --- a/tests/foreach.test +++ b/tests/foreach.test @@ -10,18 +10,17 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } -catch {unset a} -catch {unset x} +unset -nocomplain a x # Basic "foreach" operation. test foreach-1.1 {basic foreach tests} { - set a {} + set a "" foreach i {a b c d} { set a [concat $a $i] } @@ -67,9 +66,9 @@ test foreach-1.12 {foreach errors} { test foreach-1.13 {foreach errors} { list [catch {foreach a {{1 2}3} {}} msg] $msg } {1 {list element in braces followed by "3" instead of space}} -catch {unset a} +unset -nocomplain a test foreach-1.14 {foreach errors} { - catch {unset a} + unset -nocomplain a set a(0) 44 list [catch {foreach a {1 2 3} {}} msg o] $msg $::errorInfo } {1 {can't set "a": variable is array} {can't set "a": variable is array @@ -79,7 +78,7 @@ test foreach-1.14 {foreach errors} { test foreach-1.15 {foreach errors} { list [catch {foreach {} {} {}} msg] $msg } {1 {foreach varlist is empty}} -catch {unset a} +unset -nocomplain a test foreach-2.1 {parallel foreach tests} { set x {} @@ -148,7 +147,7 @@ test foreach-2.9 {foreach only supports local scalar variables} { } {1 2 3 4} test foreach-3.1 {compiled foreach backward jump works correctly} { - catch {unset x} + unset -nocomplain x proc foo {arrayName} { upvar 1 $arrayName a set l {} @@ -162,7 +161,7 @@ test foreach-3.1 {compiled foreach backward jump works correctly} { } [lsort {{0 zero} {1 one} {2 two} {3 three}}] test foreach-4.1 {noncompiled foreach and shared variable or value list objects that are converted to another type} { - catch {unset x} + unset -nocomplain x foreach {12.0} {a b c} { set x 12.0 set x [expr $x + 1] @@ -176,7 +175,7 @@ test foreach-5.1 {continue tests} {catch continue} 4 test foreach-5.2 {continue tests} { set a {} foreach i {a b c d} { - if {[string compare $i "b"] == 0} continue + if {$i eq "b"} continue set a [concat $a $i] } set a @@ -184,7 +183,7 @@ test foreach-5.2 {continue tests} { test foreach-5.3 {continue tests} { set a {} foreach i {a b c d} { - if {[string compare $i "b"] != 0} continue + if {$i ne "b"} continue set a [concat $a $i] } set a @@ -201,7 +200,7 @@ test foreach-6.1 {break tests} {catch break} 3 test foreach-6.2 {break tests} { set a {} foreach i {a b c d} { - if {[string compare $i "c"] == 0} break + if {$i eq "c"} break set a [concat $a $i] } set a @@ -276,8 +275,7 @@ test foreach-11.2 {error then dereference loop var (dev bug)} { } 1 # cleanup -catch {unset a} -catch {unset x} -catch {rename foo {}} +unset -nocomplain a x +catch {rename foo ""} ::tcltest::cleanupTests return diff --git a/tests/format.test b/tests/format.test index 27eac31..83c2ace 100644 --- a/tests/format.test +++ b/tests/format.test @@ -10,17 +10,17 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } # %u output depends on word length, so this test is not portable. -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] +testConstraint longIs32bit [expr { ( int (0x80000000) ) < 0}] +testConstraint longIs64bit [expr { ( int (0x8000000000000000) ) < 0}] testConstraint wideIs64bit \ - [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] -testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}] + [expr {( ( wide (0x80000000) ) > 0) && ( ( wide (0x8000000000000000) ) < 0)}] +testConstraint wideBiggerThanInt [expr { ( wide (0x80000000) ) != ( int (0x80000000) )}] test format-1.1 {integer formatting} { format "%*d %d %d %d" 6 34 16923 -12 -1 @@ -429,10 +429,7 @@ test format-12.1 {negative width specifiers} { } {25 } test format-13.1 {tcl_precision fuzzy comparison} { - catch {unset a} - catch {unset b} - catch {unset c} - catch {unset d} + unset -nocomplain a b c d set a 0.0000000000001 set b 0.00000000000001 set c 0.00000000000000001 @@ -440,10 +437,7 @@ test format-13.1 {tcl_precision fuzzy comparison} { format {%0.10f %0.12f %0.15f %0.17f} $d $d $d $d } {0.0000000000 0.000000000000 0.000000000000110 0.00000000000011001} test format-13.2 {tcl_precision fuzzy comparison} { - catch {unset a} - catch {unset b} - catch {unset c} - catch {unset d} + unset -nocomplain a b c d set a 0.000000000001 set b 0.000000000000005 set c 0.0000000000000008 @@ -451,27 +445,21 @@ test format-13.2 {tcl_precision fuzzy comparison} { format {%0.10f %0.12f %0.15f %0.17f} $d $d $d $d } {0.0000000000 0.000000000001 0.000000000001006 0.00000000000100580} test format-13.3 {tcl_precision fuzzy comparison} { - catch {unset a} - catch {unset b} - catch {unset c} + unset -nocomplain a b c set a 0.00000000000099 set b 0.000000000000011 set c [expr $a + $b] format {%0.10f %0.12f %0.15f %0.17f} $c $c $c $c } {0.0000000000 0.000000000001 0.000000000001001 0.00000000000100100} test format-13.4 {tcl_precision fuzzy comparison} { - catch {unset a} - catch {unset b} - catch {unset c} + unset -nocomplain a b c set a 0.444444444444 set b 0.33333333333333 set c [expr $a + $b] format {%0.10f %0.12f %0.15f %0.16f} $c $c $c $c } {0.7777777778 0.777777777777 0.777777777777330 0.7777777777773300} test format-13.5 {tcl_precision fuzzy comparison} { - catch {unset a} - catch {unset b} - catch {unset c} + unset -nocomplain a b c set a 0.444444444444 set b 0.99999999999999 set c [expr $a + $b] @@ -510,7 +498,7 @@ for {set i 0} {$i < 290} {incr i} { append b $a } for {set i 290} {$i < 400} {incr i} { - test format-16.[expr $i -289] {testing MAX_FLOAT_SIZE} { + test format-16.[expr {$i - 289}] {testing MAX_FLOAT_SIZE} { format {%s} $b } $b append b "x" @@ -569,10 +557,7 @@ test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body { } -match glob -result {value is a dict with *, string representation "*"} # cleanup -catch {unset a} -catch {unset b} -catch {unset c} -catch {unset d} +unset -nocomplain a b c d ::tcltest::cleanupTests return diff --git a/tests/get.test b/tests/get.test index d51ec6d..699be4b 100644 --- a/tests/get.test +++ b/tests/get.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -19,8 +19,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} { catch [list package require -exact Tcltest [info patchlevel]] testConstraint testgetint [llength [info commands testgetint]] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] +testConstraint longIs32bit [expr { ( int (0x80000000) ) < 0}] +testConstraint longIs64bit [expr { ( int (0x8000000000000000) ) < 0}] test get-1.1 {Tcl_GetInt procedure} testgetint { testgetint 44 { 22} diff --git a/tests/history.test b/tests/history.test index c562796..6c1c4c5 100644 --- a/tests/history.test +++ b/tests/history.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -129,7 +129,7 @@ test history-4.6 {change option} history { catch {history change Foo [expr {[history n]-4}]} } 1 if {[testConstraint history]} { - set num [expr {[history n]-4}] + set num [expr {[history n] - 4}] } test history-4.7 {change option} history { catch {history change Foo $num} msg @@ -149,11 +149,11 @@ test history-5.1 {info option} history {history info} [format {%6d set a {b %6d set b 1234 %6d set c {a b - c}} $num [expr $num+1] [expr $num+2]] + c}} $num [expr {$num + 1}] [expr {$num + 2}]] test history-5.2 {info option} history {history i 2} [format {%6d set b 1234 %6d set c {a b - c}} [expr $num+1] [expr $num+2]] + c}} [expr {$num + 1}] [expr {$num + 2}]] test history-5.3 {info option} history {catch {history i 2 3}} 1 test history-5.4 {info option} history { catch {history i 2 3} msg @@ -164,7 +164,7 @@ test history-5.5 {info option} history {history} [format {%6d set a {b %6d set b 1234 %6d set c {a b - c}} $num [expr $num+1] [expr $num+2]] + c}} $num [expr {$num + 1}] [expr {$num + 2}]] # "history keep" @@ -174,7 +174,7 @@ if {[testConstraint history]} { history add "foo3" history keep 2 } -test history-6.1 {keep option} history {history event [expr [history n]-1]} foo3 +test history-6.1 {keep option} history {history event [expr {[history n] - 1}]} foo3 test history-6.2 {keep option} history {history event -1} foo2 test history-6.3 {keep option} history {catch {history event -3}} 1 test history-6.4 {keep option} history { @@ -216,7 +216,7 @@ if {[testConstraint history]} { history add "Testing2" } test history-7.1 {nextid option} history {history event} "Testing" -test history-7.2 {nextid option} history {history next} [expr $num+2] +test history-7.2 {nextid option} history {history next} [expr {$num + 2}] test history-7.3 {nextid option} history {catch {history nextid garbage}} 1 test history-7.4 {nextid option} history { catch {history nextid garbage} msg diff --git a/tests/http.test b/tests/http.test index e2de7d8..cd64f6d 100644 --- a/tests/http.test +++ b/tests/http.test @@ -38,7 +38,7 @@ proc bgerror {args} { set port 8010 set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" -catch {unset data} +unset -nocomplain data # Ensure httpd file exists @@ -46,13 +46,13 @@ set origFile [file join [pwd] [file dirname [info script]] httpd] set httpdFile [file join [temporaryDirectory] httpd_[pid]] if {![file exists $httpdFile]} { makeFile "" $httpdFile - file delete $httpdFile - file copy $origFile $httpdFile + file delete -- $httpdFile + file copy -- $origFile $httpdFile set removeHttpd 1 } catch {package require Thread 2.7-} -if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { +if {(![catch {package present Thread}]) && [file exists $httpdFile]} { set httpthread [thread::create -preserved] thread::send $httpthread [list source $httpdFile] thread::send $httpthread [list set port $port] @@ -72,7 +72,7 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { unset port return } else { - set port [lindex [fconfigure $listen -sockname] 2] + set port [lindex [chan configure $listen -sockname] 2] } } @@ -246,12 +246,12 @@ test http-3.11 {http::geturl querychannel with -command} -setup { set testRes [list [http::status $t] [string length $query] [http::data $t]] # Now do async http::cleanup $t - close $fp + chan close $fp set fp [open $file] set t [http::geturl $posturl -querychannel $fp -command asyncCB] set postResult [list PostStart] http::wait $t - close $fp + chan close $fp lappend testRes [http::status $t] $postResult } -cleanup { removeFile outdata @@ -433,12 +433,12 @@ test http-4.4 {http::Event} -setup { } -body { set out [open $testfile w] set token [http::geturl $url -channel $out] - close $out + chan close $out set in [open $testfile] set x [read $in] } -cleanup { - catch {close $in} - catch {close $out} + catch {chan close $in} + catch {chan close $out} removeFile $testfile http::cleanup $token } -result "<html><head><title>HTTP/1.0 TEST</title></head><body> @@ -449,9 +449,9 @@ test http-4.5 {http::Event} -setup { set testfile [makeFile "" testfile] } -body { set out [open $testfile w] - fconfigure $out -translation lf + chan configure $out -translation lf set token [http::geturl $url -channel $out] - close $out + chan close $out upvar #0 $token data expr {$data(currentsize) == $data(totalsize)} } -cleanup { @@ -463,13 +463,13 @@ test http-4.6 {http::Event} -setup { } -body { set out [open $testfile w] set token [http::geturl $binurl -channel $out] - close $out + chan close $out set in [open $testfile] - fconfigure $in -translation binary + chan configure $in -translation binary read $in } -cleanup { - catch {close $in} - catch {close $out} + catch {chan close $in} + catch {chan close $out} removeFile $testfile http::cleanup $token } -result "$bindata[string trimleft $binurl /]" @@ -480,7 +480,7 @@ proc myProgress {token total current} { } set progress [list $total $current] } -if 0 { +if {0} { # This test hangs on Windows95 because the client never gets EOF set httpLog 1 test http-4.6.1 {http::Event} knownBug { @@ -624,14 +624,11 @@ test http-7.4 {http::formatQuery} -setup { } -result {%3F} # cleanup -catch {unset url} -catch {unset badurl} -catch {unset port} -catch {unset data} +unset -nocomplain url badurl port data if {[info exists httpthread]} { thread::release $httpthread } else { - close $listen + chan close $listen } if {[info exists removeHttpd]} { diff --git a/tests/http11.test b/tests/http11.test index 230ce5a..7e78c5b 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -17,21 +17,21 @@ variable httpd_output proc create_httpd {} { proc httpd_read {chan} { variable httpd_output - if {[gets $chan line] != -1} { + if {[chan gets $chan line] != -1} { #puts stderr "read '$line'" set httpd_output $line } - if {[eof $chan]} { - puts stderr "eof from httpd" - fileevent $chan readable {} - close $chan + if {[chan eof $chan]} { + chan puts stderr "eof from httpd" + chan event $chan readable "" + chan close $chan } } variable httpd_output set httpd_script [file join [pwd] [file dirname [info script]] httpd11.tcl] set httpd [open "|[list [interpreter] -encoding utf-8 $httpd_script]" r+] - fconfigure $httpd -buffering line -blocking 0 - fileevent $httpd readable [list httpd_read $httpd] + chan configure $httpd -buffering line -blocking 0 + chan event $httpd readable [list httpd_read $httpd] vwait httpd_output variable httpd_port [lindex $httpd_output 2] return $httpd diff --git a/tests/httpd b/tests/httpd index f810797..5546a4a 100644 --- a/tests/httpd +++ b/tests/httpd @@ -37,7 +37,7 @@ proc httpdAccept {newsock ipaddr port} { global httpd upvar #0 httpd$newsock data - fconfigure $newsock -blocking 0 -translation {auto crlf} + chan configure $newsock -blocking 0 -translation {auto crlf} httpd_log $newsock Connect $ipaddr $port set data(ipaddr) $ipaddr fileevent $newsock readable [list httpdRead $newsock] @@ -65,7 +65,7 @@ proc httpdRead { sock } { httpdSockDone $sock } return - } elseif {$data(state) == "mime"} { + } elseif {$data(state) eq "mime"} { # Read the HTTP headers @@ -74,7 +74,7 @@ proc httpdRead { sock } { lappend data(meta) $key [string trim $val] } - } elseif {$data(state) == "query"} { + } elseif {$data(state) eq "query"} { # Read the query data @@ -194,7 +194,7 @@ proc httpdRespond { sock } { append html "<h2>Query</h2>\n<dl>\n" foreach {key value} [split $data(query) &=] { append html "<dt>$key<dd>$value\n" - if {$key == "timeout"} { + if {$key eq "timeout"} { after $value ;# pause } } @@ -207,7 +207,7 @@ proc httpdRespond { sock } { # Catch errors from premature client closes catch { - if {$data(proto) == "HEAD"} { + if {$data(proto) eq "HEAD"} { puts $sock "HTTP/1.0 200 OK" } else { # Split the response to test for [Bug 26245326] @@ -226,8 +226,8 @@ proc httpdRespond { sock } { } puts $sock "" flush $sock - if {$data(proto) != "HEAD"} { - fconfigure $sock -translation binary + if {$data(proto) ne "HEAD"} { + chan configure $sock -translation binary puts -nonewline $sock $html } } diff --git a/tests/httpd11.tcl b/tests/httpd11.tcl index 9c543dc..64601a9 100644 --- a/tests/httpd11.tcl +++ b/tests/httpd11.tcl @@ -38,11 +38,12 @@ proc make-chunk-generator {data {size 4096}} { return $name } -proc get-chunks {data {compression gzip}} { +proc get-chunks {a_data {compression gzip}} { switch -exact -- $compression { - gzip { set data [zlib gzip $data] } - deflate { set data [zlib deflate $data] } - compress { set data [zlib compress $data] } + gzip { set data [zlib gzip $a_data] } + deflate { set data [zlib deflate $a_data] } + compress { set data [zlib compress $a_data] } + default { set data [zlib gzip $a_data] } } set data "" @@ -53,11 +54,12 @@ proc get-chunks {data {compression gzip}} { return $data } -proc blow-chunks {data {ochan stdout} {compression gzip}} { +proc blow-chunks {a_data {ochan stdout} {compression gzip}} { switch -exact -- $compression { - gzip { set data [zlib gzip $data] } - deflate { set data [zlib deflate $data] } - compress { set data [zlib compress $data] } + gzip { set data [zlib gzip $a_data] } + deflate { set data [zlib deflate $a_data] } + compress { set data [zlib compress $a_data] } + default { set data [zlib gzip $a_data] } } set chunker [make-chunk-generator $data 512] @@ -78,31 +80,42 @@ proc mime-type {filename} { .xhtml {return {text application/xml+html} } .svg { return {text image/svg+xml} } .txt - .tcl - .c - .h { return {text text/plain}} + default {return {binary text/plain}} } - return {binary text/plain} } -proc Puts {chan s} {puts $chan $s; puts $s} +proc Puts {chan s} { + puts $chan $s + puts $s +} proc Service {chan addr port} { chan event $chan readable [info coroutine] while {1} { - set meta {} + set meta [list] chan configure $chan -buffering line -encoding iso8859-1 -translation crlf chan configure $chan -blocking 0 yield - while {[gets $chan line] < 0} { - if {[eof $chan]} {chan event $chan readable {}; close $chan; return} + while {[chan gets $chan line] < 0} { + if {[chan eof $chan]} { + chan event $chan readable {} + chan close $chan + return + } yield } - if {[eof $chan]} {chan event $chan readable {}; close $chan; return} - foreach {req url protocol} {GET {} HTTP/1.1} break - regexp {^(\S+)\s+(.*)\s(\S+)?$} $line -> req url protocol - - puts $line - while {[gets $chan line] > 0} { - if {[regexp {^([^:]+):(.*)$} $line -> key val]} { - puts [list $key [string trim $val]] + if {[eof $chan]} { + chan event $chan readable {} + chan close $chan + return + } + lassign {GET {} HTTP/1.1} req url protocol + regexp {^(\S+)\s+(.*)\s(\S+)?$} $line ___ req url protocol + + chan puts $line + while {[chan gets $chan line] > 0} { + if {[regexp {^([^:]+):(.*)$} $line ___ key val]} { + chan puts [list $key [string trim $val]] lappend meta [string tolower $key] [string trim $val] } yield @@ -129,7 +142,7 @@ proc Service {chan addr port} { if {[string is integer -strict $qlen]} { chan configure $chan -buffering none -translation binary while {[string length $query] < $qlen} { - append query [read $chan $qlen] + append query [chan read $chan $qlen] if {[string length $query] < $qlen} {yield} } # Check for excess query bytes [Bug 2715421] @@ -148,11 +161,11 @@ proc Service {chan addr port} { set path [string trimleft $path /] set path [file join [pwd] $path] if {[file exists $path] && [file isfile $path]} { - foreach {what type} [mime-type $path] break + lassign [mime-type $path] what type set f [open $path r] if {$what eq "binary"} {chan configure $f -translation binary} - set data [read $f] - close $f + set data [chan read $f] + chan close $f set code "200 OK" set close [expr {[dict get? $meta connection] eq "close"}] } @@ -173,9 +186,13 @@ proc Service {chan addr port} { foreach pair [split $query &] { if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""} switch -exact -- $key { - close {set close 1 ; set transfer 0} + close { + set close 1 + set transfer 0 + } transfer {set transfer $val} content-type {set type $val} + default {} } } @@ -197,27 +214,27 @@ proc Service {chan addr port} { if {$transfer eq "chunked"} { Puts $chan "transfer-encoding: chunked" } - puts $chan "" - flush $chan + chan puts $chan "" + chan flush $chan chan configure $chan -buffering full -translation binary if {$transfer eq "chunked"} { blow-chunks $data $chan $encoding } elseif {$encoding ne "identity"} { - puts -nonewline $chan [zlib $encoding $data] + chan puts -nonewline $chan [zlib $encoding $data] } else { - puts -nonewline $chan $data + chan puts -nonewline $chan $data } if {$close} { chan event $chan readable {} - close $chan - puts "close $chan" + chan close $chan + chan puts "close $chan" return } else { - flush $chan + chan flush $chan } - puts "pipeline $chan" + chan puts "pipeline $chan" } } diff --git a/tests/httpold.test b/tests/httpold.test index aeba311..1b40133 100644 --- a/tests/httpold.test +++ b/tests/httpold.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -34,7 +34,7 @@ if {[catch {package require http 1.0}]} { } set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" -catch {unset data} +unset -nocomplain data ## ## The httpd script implement a stub http server @@ -42,7 +42,7 @@ catch {unset data} source [file join [file dirname [info script]] httpd] set port 8010 -if [catch {httpd_init $port} listen] { +if {[catch {httpd_init $port} listen]} { puts "Cannot start http server, http test skipped" unset port ::tcltest::cleanupTests @@ -156,7 +156,6 @@ test httpold-3.9 {http_get} { http_code $token } "HTTP/1.0 200 OK" - test httpold-4.1 {httpEvent} { set token [http_get $url] upvar #0 $token data @@ -207,7 +206,7 @@ test httpold-4.6 {httpEvent} { set token [http_get $binurl -channel $out] close $out set in [open $testfile] - fconfigure $in -translation binary + chan configure $in -translation binary set x [read $in] close $in removeFile $testfile @@ -221,7 +220,7 @@ proc myProgress {token total current} { } set progress [list $total $current] } -if 0 { +if {0} { # This test hangs on Windows95 because the client never gets EOF set httpLog 1 test httpold-4.6 {httpEvent} { @@ -285,9 +284,7 @@ test httpold-6.1 {httpProxyRequired} { </body></html>" # cleanup -catch {unset url} -catch {unset port} -catch {unset data} -close $listen +unset -nocomplain url port data +chan close $listen ::tcltest::cleanupTests return diff --git a/tests/if-old.test b/tests/if-old.test index fbcf56c..e08ec45 100644 --- a/tests/if-old.test +++ b/tests/if-old.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -60,12 +60,11 @@ test if-old-1.8 {taking proper branch} { } {4} test if-old-1.9 {taking proper branch, multiline test expr} { set a {} - if {($tcl_platform(platform) != "foobar1") && \ - ($tcl_platform(platform) != "foobar2")} {set a 3} else {set a 4} + if {($tcl_platform(platform) ne "foobar1") && + ($tcl_platform(platform) ne "foobar2")} {set a 3} else {set a 4} set a } {3} - test if-old-2.1 {optional then-else args} { set a 44 if 0 then {set a 1} elseif 0 then {set a 3} else {set a 2} diff --git a/tests/if.test b/tests/if.test index 040364a..9ef5c72 100644 --- a/tests/if.test +++ b/tests/if.test @@ -10,14 +10,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } # Basic "if" operation. -catch {unset a} +unset -nocomplain a test if-1.1 {TclCompileIfCmd: missing if/elseif test} -body { if } -returnCodes error -result {wrong # args: no expression after "if" argument} @@ -46,8 +46,8 @@ test if-1.5 {TclCompileIfCmd: if/elseif test not in braces} -body { test if-1.6 {TclCompileIfCmd: multiline test expr} -setup { set a {} } -body { - if {($tcl_platform(platform) != "foobar1") && \ - ($tcl_platform(platform) != "foobar2")} {set a 3} else {set a 4} + if {($tcl_platform(platform) ne "foobar1") && + ($tcl_platform(platform) ne "foobar2")} {set a 3} else {set a 4} return $a } -cleanup { unset a @@ -75,7 +75,7 @@ test if-1.9 {TclCompileIfCmd: missing "then" body} -setup { } -returnCodes error -result {wrong # args: no script following "then" argument} test if-1.10 {TclCompileIfCmd: error in "then" body} -body { set a {} - list [catch {if {$a!="xxx"} then {set}} msg] $msg $::errorInfo + list [catch {if {$a ne "xxx"} then {set}} msg] $msg $::errorInfo } -match glob -cleanup { unset a msg } -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" @@ -92,8 +92,7 @@ test if-1.12 {TclCompileIfCmd: "then" body in quotes} -body { unset a } -result {x} test if-1.13 {TclCompileIfCmd: computed "then" body} -setup { - catch {unset x1} - catch {unset x2} + unset -nocomplain x1 x2 } -body { set x1 {append a x1} set x2 {; append a x2} @@ -104,7 +103,7 @@ test if-1.13 {TclCompileIfCmd: computed "then" body} -setup { unset a x1 x2 } -result {x1x2} test if-1.14 {TclCompileIfCmd: taking proper branch} -body { - set a {} + set a "" if 1<2 {set a 1} return $a } -cleanup { @@ -118,12 +117,12 @@ test if-1.15 {TclCompileIfCmd: taking proper branch} -body { unset a } -result {} test if-1.16 {TclCompileIfCmd: test jumpFalse instruction replacement after long "then" body} -setup { - catch {unset i} - set a {} + unset -nocomplain i + set a "" } -body { if 1<2 { set a 1 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -142,11 +141,11 @@ test if-1.16 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 2 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -165,7 +164,7 @@ test if-1.16 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 3 @@ -215,12 +214,12 @@ test if-2.4 {TclCompileIfCmd: error in expression after "elseif"} -setup { unset a msg } -result {1 * {*"if 3>4 {set a 1} elseif {1>}"}} test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long "elseif" body} -setup { - catch {unset i} + unset -nocomplain i set a {} } -body { if 1>2 { set a 1 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -239,11 +238,11 @@ test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 2 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -262,13 +261,13 @@ test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 3 } elseif 1<2 then { #; this if arm should be taken set a 4 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -287,11 +286,11 @@ test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 5 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -310,7 +309,7 @@ test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 6 @@ -323,7 +322,7 @@ test if-2.5 {TclCompileIfCmd: test jumpFalse instruction replacement after long test if-3.1 {TclCompileIfCmd: "else" clause} -body { set a {} - if 3>4 {set a 1} elseif {$a == "foo"} {set a 2} else {set a 3} + if 3>4 {set a 1} elseif {$a eq "foo"} {set a 2} else {set a 3} return $a } -cleanup { unset a @@ -365,12 +364,12 @@ test if-3.5 {TclCompileIfCmd: extra arguments after "else" argument} -setup { # commands are properly relocated because a short jump must be replaced # by a "long distance" one. test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long "else" clause} -setup { - catch {unset i} - set a {} + unset -nocomplain i + set a "" } -body { if 1>2 { set a 1 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -389,11 +388,11 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 2 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -412,13 +411,13 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 3 } elseif 1==2 then { #; this if arm should be taken set a 4 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -437,11 +436,11 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 5 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -460,13 +459,13 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 6 } else { set a 7 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -485,11 +484,11 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 8 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { if {[string compare $a "bar"] < 0} { @@ -508,7 +507,7 @@ test if-3.6 {TclCompileIfCmd: test jumpFalse instruction replacement after long set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 9 @@ -600,8 +599,8 @@ test if-5.5 {if cmd with computed command names: if/elseif test not in braces} - } -result {1} test if-5.6 {if cmd with computed command names: multiline test expr} -body { set z if - $z {($tcl_platform(platform) != "foobar1") && \ - ($tcl_platform(platform) != "foobar2")} {set a 3} else {set a 4} + $z {($tcl_platform(platform) ne "foobar1") && + ($tcl_platform(platform) ne "foobar2")} {set a 3} else {set a 4} return $a } -cleanup { unset a z @@ -634,14 +633,14 @@ test if-5.9 {if cmd with computed command names: missing "then" body} -setup { test if-5.10 {if cmd with computed command names: error in "then" body} -body { set z if set a {} - list [catch {$z {$a!="xxx"} then {set}} msg] $msg $::errorInfo + list [catch {$z {$a ne "xxx"} then {set}} msg] $msg $::errorInfo } -match glob -cleanup { unset a z msg } -result {1 {wrong # args: should be "set varName ?newValue?"} {wrong # args: should be "set varName ?newValue?" while *ing "set" invoked from within -"$z {$a!="xxx"} then {set}"}} +"$z {$a ne "xxx"} then {set}"}} test if-5.11 {if cmd with computed command names: error in "then" body} -body { set z if $z 2 then {[error "error in then clause"]} @@ -658,8 +657,7 @@ test if-5.12 {if cmd with computed command names: "then" body in quotes} -setup unset a z } -result {x} test if-5.13 {if cmd with computed command names: computed "then" body} -setup { - catch {unset x1} - catch {unset x2} + unset -nocomplain x1 x2 } -body { set z if set x1 {append a x1} @@ -688,13 +686,13 @@ test if-5.15 {if cmd with computed command names: taking proper branch} -body { unset a z } -result {} test if-5.16 {if cmd with computed command names: test jumpFalse instruction replacement after long "then" body} -setup { - catch {unset i} + unset -nocomplain i set a {} } -body { set z if $z 1<2 { set a 1 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -713,11 +711,11 @@ test if-5.16 {if cmd with computed command names: test jumpFalse instruction rep set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 2 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -736,7 +734,7 @@ test if-5.16 {if cmd with computed command names: test jumpFalse instruction rep set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 3 @@ -791,13 +789,13 @@ test if-6.4 {if cmd with computed command names: error in expression after "else unset a z } -result {1 {*"$z 3>4 {set a 1} elseif {1>}"}} test if-6.5 {if cmd with computed command names: test jumpFalse instruction replacement after long "elseif" body} -setup { - catch {unset i} + unset -nocomplain i set a {} } -body { set z if $z 1>2 { set a 1 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -816,11 +814,11 @@ test if-6.5 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 2 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -839,13 +837,13 @@ test if-6.5 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 3 } elseif 1<2 then { #; this if arm should be taken set a 4 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -864,11 +862,11 @@ test if-6.5 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 5 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -887,7 +885,7 @@ test if-6.5 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 6 @@ -902,7 +900,7 @@ test if-7.1 {if cmd with computed command names: "else" clause} -setup { set a {} } -body { set z if - $z 3>4 {set a 1} elseif {$a == "foo"} {set a 2} else {set a 3} + $z 3>4 {set a 1} elseif {$a eq "foo"} {set a 2} else {set a 3} return $a } -cleanup { unset a z @@ -950,13 +948,13 @@ test if-7.5 {if cmd with computed command names: extra arguments after "else" ar # commands are properly relocated because a short jump must be replaced # by a "long distance" one. test if-7.6 {if cmd with computed command names: test jumpFalse instruction replacement after long "else" clause} -setup { - catch {unset i} + unset -nocomplain i set a {} } -body { set z if $z 1>2 { set a 1 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -975,11 +973,11 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 2 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -998,13 +996,13 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 3 } elseif 1==2 then { #; this if arm should be taken set a 4 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -1023,11 +1021,11 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 5 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -1046,13 +1044,13 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 6 } else { set a 7 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -1071,11 +1069,11 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 8 - while {$a != "xxx"} { + while {$a ne "xxx"} { break; while {$i >= 0} { $z {[string compare $a "bar"] < 0} { @@ -1094,7 +1092,7 @@ test if-7.6 {if cmd with computed command names: test jumpFalse instruction repl set i $i set i [lindex $s $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } } set a 9 diff --git a/tests/incr-old.test b/tests/incr-old.test index ed457cf..d965a1b 100644 --- a/tests/incr-old.test +++ b/tests/incr-old.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. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } -catch {unset x} +unset -nocomplain x test incr-old-1.1 {basic incr operation} { set x 23 @@ -44,7 +44,7 @@ test incr-old-2.2 {incr errors} { list [catch {incr a b c} msg] $msg } {1 {wrong # args: should be "incr varName ?increment?"}} test incr-old-2.3 {incr errors} { - catch {unset x} + unset -nocomplain x incr x } 1 test incr-old-2.4 {incr errors} { @@ -69,7 +69,7 @@ test incr-old-2.6 {incr errors} -body { while executing * "incr x 1"}} -catch {unset x} +unset -nocomplain x test incr-old-2.7 {incr errors} { set x - list [catch {incr x 1} msg] $msg diff --git a/tests/incr.test b/tests/incr.test index 9243be0..02b9338 100644 --- a/tests/incr.test +++ b/tests/incr.test @@ -16,7 +16,7 @@ if {"::tcltest" ni [namespace children]} { } unset -nocomplain x i -proc readonly varName { +proc readonly {varName} { upvar 1 $varName var trace add variable var write \ {apply {{args} {error "variable is read-only"}}} @@ -230,7 +230,7 @@ test incr-1.29 {TclCompileIncrCmd: runtime error, bad variable value} -body { incr x 1 } -returnCodes error -result {expected integer but got " - "} test incr-1.30 {TclCompileIncrCmd: array var, braced (no subs)} -setup { - catch {unset array} + unset -nocomplain array } -body { set array(\$foo) 4 incr {array($foo)} diff --git a/tests/indexObj.test b/tests/indexObj.test index 646cb02..67b6ffb 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -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. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/info.test b/tests/info.test index ebc853a..e6d737b 100644 --- a/tests/info.test +++ b/tests/info.test @@ -88,7 +88,7 @@ test info-2.4 {info body option} { # would then try and eval out of the foo context, accessing # compiled local indices test info-2.5 {info body option, returning bytecompiled bodies} -body { - catch {unset args} + unset -nocomplain args proc foo {args} { foreach v $args { upvar $v var @@ -111,7 +111,7 @@ proc testinfocmdcount {} { set x [info cmdcount] set y 12345 set z [info cm] - expr {$z-$x} + expr {$z - $x} } test info-3.1 {info cmdcount compiled} { testinfocmdcount @@ -136,9 +136,8 @@ test info-4.1 {info commands option} -body { } -cleanup {unset x} -result {1 1 1 1} test info-4.2 {info commands option} -body { proc t1 {} {} - rename t1 {} - string match {* t1 *} \ - [info comm] + rename t1 "" + string match "* t1 *" [info comm] } -result 0 test info-4.3 {info commands option} { proc _t1_ {} {} @@ -148,10 +147,10 @@ test info-4.3 {info commands option} { test info-4.4 {info commands option} { proc _t1_ {} {} proc _t2_ {} {} - lsort [info commands _t*] + lsort [info commands "_t*"] } {_t1_ _t2_} -catch {rename _t1_ {}} -catch {rename _t2_ {}} +catch {rename _t1_ ""} +catch {rename _t2_ ""} test info-4.5 {info commands option} -returnCodes error -body { info commands a b } -result {wrong # args: should be "info commands ?pattern?"} @@ -213,14 +212,14 @@ test info-6.8 {info default option} -returnCodes error -body { info default t1 x value } -result {procedure "t1" doesn't have an argument "x"} test info-6.9 {info default option} -returnCodes error -setup { - catch {unset a} + unset -nocomplain a } -cleanup {unset a} -body { set a(0) 88 proc t1 {a b} {} info default t1 a a } -returnCodes error -result {can't set "a": variable is array} test info-6.10 {info default option} -setup { - catch {unset a} + unset -nocomplain a } -cleanup {unset a} -body { set a(0) 88 proc t1 {{a 18} b} {} @@ -239,7 +238,7 @@ test info-7.1 {info exists option} -body { info exists value } -cleanup {unset value} -result 1 -test info-7.2 {info exists option} -setup {catch {unset _nonexistent_}} -body { +test info-7.2 {info exists option} -setup {unset -nocomplain _nonexistent_} -body { info exists _nonexistent_ } -result 0 test info-7.3 {info exists option} { @@ -265,12 +264,12 @@ test info-7.6 {info exists option} { t1 2 } 0 test info-7.7 {info exists option} -setup { - catch {unset x} + unset -nocomplain x } -body { set x(2) 44 list [info exists x] [info exists x(1)] [info exists x(2)] } -result {1 0 1} -catch {unset x} +unset -nocomplain x test info-7.8 {info exists option} -body { info exists } -returnCodes error -result {wrong # args: should be "info exists varName"} @@ -394,7 +393,8 @@ test info-10.3 {info library option} -body { unset tcl_library info library } -returnCodes error -result {no library has been specified for Tcl} -set tcl_library $savedLibrary; unset savedLibrary +set tcl_library $savedLibrary +unset savedLibrary test info-11.1 {info loaded option} -body { info loaded a b @@ -592,7 +592,8 @@ set gorpfile [makeFile {list [info script] [info script foo.bar]} gorp.info] test info-16.8 {info script option} { list [source $gorpfile] [file tail [info script]] } [list [list $gorpfile foo.bar] info.test] -removeFile gorp.info; unset gorpfile +removeFile gorp.info +unset gorpfile test info-17.1 {info sharedlibextension option} -returnCodes error -body { info sharedlibextension foo @@ -712,8 +713,9 @@ proc reduce {frame} { } return $frame } - -proc subinterp {} { interp create sub ; interp debug sub -frame 1; +proc subinterp {} { + interp create sub + interp debug sub -frame 1 interp eval sub [list proc reduce [info args reduce] [info body reduce]] } @@ -748,23 +750,23 @@ test info-22.2 {info frame, bad level absolute} {!singleTestInterp} { } {bad level "9"} test info-22.3 {info frame, current, relative} -match glob -body { info frame 0 -} -result {type source line 750 file */info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -result {type source line 753 file */info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-22.4 {info frame, current, relative, nested} -match glob -body { set res [info frame 0] -} -result {type source line 753 file */info.test cmd {info frame 0} proc ::tcltest::RunTest} -cleanup {unset res} +} -result {type source line 756 file */info.test cmd {info frame 0} proc ::tcltest::RunTest} -cleanup {unset res} test info-22.5 {info frame, current, absolute} -constraints {!singleTestInterp} -match glob -body { reduce [info frame 7] -} -result {type source line 756 file info.test cmd {info frame 7} proc ::tcltest::RunTest} +} -result {type source line 759 file info.test cmd {info frame 7} proc ::tcltest::RunTest} test info-22.6 {info frame, global, relative} {!singleTestInterp} { reduce [info frame -6] -} {type source line 758 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relative\}\ \{!singleTestInter level 0} +} {type source line 761 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relative\}\ \{!singleTestInter level 0} test info-22.7 {info frame, global, absolute} {!singleTestInterp} { reduce [info frame 1] -} {type source line 761 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0} +} {type source line 764 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolute\}\ \{!singleTestInter level 0} test info-22.8 {info frame, basic trace} -match glob -body { join [lrange [etrace] 0 2] \n -} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} -* {type source line 765 file info.test cmd etrace proc ::tcltest::RunTest} +} -result {* {type source line 733 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 768 file info.test cmd etrace proc ::tcltest::RunTest} * {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}} unset -nocomplain msg @@ -792,7 +794,7 @@ test info-23.3 {eval'd info frame, literal} -match glob -body { eval { info frame 0 } -} -result {type source line 793 file * cmd {info frame 0} proc ::tcltest::RunTest} +} -result {type source line 796 file * cmd {info frame 0} proc ::tcltest::RunTest} test info-23.4 {eval'd info frame, semi-dynamic} { eval info frame 0 } {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest} @@ -803,9 +805,9 @@ test info-23.5 {eval'd info frame, dynamic} -cleanup {unset script} -body { test info-23.6 {eval'd info frame, trace} -match glob -cleanup {unset script} -body { set script {etrace} join [lrange [eval $script] 0 2] \n -} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 733 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 1 cmd etrace proc ::tcltest::RunTest} -* {type source line 805 file info.test cmd {eval $script} proc ::tcltest::RunTest}} +* {type source line 808 file info.test cmd {eval $script} proc ::tcltest::RunTest}} # ------------------------------------------------------------------------- @@ -829,7 +831,7 @@ test info-24.0 {info frame, interaction, namespace eval} -body { reduce [foo::bar] } -cleanup { namespace delete foo -} -result {type source line 825 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 828 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -843,7 +845,7 @@ test info-24.1 {info frame, interaction, if} -body { reduce [foo::bar] } -cleanup { namespace delete foo -} -result {type source line 839 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 842 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -852,13 +854,14 @@ while {$flag} { namespace eval foo {} proc ::foo::bar {} {info frame 0} set flag 0 -};unset flag +} +unset flag test info-24.2 {info frame, interaction, while} -body { reduce [foo::bar] } -cleanup { namespace delete foo -} -result {type source line 853 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 856 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -871,7 +874,7 @@ test info-24.3 {info frame, interaction, catch} -body { reduce [foo::bar] } -cleanup { namespace delete foo -} -result {type source line 867 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 871 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -879,13 +882,14 @@ foreach var val { namespace eval foo {} proc ::foo::bar {} {info frame 0} break -}; unset var +} +unset var test info-24.4 {info frame, interaction, foreach} -body { reduce [foo::bar] } -cleanup { namespace delete foo -} -result {type source line 880 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 884 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -899,7 +903,7 @@ test info-24.5 {info frame, interaction, for} -body { reduce [foo::bar] } -cleanup { namespace delete foo -} -result {type source line 894 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 899 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -909,6 +913,7 @@ switch -exact -- $x { foo { proc ::foo::bar {} {info frame 0} } + default {} } test info-24.6.0 {info frame, interaction, switch, list body} -body { @@ -916,7 +921,7 @@ test info-24.6.0 {info frame, interaction, switch, list body} -body { } -cleanup { namespace delete foo unset x -} -result {type source line 910 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 915 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -931,7 +936,7 @@ test info-24.6.1 {info frame, interaction, switch, multi-body} -body { } -cleanup { namespace delete foo unset x -} -result {type source line 926 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 932 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -957,9 +962,10 @@ dict for {k v} {foo bar} { test info-24.7 {info frame, interaction, dict for} { reduce [foo::bar] -} {type source line 955 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 961 file info.test cmd {info frame 0} proc ::foo::bar level 0} -namespace delete foo; unset k v +namespace delete foo +unset k v # ------------------------------------------------------------------------- @@ -971,7 +977,7 @@ dict with thedict { test info-24.8 {info frame, interaction, dict with} { reduce [foo::bar] -} {type source line 969 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 976 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo unset thedict foo @@ -982,11 +988,12 @@ namespace eval foo {} dict filter {foo bar} script {k v} { proc ::foo::bar {} {info frame 0} set x 1 -}; unset k v x +} +unset k v x test info-24.9 {info frame, interaction, dict filter} { reduce [foo::bar] -} {type source line 983 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 990 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo #unset x @@ -999,14 +1006,14 @@ eval { test info-25.0 {info frame, proc in eval} { reduce [bar] -} {type source line 997 file info.test cmd {info frame 0} proc ::bar level 0} +} {type source line 1005 file info.test cmd {info frame 0} proc ::bar level 0} # Don't need to clean up yet... proc bar {} {info frame 0} test info-25.1 {info frame, regular proc} { reduce [bar] -} {type source line 1005 file info.test cmd {info frame 0} proc ::bar level 0} +} {type source line 1013 file info.test cmd {info frame 0} proc ::bar level 0} rename bar {} @@ -1024,7 +1031,7 @@ test info-30.0 {bs+nl in literal words} -cleanup {unset res} -body { # offsets of all bs+nl sequences in literal words, then using the # information in the bcc and other places to bump line numbers when # parsing over the location. Also affected: testcases 22.8 and 23.6. -} -result {type source line 1018 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -result {type source line 1026 file info.test cmd {info frame 0} proc ::tcltest::RunTest} # ------------------------------------------------------------------------- # See 24.0 - 24.5 for similar situations, using literal scripts. @@ -1083,7 +1090,8 @@ set body { namespace eval foo {} set x foo -switch -exact -- $x $body; unset body +switch -exact -- $x $body +unset body test info-31.7 {info frame, interaction, switch, dynamic} -body { reduce [foo::bar] @@ -1118,7 +1126,7 @@ test info-33.0 {{*}, literal, direct} -body { reduce [foo::bar] } -cleanup { namespace delete foo -} -result {type source line 1115 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 1124 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -1134,7 +1142,7 @@ test info-33.1 {{*}, literal, simple, bytecompiled} -body { reduce [foo::bar] } -cleanup { namespace delete foo -} -result {type source line 1130 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 1139 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- @@ -1145,7 +1153,7 @@ namespace {*}" " test info-33.2 {{*}, literal, direct} { reduce [foo::bar] -} {type source line 1144 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 1153 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo @@ -1171,7 +1179,7 @@ proc foo::bar {} { } test info-33.3 {{*}, literal, simple, bytecompiled} { reduce [foo::bar] -} {type source line 1169 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} {type source line 1178 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo @@ -1213,7 +1221,8 @@ set body { {info frame 0} } proc foo::bar {} { - global body ; set flag 1 + global body + set flag 1 if {*}$body } test info-34.1 {{*}, literal, bytecompiled} { @@ -1233,7 +1242,7 @@ proc foo {} { } test info-35.0 {apply, literal} { reduce [foo] -} {type source line 1231 file info.test cmd {info frame 0} lambda { +} {type source line 1241 file info.test cmd {info frame 0} lambda { {x y} {info frame 0} } level 0} @@ -1262,7 +1271,7 @@ proc foo::bar {} { } test info-36.0 {info frame, dict for, bcc} -body { reduce [foo::bar] -} -result {type source line 1259 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 1269 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo @@ -1273,13 +1282,14 @@ proc foo::bar {} { set x foo switch -exact -- $x { foo {set y [info frame 0]} + default {} } set y } test info-36.1.0 {switch, list literal, bcc} -body { reduce [foo::bar] -} -result {type source line 1275 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 1285 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo @@ -1294,7 +1304,7 @@ proc foo::bar {} { test info-36.1.1 {switch, multi-body literals, bcc} -body { reduce [foo::bar] -} -result {type source line 1291 file info.test cmd {info frame 0} proc ::foo::bar level 0} +} -result {type source line 1302 file info.test cmd {info frame 0} proc ::foo::bar level 0} namespace delete foo @@ -1318,7 +1328,7 @@ test info-37.0 {eval pure list, single line} -match glob -body { }] eval $cmd return $res -} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 733 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 2 cmd etrace proc ::tcltest::RunTest} * {type eval line 1 cmd foreac proc ::tcltest::RunTest}} -cleanup {unset foo cmd res b c} @@ -1359,9 +1369,9 @@ test info-38.1 {location information for uplevel, dv, direct-var} -match glob -b etrace } join [lrange [uplevel \#0 $script] 0 2] \n -} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 733 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 3 cmd etrace proc ::tcltest::RunTest} -* {type source line 1361 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} -cleanup {unset script y} +* {type source line 1372 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} -cleanup {unset script y} # 38.2 moved to bottom to not disturb other tests with the necessary changes to this one. @@ -1378,10 +1388,10 @@ test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match g etrace } join [lrange [control y $script] 0 3] \n -} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 733 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 3 cmd etrace proc ::control} -* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control} -* {type source line 1380 file info.test cmd {control y $script} proc ::tcltest::RunTest}} -cleanup {unset script y} +* {type source line 1349 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1391 file info.test cmd {control y $script} proc ::tcltest::RunTest}} -cleanup {unset script y} # 38.4 moved to bottom to not disturb other tests with the necessary changes to this one. @@ -1395,11 +1405,11 @@ test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match g test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glob -body { join [lrange [datav] 0 4] \n -} -result {* {type source line 730 file info.test cmd {info frame $level} proc ::etrace level 0} +} -result {* {type source line 733 file info.test cmd {info frame $level} proc ::etrace level 0} * {type eval line 3 cmd etrace proc ::control} -* {type source line 1338 file info.test cmd {uplevel 1 $script} proc ::control} -* {type source line 1353 file info.test cmd {control y $script} proc ::datav level 1} -* {type source line 1397 file info.test cmd datav proc ::tcltest::RunTest}} +* {type source line 1349 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1364 file info.test cmd {control y $script} proc ::datav level 1} +* {type source line 1408 file info.test cmd datav proc ::tcltest::RunTest}} # 38.6 moved to bottom to not disturb other tests with the necessary changes to this one. @@ -1412,10 +1422,10 @@ test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glo testConstraint testevalex [llength [info commands testevalex]] test info-38.7 {location information for arg substitution} -constraints testevalex -match glob -body { join [lrange [testevalex {return -level 0 [etrace]}] 0 3] \n -} -result {* {type source line 730 file info.test cmd {info frame \$level} proc ::etrace level 0} +} -result {* {type source line 733 file info.test cmd {info frame \$level} proc ::etrace level 0} * {type eval line 1 cmd etrace proc ::tcltest::RunTest} -* {type source line 1414 file info.test cmd {testevalex {return -level 0 \[etrace]}} proc ::tcltest::RunTest} -* {type source line * file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}} +* {type source line 1425 file info.test cmd {testevalex {return -level 0 \[etrace]}} proc ::tcltest::RunTest} +* {type source line 2325 file tcltest* cmd {uplevel 1 $script} proc ::tcltest::RunTest}} # ------------------------------------------------------------------------- # literal sharing @@ -1432,8 +1442,8 @@ test info-39.0 {location information not confused by literal sharing} -body { namespace delete ::foo join $res \n } -cleanup {unset res} -result { -type source line 1427 file info.test cmd {info frame 0} proc ::foo::bar level 0 -type source line 1428 file info.test cmd {info frame 0} proc ::foo::bar level 0} +type source line 1438 file info.test cmd {info frame 0} proc ::foo::bar level 0 +type source line 1439 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- # Additional tests for info-30.*, handling of continuation lines (bs+nl sequences). @@ -1449,88 +1459,88 @@ test info-30.1 {bs+nl in literal words, procedure body, compiled} -body { abra } -cleanup { rename abra {} -} -result {type source line 1446 file info.test cmd {info frame 0} proc ::abra level 0} +} -result {type source line 1457 file info.test cmd {info frame 0} proc ::abra level 0} test info-30.2 {bs+nl in literal words, namespace script} { namespace eval xxx { variable res \ - [info frame 0];# line 1457 + [info frame 0];# line 1468 } return [reduce $xxx::res] -} {type source line 1457 file info.test cmd {info frame 0} level 0} +} {type source line 1468 file info.test cmd {info frame 0} level 0} test info-30.3 {bs+nl in literal words, namespace multi-word script} { namespace eval xxx variable res \ - [list [reduce [info frame 0]]];# line 1464 + [list [reduce [info frame 0]]];# line 1475 return $xxx::res -} {type source line 1464 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} {type source line 1475 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.4 {bs+nl in literal words, eval script} -cleanup {unset res} -body { eval { set ::res \ - [reduce [info frame 0]];# line 1471 + [reduce [info frame 0]];# line 1482 } return $res -} -result {type source line 1471 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -result {type source line 1482 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.5 {bs+nl in literal words, eval script, with nested words} -body { eval { if {1} \ { set ::res \ - [reduce [info frame 0]];# line 1481 + [reduce [info frame 0]];# line 1492 } } return $res -} -cleanup {unset res} -result {type source line 1481 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -cleanup {unset res} -result {type source line 1492 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.6 {bs+nl in computed word} -cleanup {unset res} -body { set res "\ -[reduce [info frame 0]]";# line 1489 -} -result { type source line 1489 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +[reduce [info frame 0]]";# line 1500 +} -result { type source line 1500 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.7 {bs+nl in computed word, in proc} -body { proc abra {} { return "\ -[reduce [info frame 0]]";# line 1495 +[reduce [info frame 0]]";# line 1506 } abra } -cleanup { rename abra {} -} -result { type source line 1495 file info.test cmd {info frame 0} proc ::abra level 0} +} -result { type source line 1506 file info.test cmd {info frame 0} proc ::abra level 0} test info-30.8 {bs+nl in computed word, nested eval} -body { eval { set \ res "\ -[reduce [info frame 0]]";# line 1506 +[reduce [info frame 0]]";# line 1517 } -} -cleanup {unset res} -result { type source line 1506 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -cleanup {unset res} -result { type source line 1517 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.9 {bs+nl in computed word, nested eval} -body { eval { set \ res "\ [reduce \ - [info frame 0]]";# line 1515 + [info frame 0]]";# line 1526 } -} -cleanup {unset res} -result { type source line 1515 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -cleanup {unset res} -result { type source line 1526 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.10 {bs+nl in computed word, key to array} -body { set tmp([set \ res "\ [reduce \ - [info frame 0]]"]) x ; #1523 + [info frame 0]]"]) x ; #1534 unset tmp set res -} -cleanup {unset res} -result { type source line 1523 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -cleanup {unset res} -result { type source line 1534 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.11 {bs+nl in subst arguments} -body { subst {[set \ res "\ [reduce \ - [info frame 0]]"]} ; #1532 -} -cleanup {unset res} -result { type source line 1532 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + [info frame 0]]"]} ; #1543 +} -cleanup {unset res} -result { type source line 1543 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.12 {bs+nl in computed word, nested eval} -body { eval { @@ -1538,20 +1548,20 @@ test info-30.12 {bs+nl in computed word, nested eval} -body { res "\ [set x {}] \ [reduce \ - [info frame 0]]";# line 1541 + [info frame 0]]";# line 1552 } -} -cleanup {unset res x} -result { type source line 1541 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -cleanup {unset res x} -result { type source line 1552 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.13 {bs+nl in literal words, uplevel script, with nested words} -body { subinterp ; set res [interp eval sub { uplevel #0 { if {1} \ { set ::res \ - [reduce [info frame 0]];# line 1550 + [reduce [info frame 0]];# line 1561 } } set res }] ; interp delete sub ; set res -} -cleanup {unset res} -result {type source line 1550 file info.test cmd {info frame 0} level 0} +} -cleanup {unset res} -result {type source line 1561 file info.test cmd {info frame 0} level 0} test info-30.14 {bs+nl, literal word, uplevel through proc} { subinterp ; set res [interp eval sub { proc abra {script} { @@ -1559,11 +1569,11 @@ test info-30.14 {bs+nl, literal word, uplevel through proc} { } set res [abra { return "\ -[reduce [info frame 0]]";# line 1562 +[reduce [info frame 0]]";# line 1573 }] rename abra {} set res }] ; interp delete sub ; set res -} { type source line 1562 file info.test cmd {info frame 0} proc ::abra} +} { type source line 1573 file info.test cmd {info frame 0} proc ::abra} test info-30.15 {bs+nl in literal words, nested proc body, compiled} { proc a {} { @@ -1571,7 +1581,7 @@ test info-30.15 {bs+nl in literal words, nested proc body, compiled} { if {1} \ { return \ - [reduce [info frame 0]];# line 1574 + [reduce [info frame 0]];# line 1585 } } } @@ -1579,29 +1589,29 @@ test info-30.15 {bs+nl in literal words, nested proc body, compiled} { rename a {} rename b {} set res -} {type source line 1574 file info.test cmd {info frame 0} proc ::b level 0} +} {type source line 1585 file info.test cmd {info frame 0} proc ::b level 0} test info-30.16 {bs+nl in multi-body switch, compiled} { proc a {value} { switch -regexp -- $value \ - ^key { info frame 0; # 1587 } \ - \t### { info frame 0; # 1588 } \ - {[0-9]*} { info frame 0; # 1589 } + ^key { info frame 0; # 1598 } \ + \t### { info frame 0; # 1599 } \ + {[0-9]*} { info frame 0; # 1600 } } set res {} lappend res [reduce [a {key }]] lappend res [reduce [a {1alpha}]] set res "\n[join $res \n]" } { -type source line 1587 file info.test cmd {info frame 0} proc ::a level 0 -type source line 1589 file info.test cmd {info frame 0} proc ::a level 0} +type source line 1598 file info.test cmd {info frame 0} proc ::a level 0 +type source line 1600 file info.test cmd {info frame 0} proc ::a level 0} test info-30.17 {bs+nl in multi-body switch, direct} { switch -regexp -- {key } \ - ^key { reduce [info frame 0] ;# 1601 } \ + ^key { reduce [info frame 0] ;# 1612 } \ \t### { } \ {[0-9]*} { } -} {type source line 1601 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} {type source line 1612 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.18 {bs+nl, literal word, uplevel through proc, appended, loss of primary tracking data} { proc abra {script} { @@ -1633,8 +1643,8 @@ test info-30.19 {bs+nl in single-body switch, compiled} { lappend res [a {1alpha}] set res "\n[join $res \n]" } { -type source line 1624 file info.test cmd {info frame 0} proc ::a level 0 -type source line 1628 file info.test cmd {info frame 0} proc ::a level 0} +type source line 1635 file info.test cmd {info frame 0} proc ::a level 0 +type source line 1639 file info.test cmd {info frame 0} proc ::a level 0} test info-30.20 {bs+nl in single-body switch, direct} { switch -regexp -- {key } { \ @@ -1644,50 +1654,50 @@ test info-30.20 {bs+nl in single-body switch, direct} { \t### { } {[0-9]*} { } } -} {type source line 1643 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} {type source line 1654 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.21 {bs+nl in if, full compiled} { proc a {value} { if {$value} \ {info frame 0} \ - {info frame 0} ; # 1653 + {info frame 0} ; # 1664 } set res {} lappend res [reduce [a 1]] lappend res [reduce [a 0]] set res "\n[join $res \n]" } { -type source line 1652 file info.test cmd {info frame 0} proc ::a level 0 -type source line 1653 file info.test cmd {info frame 0} proc ::a level 0} +type source line 1663 file info.test cmd {info frame 0} proc ::a level 0 +type source line 1664 file info.test cmd {info frame 0} proc ::a level 0} test info-30.22 {bs+nl in computed word, key to array, compiled} { proc a {} { set tmp([set \ res "\ [reduce \ - [info frame 0]]"]) x ; #1668 + [info frame 0]]"]) x ; #1679 unset tmp set res } set res [a] rename a {} set res -} { type source line 1668 file info.test cmd {info frame 0} proc ::a level 0} +} { type source line 1679 file info.test cmd {info frame 0} proc ::a level 0} test info-30.23 {bs+nl in multi-body switch, full compiled} { proc a {value} { switch -exact -- $value \ - key { info frame 0; # 1680 } \ - xxx { info frame 0; # 1681 } \ - 000 { info frame 0; # 1682 } + key { info frame 0; # 1691 } \ + xxx { info frame 0; # 1692 } \ + 000 { info frame 0; # 1693 } } set res {} lappend res [reduce [a key]] lappend res [reduce [a 000]] set res "\n[join $res \n]" } { -type source line 1680 file info.test cmd {info frame 0} proc ::a level 0 -type source line 1682 file info.test cmd {info frame 0} proc ::a level 0} +type source line 1691 file info.test cmd {info frame 0} proc ::a level 0 +type source line 1693 file info.test cmd {info frame 0} proc ::a level 0} test info-30.24 {bs+nl in single-body switch, full compiled} { proc a {value} { @@ -1705,130 +1715,130 @@ test info-30.24 {bs+nl in single-body switch, full compiled} { lappend res [a 000] set res "\n[join $res \n]" } { -type source line 1696 file info.test cmd {info frame 0} proc ::a level 0 -type source line 1700 file info.test cmd {info frame 0} proc ::a level 0} +type source line 1707 file info.test cmd {info frame 0} proc ::a level 0 +type source line 1711 file info.test cmd {info frame 0} proc ::a level 0} test info-30.25 {TIP 280 for compiled [subst]} { - subst {[reduce [info frame 0]]} ; # 1712 -} {type source line 1712 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + subst {[reduce [info frame 0]]} ; # 1723 +} {type source line 1723 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.26 {TIP 280 for compiled [subst]} { subst \ - {[reduce [info frame 0]]} ; # 1716 -} {type source line 1716 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + {[reduce [info frame 0]]} ; # 1727 +} {type source line 1727 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.27 {TIP 280 for compiled [subst]} { subst { -[reduce [info frame 0]]} ; # 1720 +[reduce [info frame 0]]} ; # 1731 } { -type source line 1720 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +type source line 1731 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.28 {TIP 280 for compiled [subst]} { subst {\ -[reduce [info frame 0]]} ; # 1725 -} { type source line 1725 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +[reduce [info frame 0]]} ; # 1736 +} { type source line 1736 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.29 {TIP 280 for compiled [subst]} { subst {foo\ -[reduce [info frame 0]]} ; # 1729 -} {foo type source line 1729 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +[reduce [info frame 0]]} ; # 1740 +} {foo type source line 1740 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.30 {TIP 280 for compiled [subst]} { subst {foo -[reduce [info frame 0]]} ; # 1733 +[reduce [info frame 0]]} ; # 1744 } {foo -type source line 1733 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +type source line 1744 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.31 {TIP 280 for compiled [subst]} { - subst {[][reduce [info frame 0]]} ; # 1737 -} {type source line 1737 file info.test cmd {info frame 0} proc ::tcltest::RunTest} + subst {[][reduce [info frame 0]]} ; # 1748 +} {type source line 1748 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.32 {TIP 280 for compiled [subst]} { subst {[\ -][reduce [info frame 0]]} ; # 1741 -} {type source line 1741 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +][reduce [info frame 0]]} ; # 1752 +} {type source line 1752 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.33 {TIP 280 for compiled [subst]} { subst {[ -][reduce [info frame 0]]} ; # 1745 -} {type source line 1745 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +][reduce [info frame 0]]} ; # 1756 +} {type source line 1756 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.34 {TIP 280 for compiled [subst]} { subst {[format %s {} -][reduce [info frame 0]]} ; # 1749 -} {type source line 1749 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +][reduce [info frame 0]]} ; # 1760 +} {type source line 1760 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.35 {TIP 280 for compiled [subst]} { subst {[format %s {} ] -[reduce [info frame 0]]} ; # 1754 +[reduce [info frame 0]]} ; # 1765 } { -type source line 1754 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +type source line 1765 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.36 {TIP 280 for compiled [subst]} { subst { -[format %s {}][reduce [info frame 0]]} ; # 1759 +[format %s {}][reduce [info frame 0]]} ; # 1770 } { -type source line 1759 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +type source line 1770 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.37 {TIP 280 for compiled [subst]} { subst { [format %s {}] -[reduce [info frame 0]]} ; # 1765 +[reduce [info frame 0]]} ; # 1776 } { -type source line 1765 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +type source line 1776 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.38 {TIP 280 for compiled [subst]} { subst {\ -[format %s {}][reduce [info frame 0]]} ; # 1771 -} { type source line 1771 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +[format %s {}][reduce [info frame 0]]} ; # 1782 +} { type source line 1782 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.39 {TIP 280 for compiled [subst]} { subst {\ [format %s {}]\ -[reduce [info frame 0]]} ; # 1776 -} { type source line 1776 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +[reduce [info frame 0]]} ; # 1787 +} { type source line 1787 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.40 {TIP 280 for compiled [subst]} -setup { unset -nocomplain empty } -body { set empty {} - subst {$empty[reduce [info frame 0]]} ; # 1782 + subst {$empty[reduce [info frame 0]]} ; # 1793 } -cleanup { unset empty -} -result {type source line 1782 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -result {type source line 1793 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.41 {TIP 280 for compiled [subst]} -setup { unset -nocomplain empty } -body { set empty {} subst {$empty -[reduce [info frame 0]]} ; # 1791 +[reduce [info frame 0]]} ; # 1802 } -cleanup { unset empty } -result { -type source line 1791 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +type source line 1802 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.42 {TIP 280 for compiled [subst]} -setup { unset -nocomplain empty } -body { set empty {}; subst {$empty\ -[reduce [info frame 0]]} ; # 1800 +[reduce [info frame 0]]} ; # 1811 } -cleanup { unset empty -} -result { type source line 1800 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +} -result { type source line 1811 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.43 {TIP 280 for compiled [subst]} -body { unset -nocomplain a\nb set a\nb {} subst {${a -b}[reduce [info frame 0]]} ; # 1808 -} -cleanup {unset a\nb} -result {type source line 1808 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +b}[reduce [info frame 0]]} ; # 1819 +} -cleanup {unset a\nb} -result {type source line 1819 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.44 {TIP 280 for compiled [subst]} { unset -nocomplain a set a(\n) {} subst {$a( -)[reduce [info frame 0]]} ; # 1814 -} {type source line 1814 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +)[reduce [info frame 0]]} ; # 1825 +} {type source line 1825 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.45 {TIP 280 for compiled [subst]} { unset -nocomplain a set a() {} subst {$a([ -return -level 0])[reduce [info frame 0]]} ; # 1820 -} {type source line 1820 file info.test cmd {info frame 0} proc ::tcltest::RunTest} +return -level 0])[reduce [info frame 0]]} ; # 1831 +} {type source line 1831 file info.test cmd {info frame 0} proc ::tcltest::RunTest} test info-30.46 {TIP 280 for compiled [subst]} { unset -nocomplain a - set a(1825) YES; set a(1824) 1824; set a(1826) 1826 - subst {$a([dict get [info frame 0] line])} ; # 1825 + set a(1836) YES; set a(1835) 1835; set a(1837) 1837 + subst {$a([dict get [info frame 0] line])} ; # 1836 } YES test info-30.47 {TIP 280 for compiled [subst]} { unset -nocomplain a - set a(\n1831) YES; set a(\n1830) 1830; set a(\n1832) 1832 + set a(\n1842) YES; set a(\n1841) 1841; set a(\n1843) 1843 subst {$a( -[dict get [info frame 0] line])} ; # 1831 +[dict get [info frame 0] line])} ; # 1842 } YES unset -nocomplain a @@ -1875,8 +1885,8 @@ test info-39.1 {location information not confused by literal sharing, bug 293308 rename get_frame_info {} rename test_info_frame {} rename print_one {} -} -result {type source line 1854 file info.test cmd print_one proc ::test_info_frame level 1 -type source line 1859 file info.test cmd print_one proc ::test_info_frame level 1} +} -result {type source line 1865 file info.test cmd print_one proc ::test_info_frame level 1 +type source line 1870 file info.test cmd print_one proc ::test_info_frame level 1} # ------------------------------------------------------------------------- # Tests moved to the end to not disturb other tests and their locations. @@ -1904,11 +1914,11 @@ test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -match } join [lrange [datal] 0 4] \n } -} -result {* {type source line 1890 file info.test cmd {info frame $level} proc ::etrace level 0} -* {type source line 1902 file info.test cmd etrace proc ::control} -* {type source line 1897 file info.test cmd {uplevel 1 $script} proc ::control} -* {type source line 1900 file info.test cmd control proc ::datal level 1} -* {type source line 1905 file info.test cmd datal level 2}} -cleanup {interp delete sub} +} -result {* {type source line 1901 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 1913 file info.test cmd etrace proc ::control} +* {type source line 1908 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1911 file info.test cmd control proc ::datal level 1} +* {type source line 1916 file info.test cmd datal level 2}} -cleanup {interp delete sub} test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -match glob -setup {subinterp} -body { interp eval sub { @@ -1930,10 +1940,10 @@ test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -mat etrace }] 0 3] \n } -} -result {* {type source line 1919 file info.test cmd {info frame $level} proc ::etrace level 0} -* {type source line 1930 file info.test cmd etrace proc ::control} -* {type source line 1926 file info.test cmd {uplevel 1 $script} proc ::control} -* {type source line 1928 file info.test cmd control level 1}} -cleanup {interp delete sub} +} -result {* {type source line 1930 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 1941 file info.test cmd etrace proc ::control} +* {type source line 1937 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1939 file info.test cmd control level 1}} -cleanup {interp delete sub} test info-38.2 {location information for uplevel, dl, direct-literal} -match glob -setup {subinterp} -body { interp eval sub { @@ -1951,9 +1961,9 @@ test info-38.2 {location information for uplevel, dl, direct-literal} -match glo etrace }] 0 2] \n } -} -result {* {type source line 1944 file info.test cmd {info frame $level} proc ::etrace level 0} -* {type source line 1951 file info.test cmd etrace level 1} -* {type source line 1949 file info.test cmd uplevel\\ \\\\ level 1}} -cleanup {interp delete sub} +} -result {3 {type source line 1955 file info.test cmd {info frame $level} proc ::etrace level 0} +2 {type source line 1962 file info.test cmd etrace level 1} +1 {type source line 1960 file info.test cmd uplevel\ \\ level 1}} -cleanup {interp delete sub} # This test at the end of this file _only_ to avoid disturbing above line # numbers. It _belongs_ after info-9.12 diff --git a/tests/interp.test b/tests/interp.test index 0af9887..f25663a 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -308,13 +308,13 @@ test interp-9.4 {testing aliases and namespace commands} { interp alias {} a {} p set res [a] lappend res [namespace eval tst a] - rename p {} - rename a {} + rename p "" + rename a "" namespace delete tst set res } {GLOBAL GLOBAL} -if {[info command nonexistent-command-in-master] != ""} { +if {[info command nonexistent-command-in-master] ne ""} { rename nonexistent-command-in-master {} } diff --git a/tests/io.test b/tests/io.test index 0688c14..a0f4297 100644 --- a/tests/io.test +++ b/tests/io.test @@ -52,13 +52,13 @@ testConstraint largefileSupport 0 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 ~/_test_]) && [file writable ~]}] # set up a long data file for some of the following tests set path(longfile) [makeFile {} longfile] set f [open $path(longfile) w] -fconfigure $f -eofchar {} -translation lf +chan configure $f -eofchar {} -translation lf for { set i 0 } { $i < 100 } { incr i} { puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef \#123456789abcdef01 @@ -68,12 +68,12 @@ close $f set path(cat) [makeFile { set f stdin - if {$argv != ""} { + if {$argv ne ""} { set f [open [lindex $argv 0]] } - fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar \x1a - fconfigure stdout -encoding binary -translation lf -buffering none - fileevent $f readable "foo $f" + chan configure $f -encoding binary -translation lf -blocking 0 -eofchar \x1a + chan configure stdout -encoding binary -translation lf -buffering none + chan event $f readable "foo $f" proc foo {f} { set x [read $f] catch {puts -nonewline $x} @@ -89,7 +89,7 @@ set thisScript [file join [pwd] [info script]] proc contents {file} { set f [open $file] - fconfigure $f -translation binary + chan configure $f -translation binary set a [read $f] close $f return $a @@ -101,14 +101,14 @@ test io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} { set path(test1) [makeFile {} test1] test io-1.6 {Tcl_WriteChars: WriteBytes} { set f [open $path(test1) w] - fconfigure $f -encoding binary + chan configure $f -encoding binary puts -nonewline $f "a\u4e4d\0" close $f contents $path(test1) } "a\x4d\x00" test io-1.7 {Tcl_WriteChars: WriteChars} { set f [open $path(test1) w] - fconfigure $f -encoding shiftjis + chan configure $f -encoding shiftjis puts -nonewline $f "a\u4e4d\0" close $f contents $path(test1) @@ -122,7 +122,7 @@ test io-1.8 {Tcl_WriteChars: WriteChars} { # go into an infinite loop. set f [open $path(test2) w] - fconfigure $f -encoding iso2022-jp + chan configure $f -encoding iso2022-jp puts -nonewline $f [format %s%c [string repeat " " 4] 12399] close $f contents $path(test2) @@ -140,7 +140,7 @@ test io-1.9 {Tcl_WriteChars: WriteChars} { # With default buffer size set f [open $path(test2) w] - fconfigure $f -encoding iso2022-jp + chan configure $f -encoding iso2022-jp puts -nonewline $f $data close $f lappend sizes [file size $path(test2)] @@ -150,7 +150,7 @@ test io-1.9 {Tcl_WriteChars: WriteChars} { # go into the next buffer. set f [open $path(test2) w] - fconfigure $f -encoding iso2022-jp -buffersize 16 + chan configure $f -encoding iso2022-jp -buffersize 16 puts -nonewline $f $data close $f lappend sizes [file size $path(test2)] @@ -162,7 +162,7 @@ test io-1.9 {Tcl_WriteChars: WriteChars} { # and then again to the second buffer. set f [open $path(test2) w] - fconfigure $f -encoding iso2022-jp -buffersize 17 + chan configure $f -encoding iso2022-jp -buffersize 17 puts -nonewline $f $data close $f lappend sizes [file size $path(test2)] @@ -171,7 +171,7 @@ test io-1.9 {Tcl_WriteChars: WriteChars} { # 3 bytes of escaped data. set f [open $path(test2) w] - fconfigure $f -encoding iso2022-jp -buffersize 18 + chan configure $f -encoding iso2022-jp -buffersize 18 puts -nonewline $f $data close $f lappend sizes [file size $path(test2)] @@ -180,7 +180,7 @@ test io-1.9 {Tcl_WriteChars: WriteChars} { # data and escape bytes. set f [open $path(test2) w] - fconfigure $f -encoding iso2022-jp -buffersize 19 + chan configure $f -encoding iso2022-jp -buffersize 19 puts -nonewline $f $data close $f lappend sizes [file size $path(test2)] @@ -192,7 +192,7 @@ test io-2.1 {WriteBytes} { # loop until all bytes are written set f [open $path(test1) w] - fconfigure $f -encoding binary -buffersize 16 -translation crlf + chan configure $f -encoding binary -buffersize 16 -translation crlf puts $f "abcdefghijklmnopqrstuvwxyz" close $f contents $path(test1) @@ -202,7 +202,7 @@ test io-2.2 {WriteBytes: savedLF > 0} { # \n -> \r\n expansion. It gets stuck at beginning of this buffer. set f [open $path(test1) w] - fconfigure $f -encoding binary -buffersize 16 -translation crlf + chan configure $f -encoding binary -buffersize 16 -translation crlf puts -nonewline $f "123456789012345\n12" set x [list [contents $path(test1)]] close $f @@ -214,7 +214,7 @@ test io-2.3 {WriteBytes: flush on line} { # only up to the \n. set f [open $path(test1) w] - fconfigure $f -encoding binary -buffering line -translation crlf + chan configure $f -encoding binary -buffering line -translation crlf puts -nonewline $f "\n12" set x [contents $path(test1)] close $f @@ -222,7 +222,7 @@ test io-2.3 {WriteBytes: flush on line} { } "\r\n12" test io-2.4 {WriteBytes: reset sawLF after each buffer} { set f [open $path(test1) w] - fconfigure $f -encoding binary -buffering line -translation lf \ + chan configure $f -encoding binary -buffering line -translation lf \ -buffersize 16 puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz" set x [list [contents $path(test1)]] @@ -234,7 +234,7 @@ test io-3.1 {WriteChars: compatibility with WriteBytes} { # loop until all bytes are written set f [open $path(test1) w] - fconfigure $f -encoding ascii -buffersize 16 -translation crlf + chan configure $f -encoding ascii -buffersize 16 -translation crlf puts $f "abcdefghijklmnopqrstuvwxyz" close $f contents $path(test1) @@ -244,7 +244,7 @@ test io-3.2 {WriteChars: compatibility with WriteBytes: savedLF > 0} { # \n -> \r\n expansion. It gets stuck at beginning of this buffer. set f [open $path(test1) w] - fconfigure $f -encoding ascii -buffersize 16 -translation crlf + chan configure $f -encoding ascii -buffersize 16 -translation crlf puts -nonewline $f "123456789012345\n12" set x [list [contents $path(test1)]] close $f @@ -256,7 +256,7 @@ test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} { # only up to the \n. set f [open $path(test1) w] - fconfigure $f -encoding ascii -buffering line -translation crlf + chan configure $f -encoding ascii -buffering line -translation crlf puts -nonewline $f "\n12" set x [contents $path(test1)] close $f @@ -266,7 +266,7 @@ test io-3.4 {WriteChars: loop over stage buffer} { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 16 + chan configure $f -encoding jis0208 -buffersize 16 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -278,7 +278,7 @@ test io-3.5 {WriteChars: saved != 0} { # requested buffersize. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 17 + chan configure $f -encoding jis0208 -buffersize 17 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -295,7 +295,7 @@ test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} { # (the last byte of \uff21 plus the all of \uff22) appended. set f [open $path(test1) w] - fconfigure $f -encoding shiftjis -buffersize 16 + chan configure $f -encoding shiftjis -buffersize 16 puts -nonewline $f "12345678901234\uff21\uff22" set x [list [contents $path(test1)]] close $f @@ -309,7 +309,7 @@ test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} { # of the next channel buffer. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 17 + chan configure $f -encoding jis0208 -buffersize 17 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -317,7 +317,7 @@ test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} { } [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"] test io-3.8 {WriteChars: reset sawLF after each buffer} { set f [open $path(test1) w] - fconfigure $f -encoding ascii -buffering line -translation lf \ + chan configure $f -encoding ascii -buffering line -translation lf \ -buffersize 16 puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz" set x [list [contents $path(test1)]] @@ -329,7 +329,7 @@ test io-4.1 {TranslateOutputEOL: lf} { # search for \n set f [open $path(test1) w] - fconfigure $f -buffering line -translation lf + chan configure $f -buffering line -translation lf puts $f "abcde" set x [list [contents $path(test1)]] close $f @@ -339,7 +339,7 @@ test io-4.2 {TranslateOutputEOL: cr} { # search for \n, replace with \r set f [open $path(test1) w] - fconfigure $f -buffering line -translation cr + chan configure $f -buffering line -translation cr puts $f "abcde" set x [list [contents $path(test1)]] close $f @@ -349,7 +349,7 @@ test io-4.3 {TranslateOutputEOL: crlf} { # simple case: search for \n, replace with \r set f [open $path(test1) w] - fconfigure $f -buffering line -translation crlf + chan configure $f -buffering line -translation crlf puts $f "abcde" set x [list [contents $path(test1)]] close $f @@ -361,7 +361,7 @@ test io-4.4 {TranslateOutputEOL: crlf} { # dest buffer while (dstEnd < dstMax). set f [open $path(test1) w] - fconfigure $f -translation crlf -buffersize 16 + chan configure $f -translation crlf -buffersize 16 puts -nonewline $f "1234567\n\n\n\n\nA" set x [list [contents $path(test1)]] close $f @@ -371,7 +371,7 @@ test io-4.5 {TranslateOutputEOL: crlf} { # Check for overflow of the destination buffer set f [open $path(test1) w] - fconfigure $f -translation crlf -buffersize 12 + chan configure $f -translation crlf -buffersize 12 puts -nonewline $f "12345678901\n456789012345678901234" close $f set x [contents $path(test1)] @@ -379,7 +379,7 @@ test io-4.5 {TranslateOutputEOL: crlf} { test io-5.1 {CheckFlush: not full} { set f [open $path(test1) w] - fconfigure $f + chan configure $f puts -nonewline $f "12345678901234567890" set x [list [contents $path(test1)]] close $f @@ -387,7 +387,7 @@ test io-5.1 {CheckFlush: not full} { } [list "" "12345678901234567890"] test io-5.2 {CheckFlush: full} { set f [open $path(test1) w] - fconfigure $f -buffersize 16 + chan configure $f -buffersize 16 puts -nonewline $f "12345678901234567890" set x [list [contents $path(test1)]] close $f @@ -395,7 +395,7 @@ test io-5.2 {CheckFlush: full} { } [list "1234567890123456" "12345678901234567890"] test io-5.3 {CheckFlush: not line} { set f [open $path(test1) w] - fconfigure $f -buffering line + chan configure $f -buffering line puts -nonewline $f "12345678901234567890" set x [list [contents $path(test1)]] close $f @@ -403,7 +403,7 @@ test io-5.3 {CheckFlush: not line} { } [list "" "12345678901234567890"] test io-5.4 {CheckFlush: line} { set f [open $path(test1) w] - fconfigure $f -buffering line -translation lf -encoding ascii + chan configure $f -buffering line -translation lf -encoding ascii puts -nonewline $f "1234567890\n1234567890" set x [list [contents $path(test1)]] close $f @@ -411,7 +411,7 @@ test io-5.4 {CheckFlush: line} { } [list "1234567890\n1234567890" "1234567890\n1234567890"] test io-5.5 {CheckFlush: none} { set f [open $path(test1) w] - fconfigure $f -buffering none + chan configure $f -buffering none puts -nonewline $f "1234567890" set x [list [contents $path(test1)]] close $f @@ -434,7 +434,7 @@ test io-6.3 {Tcl_GetsObj: how many have we used?} { # if (bufPtr != NULL) {oldRemoved = bufPtr->nextRemoved} set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf puts $f "abc\ndefg" close $f set f [open $path(test1)] @@ -444,22 +444,22 @@ test io-6.3 {Tcl_GetsObj: how many have we used?} { } {0 3 5 4 defg} test io-6.4 {Tcl_GetsObj: encoding == NULL} { set f [open $path(test1) w] - fconfigure $f -translation binary + chan configure $f -translation binary puts $f "\x81\u1234\0" close $f set f [open $path(test1)] - fconfigure $f -translation binary + chan configure $f -translation binary set x [list [gets $f line] $line] close $f set x } [list 3 "\x81\x34\x00"] test io-6.5 {Tcl_GetsObj: encoding != NULL} { set f [open $path(test1) w] - fconfigure $f -translation binary + chan configure $f -translation binary puts $f "\x88\xea\x92\x9a" close $f set f [open $path(test1)] - fconfigure $f -encoding shiftjis + chan configure $f -encoding shiftjis set x [list [gets $f line] $line] close $f set x @@ -486,7 +486,7 @@ test io-6.7 {Tcl_GetsObj: error in input} {stdio openpipe} { puts -nonewline $f "hi\nwould" flush $f gets $f - fconfigure $f -blocking 0 + chan configure $f -blocking 0 set x [gets $f line] close $f set x @@ -496,7 +496,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 + chan configure $f -eofchar \x1a set x [list [gets $f line] $line [gets $f line] $line] close $f set x @@ -506,7 +506,7 @@ test io-6.9 {Tcl_GetsObj: remember if EOF is seen} { puts $f "abcdefghijk\nwom\u001abat" close $f set f [open $path(test1)] - fconfigure $f -eofchar \x1a + chan configure $f -eofchar \x1a set x [list [gets $f line] $line [gets $f line] $line] close $f set x @@ -516,62 +516,62 @@ test io-6.10 {Tcl_GetsObj: lf mode: no chars} { set f [open $path(test1) w] close $f set f [open $path(test1)] - fconfigure $f -translation lf + chan configure $f -translation lf set x [list [gets $f line] $line] close $f set x } {-1 {}} test io-6.11 {Tcl_GetsObj: lf mode: lone \n} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\n" close $f set f [open $path(test1)] - fconfigure $f -translation lf + chan configure $f -translation lf set x [list [gets $f line] $line [gets $f line] $line] close $f set x } {0 {} -1 {}} test io-6.12 {Tcl_GetsObj: lf mode: lone \r} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\r" close $f set f [open $path(test1)] - fconfigure $f -translation lf + chan configure $f -translation lf set x [list [gets $f line] $line [gets $f line] $line] close $f set x } [list 1 "\r" -1 ""] test io-6.13 {Tcl_GetsObj: lf mode: 1 char} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f a close $f set f [open $path(test1)] - fconfigure $f -translation lf + chan configure $f -translation lf set x [list [gets $f line] $line [gets $f line] $line] close $f set x } {1 a -1 {}} test io-6.14 {Tcl_GetsObj: lf mode: 1 char followed by EOL} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "a\n" close $f set f [open $path(test1)] - fconfigure $f -translation lf + chan configure $f -translation lf set x [list [gets $f line] $line [gets $f line] $line] close $f set x } {1 a -1 {}} test io-6.15 {Tcl_GetsObj: lf mode: several chars} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" close $f set f [open $path(test1)] - fconfigure $f -translation lf + chan configure $f -translation lf set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line] close $f set x @@ -580,62 +580,62 @@ test io-6.16 {Tcl_GetsObj: cr mode: no chars} { set f [open $path(test1) w] close $f set f [open $path(test1)] - fconfigure $f -translation cr + chan configure $f -translation cr set x [list [gets $f line] $line] close $f set x } {-1 {}} test io-6.17 {Tcl_GetsObj: cr mode: lone \n} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\n" close $f set f [open $path(test1)] - fconfigure $f -translation cr + chan configure $f -translation cr set x [list [gets $f line] $line [gets $f line] $line] close $f set x } [list 1 "\n" -1 ""] test io-6.18 {Tcl_GetsObj: cr mode: lone \r} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\r" close $f set f [open $path(test1)] - fconfigure $f -translation cr + chan configure $f -translation cr set x [list [gets $f line] $line [gets $f line] $line] close $f set x } {0 {} -1 {}} test io-6.19 {Tcl_GetsObj: cr mode: 1 char} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f a close $f set f [open $path(test1)] - fconfigure $f -translation cr + chan configure $f -translation cr set x [list [gets $f line] $line [gets $f line] $line] close $f set x } {1 a -1 {}} test io-6.20 {Tcl_GetsObj: cr mode: 1 char followed by EOL} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "a\r" close $f set f [open $path(test1)] - fconfigure $f -translation cr + chan configure $f -translation cr set x [list [gets $f line] $line [gets $f line] $line] close $f set x } {1 a -1 {}} test io-6.21 {Tcl_GetsObj: cr mode: several chars} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" close $f set f [open $path(test1)] - fconfigure $f -translation cr + chan configure $f -translation cr set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line] close $f set x @@ -644,84 +644,84 @@ test io-6.22 {Tcl_GetsObj: crlf mode: no chars} { set f [open $path(test1) w] close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [list [gets $f line] $line] close $f set x } {-1 {}} test io-6.23 {Tcl_GetsObj: crlf mode: lone \n} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\n" close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [list [gets $f line] $line [gets $f line] $line] close $f set x } [list 1 "\n" -1 ""] test io-6.24 {Tcl_GetsObj: crlf mode: lone \r} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\r" close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [list [gets $f line] $line [gets $f line] $line] close $f set x } [list 1 "\r" -1 ""] test io-6.25 {Tcl_GetsObj: crlf mode: \r\r} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\r\r" close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [list [gets $f line] $line [gets $f line] $line] close $f set x } [list 2 "\r\r" -1 ""] test io-6.26 {Tcl_GetsObj: crlf mode: \r\n} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\r\n" close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [list [gets $f line] $line [gets $f line] $line] close $f set x } [list 0 "" -1 ""] test io-6.27 {Tcl_GetsObj: crlf mode: 1 char} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f a close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [list [gets $f line] $line [gets $f line] $line] close $f set x } {1 a -1 {}} test io-6.28 {Tcl_GetsObj: crlf mode: 1 char followed by EOL} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "a\r\n" close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [list [gets $f line] $line [gets $f line] $line] close $f set x } {1 a -1 {}} test io-6.29 {Tcl_GetsObj: crlf mode: several chars} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line] close $f set x @@ -730,25 +730,25 @@ test io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {testchannel} { # if (eol >= dstEnd) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "123456789012345\r\nabcdefghijklmnoprstuvwxyz" close $f set f [open $path(test1)] - fconfigure $f -translation crlf -buffersize 16 + chan configure $f -translation crlf -buffersize 16 set x [list [gets $f line] $line [testchannel inputbuffered $f]] close $f set x } [list 15 "123456789012345" 15] -test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel openpipe fileevent} { +test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel openpipe chan event} { # (FilterInputBytes() != 0) set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -translation {crlf lf} -buffering none + chan configure $f -translation {crlf lf} -buffering none puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r" - fconfigure $f -buffersize 16 + chan configure $f -buffersize 16 set x [gets $f] - fconfigure $f -blocking 0 - lappend x [gets $f line] $line [fblocked $f] [testchannel inputbuffered $f] + chan configure $f -blocking 0 + lappend x [gets $f line] $line [chan blocked $f] [testchannel inputbuffered $f] close $f set x } [list "bbbbbbbbbbbbbb" -1 "" 1 16] @@ -756,11 +756,11 @@ test io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testchannel} # not (FilterInputBytes() != 0) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "123456789012345\r\n123" close $f set f [open $path(test1)] - fconfigure $f -translation crlf -buffersize 16 + chan configure $f -translation crlf -buffersize 16 set x [list [gets $f line] $line [tell $f] [testchannel inputbuffered $f]] close $f set x @@ -769,11 +769,11 @@ test io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} { # eol still equals dstEnd set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "123456789012345\r" close $f set f [open $path(test1)] - fconfigure $f -translation crlf -buffersize 16 + chan configure $f -translation crlf -buffersize 16 set x [list [gets $f line] $line [eof $f]] close $f set x @@ -782,11 +782,11 @@ test io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} { # not (*eol == '\n') set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "123456789012345\rabcd\r\nefg" close $f set f [open $path(test1)] - fconfigure $f -translation crlf -buffersize 16 + chan configure $f -translation crlf -buffersize 16 set x [list [gets $f line] $line [tell $f]] close $f set x @@ -795,151 +795,151 @@ test io-6.35 {Tcl_GetsObj: auto mode: no chars} { set f [open $path(test1) w] close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [list [gets $f line] $line] close $f set x } {-1 {}} test io-6.36 {Tcl_GetsObj: auto mode: lone \n} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\n" close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [list [gets $f line] $line [gets $f line] $line] close $f set x } [list 0 "" -1 ""] test io-6.37 {Tcl_GetsObj: auto mode: lone \r} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\r" close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [list [gets $f line] $line [gets $f line] $line] close $f set x } [list 0 "" -1 ""] test io-6.38 {Tcl_GetsObj: auto mode: \r\r} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\r\r" close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line] close $f set x } [list 0 "" 0 "" -1 ""] test io-6.39 {Tcl_GetsObj: auto mode: \r\n} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\r\n" close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [list [gets $f line] $line [gets $f line] $line] close $f set x } [list 0 "" -1 ""] test io-6.40 {Tcl_GetsObj: auto mode: 1 char} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f a close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [list [gets $f line] $line [gets $f line] $line] close $f set x } {1 a -1 {}} test io-6.41 {Tcl_GetsObj: auto mode: 1 char followed by EOL} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "a\r\n" close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [list [gets $f line] $line [gets $f line] $line] close $f set x } {1 a -1 {}} test io-6.42 {Tcl_GetsObj: auto mode: several chars} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop" close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [list [gets $f line] $line [gets $f line] $line] lappend x [gets $f line] $line [gets $f line] $line [gets $f line] $line close $f set x } [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""] -test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} { +test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe chan event} { # if (chanPtr->flags & INPUT_SAW_CR) set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -translation {auto lf} -buffering none + chan configure $f -translation {auto lf} -buffering none puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" - fconfigure $f -buffersize 16 + chan configure $f -buffersize 16 set x [list [gets $f]] - fconfigure $f -blocking 0 + chan configure $f -blocking 0 lappend x [gets $f line] $line [testchannel queuedcr $f] - fconfigure $f -blocking 1 + chan configure $f -blocking 1 puts -nonewline $f "\nabcd\refg\x1a" lappend x [gets $f line] $line [testchannel queuedcr $f] lappend x [gets $f line] $line close $f set x } [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] -test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel openpipe fileevent} { +test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel openpipe chan event} { # not (*eol == '\n') set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -translation {auto lf} -buffering none + chan configure $f -translation {auto lf} -buffering none puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" - fconfigure $f -buffersize 16 + chan configure $f -buffersize 16 set x [list [gets $f]] - fconfigure $f -blocking 0 + chan configure $f -blocking 0 lappend x [gets $f line] $line [testchannel queuedcr $f] - fconfigure $f -blocking 1 + chan configure $f -blocking 1 puts -nonewline $f "abcd\refg\x1a" lappend x [gets $f line] $line [testchannel queuedcr $f] lappend x [gets $f line] $line close $f set x } [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] -test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel openpipe fileevent} { +test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel openpipe chan event} { # Tcl_ExternalToUtf() set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -translation {auto lf} -buffering none - fconfigure $f -encoding unicode + chan configure $f -translation {auto lf} -buffering none + chan configure $f -encoding unicode puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" - fconfigure $f -buffersize 16 + chan configure $f -buffersize 16 gets $f - fconfigure $f -blocking 0 + chan configure $f -blocking 0 set x [list [gets $f line] $line [testchannel queuedcr $f]] - fconfigure $f -blocking 1 + chan configure $f -blocking 1 puts -nonewline $f "\nabcd\refg" lappend x [gets $f line] $line [testchannel queuedcr $f] close $f set x } [list 15 "123456789abcdef" 1 4 "abcd" 0] -test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel openpipe fileevent} { +test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel openpipe chan event} { # memmove() set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -translation {auto lf} -buffering none + chan configure $f -translation {auto lf} -buffering none puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" - fconfigure $f -buffersize 16 + chan configure $f -buffersize 16 gets $f - fconfigure $f -blocking 0 + chan configure $f -blocking 0 set x [list [gets $f line] $line [testchannel queuedcr $f]] - fconfigure $f -blocking 1 + chan configure $f -blocking 1 puts -nonewline $f "\n\x1a" lappend x [gets $f line] $line [testchannel queuedcr $f] close $f @@ -949,11 +949,11 @@ test io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {testcha # (eol == dstEnd) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "123456789012345\r\nabcdefghijklmnopq" close $f set f [open $path(test1)] - fconfigure $f -translation auto -buffersize 16 + chan configure $f -translation auto -buffersize 16 set x [list [gets $f] [testchannel inputbuffered $f]] close $f set x @@ -962,11 +962,11 @@ test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testc # PeekAhead() did not get any, so (eol >= dstEnd) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "123456789012345\r" close $f set f [open $path(test1)] - fconfigure $f -translation auto -buffersize 16 + chan configure $f -translation auto -buffersize 16 set x [list [gets $f] [testchannel queuedcr $f]] close $f set x @@ -975,7 +975,7 @@ test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} { # if (*eol == '\n') {skip++} set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "123456\r\n78901" close $f set f [open $path(test1)] @@ -987,7 +987,7 @@ test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} { # not (*eol == '\n') set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "123456\r78901" close $f set f [open $path(test1)] @@ -999,7 +999,7 @@ test io-6.51 {Tcl_GetsObj: auto mode: \n} { # else if (*eol == '\n') {goto gotoeol;} set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "123456\n78901" close $f set f [open $path(test1)] @@ -1011,11 +1011,11 @@ test io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} { # if (eof != NULL) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "123456\x1ak9012345\r" close $f set f [open $path(test1)] - fconfigure $f -eofchar \x1a + chan configure $f -eofchar \x1a set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]] close $f set x @@ -1045,30 +1045,30 @@ test io-6.55 {Tcl_GetsObj: overconverted} { # Tcl_ExternalToUtf(), make sure state updated set f [open $path(test1) w] - fconfigure $f -encoding iso2022-jp + chan configure $f -encoding iso2022-jp puts $f "there\u4e00ok\n\u4e01more bytes\nhere" close $f set f [open $path(test1)] - fconfigure $f -encoding iso2022-jp + chan configure $f -encoding iso2022-jp set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line] close $f set x } [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"] -test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio openpipe fileevent} { +test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio openpipe chan event} { update set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -buffering none + chan configure $f -buffering none puts -nonewline $f "foobar" - fconfigure $f -blocking 0 + chan configure $f -blocking 0 variable x {} after 500 [namespace code { lappend x timeout }] - fileevent $f readable [namespace code { lappend x [gets $f] }] + chan event $f readable [namespace code { lappend x [gets $f] }] vwait [namespace which -variable x] vwait [namespace which -variable x] - fconfigure $f -blocking 1 + chan configure $f -blocking 1 puts -nonewline $f "baz\n" after 500 [namespace code { lappend x timeout }] - fconfigure $f -blocking 0 + chan configure $f -blocking 0 vwait [namespace which -variable x] vwait [namespace which -variable x] close $f @@ -1079,11 +1079,11 @@ test io-7.1 {FilterInputBytes: split up character at end of buffer} { # (result == TCL_CONVERT_MULTIBYTE) set f [open $path(test1) w] - fconfigure $f -encoding shiftjis + chan configure $f -encoding shiftjis puts $f "1234567890123\uff10\uff11\uff12\uff13\uff14\nend" close $f set f [open $path(test1)] - fconfigure $f -encoding shiftjis -buffersize 16 + chan configure $f -encoding shiftjis -buffersize 16 set x [gets $f] close $f set x @@ -1092,43 +1092,43 @@ test io-7.2 {FilterInputBytes: split up character in middle of buffer} { # (bufPtr->nextAdded < bufPtr->bufLength) set f [open $path(test1) w] - fconfigure $f -encoding binary + chan configure $f -encoding binary puts -nonewline $f "1234567890\n123\x82\x4f\x82\x50\x82" close $f set f [open $path(test1)] - fconfigure $f -encoding shiftjis + chan configure $f -encoding shiftjis set x [list [gets $f line] $line [eof $f]] close $f set x } [list 10 "1234567890" 0] test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} { set f [open $path(test1) w] - fconfigure $f -encoding binary + chan configure $f -encoding binary puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" close $f set f [open $path(test1)] - fconfigure $f -encoding shiftjis + chan configure $f -encoding shiftjis set x [list [gets $f line] $line] lappend x [tell $f] [testchannel inputbuffered $f] [eof $f] lappend x [gets $f line] $line close $f set x } [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""] -test io-7.4 {FilterInputBytes: recover from split up character} {stdio openpipe fileevent} { +test io-7.4 {FilterInputBytes: recover from split up character} {stdio openpipe chan event} { set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -encoding binary -buffering none + chan configure $f -encoding binary -buffering none puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82" - fconfigure $f -encoding shiftjis -blocking 0 - fileevent $f read [namespace code "ready $f"] + chan configure $f -encoding shiftjis -blocking 0 + chan event $f read [namespace code "ready $f"] variable x {} proc ready {f} { variable x - lappend x [gets $f line] $line [fblocked $f] + lappend x [gets $f line] $line [chan blocked $f] } vwait [namespace which -variable x] - fconfigure $f -encoding binary -blocking 1 + chan configure $f -encoding binary -blocking 1 puts $f "\x51\x82\x52" - fconfigure $f -encoding shiftjis + chan configure $f -encoding shiftjis vwait [namespace which -variable x] close $f set x @@ -1138,42 +1138,42 @@ test io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} # (bufPtr->nextPtr == NULL) set f [open $path(test1) w] - fconfigure $f -encoding ascii -translation lf + chan configure $f -encoding ascii -translation lf puts -nonewline $f "123456789012345\r\n2345678" close $f set f [open $path(test1)] - fconfigure $f -encoding ascii -translation auto -buffersize 16 + chan configure $f -encoding ascii -translation auto -buffersize 16 # here gets $f set x [testchannel inputbuffered $f] close $f set x } "7" -test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel openpipe fileevent} { +test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel openpipe chan event} { # not (bufPtr->nextPtr == NULL) set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -translation lf -encoding ascii -buffering none + chan configure $f -translation lf -encoding ascii -buffering none puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz" variable x {} - fileevent $f read [namespace code "ready $f"] + chan event $f read [namespace code "ready $f"] proc ready {f} { variable x lappend x [gets $f line] $line [testchannel inputbuffered $f] } - fconfigure $f -encoding unicode -buffersize 16 -blocking 0 + chan configure $f -encoding unicode -buffersize 16 -blocking 0 vwait [namespace which -variable x] - fconfigure $f -translation auto -encoding ascii -blocking 1 + chan configure $f -translation auto -encoding ascii -blocking 1 # here vwait [namespace which -variable x] close $f set x } [list -1 "" 42 15 "123456789012345" 25] -test io-8.3 {PeekAhead: no cached data available} {stdio testchannel openpipe fileevent} { +test io-8.3 {PeekAhead: no cached data available} {stdio testchannel openpipe chan event} { # (bytesLeft == 0) set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -translation {auto binary} + chan configure $f -translation {auto binary} puts -nonewline $f "abcdefghijklmno\r" flush $f set x [list [gets $f line] $line [testchannel queuedcr $f]] @@ -1187,11 +1187,11 @@ test io-8.4 {PeekAhead: cached data available in this buffer} { # not (bytesLeft == 0) set f [open $path(test1) w+] - fconfigure $f -translation binary + chan configure $f -translation binary puts $f "${a}\r\nabcdef" close $f set f [open $path(test1)] - fconfigure $f -encoding binary -translation auto + chan configure $f -encoding binary -translation auto # "${a}\r" was converted in one operation (because ENCODING_LINESIZE # is 30). To check if "\n" follows, calls PeekAhead and determines @@ -1202,11 +1202,11 @@ test io-8.4 {PeekAhead: cached data available in this buffer} { set x } $a unset a -test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel openpipe fileevent} { +test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel openpipe chan event} { # (bufPtr->nextAdded < bufPtr->length) set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -translation {auto binary} + chan configure $f -translation {auto binary} puts -nonewline $f "abcdefghijklmno\r" flush $f # here @@ -1214,11 +1214,11 @@ test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel op close $f set x } {15 abcdefghijklmno 1} -test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe fileevent} { +test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe chan event} { # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -translation {auto binary} -buffersize 16 + chan configure $f -translation {auto binary} -buffersize 16 puts -nonewline $f "abcdefghijklmno\r" flush $f # here @@ -1226,11 +1226,11 @@ test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe close $f set x } {15 abcdefghijklmno 1} -test io-8.7 {PeekAhead: cleanup} {stdio testchannel openpipe fileevent} { +test io-8.7 {PeekAhead: cleanup} {stdio testchannel openpipe chan event} { # Make sure bytes are removed from buffer. set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -translation {auto binary} -buffering none + chan configure $f -translation {auto binary} -buffering none puts -nonewline $f "abcdefghijklmno\r" # here set x [list [gets $f line] $line [testchannel queuedcr $f]] @@ -1268,7 +1268,7 @@ test io-10.3 {Tcl_ReadChars: loop until enough copied} { close $f set f [open $path(test1)] - fconfigure $f -buffersize 16 + chan configure $f -buffersize 16 # here set x [read $f 19] close $f @@ -1308,7 +1308,7 @@ test io-11.1 {ReadBytes: want to read a lot} { puts -nonewline $f abcdefghijkl close $f set f [open $path(test1)] - fconfigure $f -encoding binary + chan configure $f -encoding binary # here set x [read $f 1000] close $f @@ -1321,7 +1321,7 @@ test io-11.2 {ReadBytes: want to read all} { puts -nonewline $f abcdefghijkl close $f set f [open $path(test1)] - fconfigure $f -encoding binary + chan configure $f -encoding binary # here set x [read $f] close $f @@ -1334,7 +1334,7 @@ test io-11.3 {ReadBytes: allocate more space} { puts -nonewline $f abcdefghijklmnopqrstuvwxyz close $f set f [open $path(test1)] - fconfigure $f -buffersize 16 -encoding binary + chan configure $f -buffersize 16 -encoding binary # here set x [read $f] close $f @@ -1347,7 +1347,7 @@ test io-11.4 {ReadBytes: EOF char found} { puts $f abcdefghijklmnopqrstuvwxyz close $f set f [open $path(test1)] - fconfigure $f -eofchar m -encoding binary + chan configure $f -eofchar m -encoding binary # here set x [list [read $f] [eof $f] [read $f] [eof $f]] close $f @@ -1385,46 +1385,46 @@ test io-12.3 {ReadChars: allocate more space} { puts -nonewline $f abcdefghijklmnopqrstuvwxyz close $f set f [open $path(test1)] - fconfigure $f -buffersize 16 + chan configure $f -buffersize 16 # here set x [read $f] close $f set x } {abcdefghijklmnopqrstuvwxyz} -test io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileevent} { +test io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe chan event} { # (srcRead == 0) set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -encoding binary -buffering none -buffersize 16 + chan configure $f -encoding binary -buffering none -buffersize 16 puts -nonewline $f "123456789012345\x96" - fconfigure $f -encoding shiftjis -blocking 0 + chan configure $f -encoding shiftjis -blocking 0 - fileevent $f read [namespace code "ready $f"] + chan event $f read [namespace code "ready $f"] proc ready {f} { variable x lappend x [read $f] [testchannel inputbuffered $f] } variable x {} - fconfigure $f -encoding shiftjis + chan configure $f -encoding shiftjis vwait [namespace which -variable x] - fconfigure $f -encoding binary -blocking 1 + chan configure $f -encoding binary -blocking 1 puts -nonewline $f "\x7b" after 500 ;# Give the cat process time to catch up - fconfigure $f -encoding shiftjis -blocking 0 + chan configure $f -encoding shiftjis -blocking 0 vwait [namespace which -variable x] close $f set x } [list "123456789012345" 1 "\u672c" 0] -test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe fileevent} { +test io-12.5 {ReadChars: chan events on partial characters} {stdio openpipe chan event} { set path(test1) [makeFile { - fconfigure stdout -encoding binary -buffering none + chan configure stdout -encoding binary -buffering none gets stdin; puts -nonewline "\xe7" gets stdin; puts -nonewline "\x89" gets stdin; puts -nonewline "\xa6" } test1] set f [open "|[list [interpreter] $path(test1)]" r+] - fileevent $f readable [namespace code { + chan event $f readable [namespace code { lappend x [read $f] if {[eof $f]} { lappend x eof @@ -1432,7 +1432,7 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe filee }] puts $f "go1" flush $f - fconfigure $f -blocking 0 -encoding utf-8 + chan configure $f -blocking 0 -encoding utf-8 variable x {} vwait [namespace which -variable x] after 500 [namespace code { lappend x timeout }] @@ -1452,22 +1452,22 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe filee test io-13.1 {TranslateInputEOL: cr mode} {} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\rdef\r" close $f set f [open $path(test1)] - fconfigure $f -translation cr + chan configure $f -translation cr set x [read $f] close $f set x } "abcd\ndef\n" test io-13.2 {TranslateInputEOL: crlf mode} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\r\ndef\r\n" close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [read $f] close $f set x @@ -1476,11 +1476,11 @@ test io-13.3 {TranslateInputEOL: crlf mode: naked cr} { # (src >= srcMax) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\r\ndef\r" close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [read $f] close $f set x @@ -1489,11 +1489,11 @@ test io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} { # (src >= srcMax) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\r\ndef\rfgh" close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [read $f] close $f set x @@ -1502,23 +1502,23 @@ test io-13.5 {TranslateInputEOL: crlf mode: naked lf} { # (src >= srcMax) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\r\ndef\nfgh" close $f set f [open $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [read $f] close $f set x } "abcd\ndef\nfgh" -test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel openpipe fileevent} { +test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel openpipe chan event} { # (chanPtr->flags & INPUT_SAW_CR) # This test may fail on slower machines. set f [open "|[list [interpreter] $path(cat)]" w+] - fconfigure $f -blocking 0 -buffering none -translation {auto lf} + chan configure $f -blocking 0 -buffering none -translation {auto lf} - fileevent $f read [namespace code "ready $f"] + chan event $f read [namespace code "ready $f"] proc ready {f} { variable x lappend x [read $f] [testchannel queuedcr $f] @@ -1541,11 +1541,11 @@ test io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel openpipe} { # (src >= srcMax) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\r" close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [list [read $f] [testchannel queuedcr $f]] close $f set x @@ -1554,22 +1554,22 @@ test io-13.8 {TranslateInputEOL: auto mode: \r\n} { # (*src == '\n') set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\r\ndef" close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [read $f] close $f set x } "abcd\ndef" test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} { set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\rdef" close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [read $f] close $f set x @@ -1578,11 +1578,11 @@ test io-13.10 {TranslateInputEOL: auto mode: \n} { # not (*src == '\r') set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\ndef" close $f set f [open $path(test1)] - fconfigure $f -translation auto + chan configure $f -translation auto set x [read $f] close $f set x @@ -1591,11 +1591,11 @@ test io-13.11 {TranslateInputEOL: EOF char} { # (*chanPtr->inEofChar != '\0') set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "abcd\ndefgh" close $f set f [open $path(test1)] - fconfigure $f -translation auto -eofchar e + chan configure $f -translation auto -eofchar e set x [read $f] close $f set x @@ -1604,11 +1604,11 @@ test io-13.12 {TranslateInputEOL: find EOF char in src} { # (*chanPtr->inEofChar != '\0') set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "\r\n\r\n\r\nab\r\n\r\ndef\r\n\r\n\r\n" close $f set f [open $path(test1)] - fconfigure $f -translation auto -eofchar e + chan configure $f -translation auto -eofchar e set x [read $f] close $f set x @@ -1618,7 +1618,7 @@ test io-13.12 {TranslateInputEOL: find EOF char in src} { # Tcl_SetStdChannel and Tcl_GetStdChannel. Incidentally we are # also testing channel table management. -if {[info commands testchannel] != ""} { +if {[info commands testchannel] ne ""} { set consoleFileNames [lsort [testchannel open]] } else { # just to avoid an error @@ -1627,18 +1627,18 @@ if {[info commands testchannel] != ""} { test io-14.1 {Tcl_SetStdChannel and Tcl_GetStdChannel} {testchannel} { set l "" - lappend l [fconfigure stdin -buffering] - lappend l [fconfigure stdout -buffering] - lappend l [fconfigure stderr -buffering] + lappend l [chan configure stdin -buffering] + lappend l [chan configure stdout -buffering] + lappend l [chan configure stderr -buffering] lappend l [lsort [testchannel open]] set l } [list line line none $consoleFileNames] test io-14.2 {Tcl_SetStdChannel and Tcl_GetStdChannel} { interp create x set l "" - lappend l [x eval {fconfigure stdin -buffering}] - lappend l [x eval {fconfigure stdout -buffering}] - lappend l [x eval {fconfigure stderr -buffering}] + lappend l [x eval {chan configure stdin -buffering}] + lappend l [x eval {chan configure stdout -buffering}] + lappend l [x eval {chan configure stderr -buffering}] interp delete x set l } {line line none} @@ -1755,7 +1755,7 @@ test io-14.8 {reuse of stdio special channels} {stdio openpipe} { close $f set c } hello -test io-14.9 {reuse of stdio special channels} {stdio openpipe fileevent} { +test io-14.9 {reuse of stdio special channels} {stdio openpipe chan event} { file delete $path(script) file delete $path(test1) set f [open $path(script) w] @@ -1919,7 +1919,7 @@ test io-20.1 {Tcl_CreateChannel: initial settings} { set old [encoding system] encoding system ascii set f [open $path(test1) w] - set x [fconfigure $f -encoding] + set x [chan configure $f -encoding] close $f encoding system $old close $a @@ -1927,13 +1927,13 @@ test io-20.1 {Tcl_CreateChannel: initial settings} { } {ascii} test io-20.2 {Tcl_CreateChannel: initial settings} {win} { set f [open $path(test1) w+] - set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] + set x [list [chan configure $f -eofchar] [chan configure $f -translation]] close $f set x } [list [list \x1a ""] {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]] + set x [list [chan configure $f -eofchar] [chan configure $f -translation]] close $f set x } {{{} {}} {auto lf}} @@ -1945,8 +1945,8 @@ test io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio openpipe} set f1 [} puts $f [list open $path(stdout) w]] puts $f { - fconfigure $f1 -buffersize 777 - puts stderr [fconfigure stdout -buffersize] + chan configure $f1 -buffersize 777 + puts stderr [chan configure stdout -buffersize] } close $f set f [open "|[list [interpreter] $path(script)]"] @@ -1985,7 +1985,7 @@ test io-24.1 {Tcl_GetChannelType} {testchannel} { test io-25.1 {Tcl_GetChannelHandle, input} {testchannel} { set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts $f "1234567890\n098765432" close $f set f [open $path(test1) r] @@ -1999,7 +1999,7 @@ test io-25.1 {Tcl_GetChannelHandle, input} {testchannel} { test io-25.2 {Tcl_GetChannelHandle, output} {testchannel} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello set l "" lappend l [testchannel outputbuffered $f] @@ -2034,7 +2034,7 @@ test io-27.1 {FlushChannel, no output buffered} { test io-27.2 {FlushChannel, some output buffered} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set l "" puts $f hello lappend l [file size $path(test1)] @@ -2047,7 +2047,7 @@ test io-27.2 {FlushChannel, some output buffered} { test io-27.3 {FlushChannel, implicit flush on close} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set l "" puts $f hello lappend l [file size $path(test1)] @@ -2058,8 +2058,8 @@ test io-27.3 {FlushChannel, implicit flush on close} { test io-27.4 {FlushChannel, implicit flush when buffer fills} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} - fconfigure $f -buffersize 60 + chan configure $f -translation lf -eofchar {} + chan configure $f -buffersize 60 set l "" lappend l [file size $path(test1)] for {set i 0} {$i < 12} {incr i} { @@ -2075,7 +2075,7 @@ test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \ {unixOrPc} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -buffersize 60 -eofchar {} + chan configure $f -translation lf -buffersize 60 -eofchar {} set l "" lappend l [file size $path(test1)] for {set i 0} {$i < 12} {incr i} { @@ -2097,7 +2097,7 @@ test io-27.6 {FlushChannel, async flushing, async close} \ set f [open $path(pipe) w] puts $f "set f \[[list open $path(output) w]]" puts $f { - fconfigure $f -translation lf -buffering none -eofchar {} + chan configure $f -translation lf -buffering none -eofchar {} while {![eof stdin]} { after 20 puts -nonewline $f [read stdin 1024] @@ -2112,7 +2112,7 @@ test io-27.6 {FlushChannel, async flushing, async close} \ set f [open $path(output) w] close $f set f [open "|[list [interpreter] $path(pipe)]" w] - fconfigure $f -blocking off + chan configure $f -blocking off puts -nonewline $f $x close $f set counter 0 @@ -2168,11 +2168,11 @@ test io-28.3 {CloseChannel, not called before output queue is empty} \ # side of the pipe already closed, so that writing would cause an # error "invalid file". - fconfigure stdout -eofchar {} - fconfigure stderr -eofchar {} + chan configure stdout -eofchar {} + chan configure stderr -eofchar {} set f [open $path(output) w] - fconfigure $f -translation lf -buffering none + chan configure $f -translation lf -buffering none for {set x 0} {$x < 20} {incr x} { after 20 puts -nonewline $f [read stdin 1024] @@ -2187,7 +2187,7 @@ test io-28.3 {CloseChannel, not called before output queue is empty} \ set f [open $path(output) w] close $f set f [open "|[list [interpreter] pipe]" r+] - fconfigure $f -blocking off -eofchar {} + chan configure $f -blocking off -eofchar {} puts -nonewline $f $x close $f @@ -2235,7 +2235,7 @@ test io-29.1 {Tcl_WriteChars, channel not writable} { test io-29.2 {Tcl_WriteChars, empty string} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} puts -nonewline $f "" close $f file size $path(test1) @@ -2243,7 +2243,7 @@ test io-29.2 {Tcl_WriteChars, empty string} { test io-29.3 {Tcl_WriteChars, nonempty string} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} puts -nonewline $f hello close $f file size $path(test1) @@ -2251,7 +2251,7 @@ test io-29.3 {Tcl_WriteChars, nonempty string} { test io-29.4 {Tcl_WriteChars, buffering in full buffering mode} {testchannel} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -buffering full -eofchar {} + chan configure $f -translation lf -buffering full -eofchar {} puts $f hello set l "" lappend l [testchannel outputbuffered $f] @@ -2265,7 +2265,7 @@ test io-29.4 {Tcl_WriteChars, buffering in full buffering mode} {testchannel} { test io-29.5 {Tcl_WriteChars, buffering in line buffering mode} {testchannel} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -buffering line -eofchar {} + chan configure $f -translation lf -buffering line -eofchar {} puts -nonewline $f hello set l "" lappend l [testchannel outputbuffered $f] @@ -2279,7 +2279,7 @@ test io-29.5 {Tcl_WriteChars, buffering in line buffering mode} {testchannel} { test io-29.6 {Tcl_WriteChars, buffering in no buffering mode} {testchannel} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -buffering none -eofchar {} + chan configure $f -translation lf -buffering none -eofchar {} puts -nonewline $f hello set l "" lappend l [testchannel outputbuffered $f] @@ -2293,7 +2293,7 @@ test io-29.6 {Tcl_WriteChars, buffering in no buffering mode} {testchannel} { test io-29.7 {Tcl_Flush, full buffering} {testchannel} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -buffering full -eofchar {} + chan configure $f -translation lf -buffering full -eofchar {} puts -nonewline $f hello set l "" lappend l [testchannel outputbuffered $f] @@ -2310,7 +2310,7 @@ test io-29.7 {Tcl_Flush, full buffering} {testchannel} { test io-29.8 {Tcl_Flush, full buffering} {testchannel} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -buffering line + chan configure $f -translation lf -buffering line puts -nonewline $f hello set l "" lappend l [testchannel outputbuffered $f] @@ -2333,7 +2333,7 @@ test io-29.9 {Tcl_Flush, channel not writable} { test io-29.10 {Tcl_WriteChars, looping and buffering} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} set f2 [open $path(longfile) r] for {set x 0} {$x < 10} {incr x} { puts $f1 [gets $f2] @@ -2345,7 +2345,7 @@ test io-29.10 {Tcl_WriteChars, looping and buffering} { test io-29.11 {Tcl_WriteChars, no newline, implicit flush} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -eofchar {} + chan configure $f1 -eofchar {} set f2 [open $path(longfile) r] for {set x 0} {$x < 10} {incr x} { puts -nonewline $f1 [gets $f2] @@ -2371,7 +2371,7 @@ test io-29.12 {Tcl_WriteChars on a pipe} {stdio openpipe} { for {set x 0} {$x < 10} {incr x} { set l1 [gets $f1] set l2 [gets $f2] - if {"$l1" != "$l2"} { + if {$l1 ne $l2} { set y broken } } @@ -2390,18 +2390,18 @@ test io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio openpipe} { close $f1 set y ok set f1 [open "|[list [interpreter] $path(pipe)]" r+] - fconfigure $f1 -buffering line + chan configure $f1 -buffering line set f2 [open $path(longfile) r] set line [gets $f2] puts $f1 $line set backline [gets $f1] - if {"$line" != "$backline"} { + if {$line ne $backline} { set y broken } set line [gets $f2] puts $f1 $line set backline [gets $f1] - if {"$line" != "$backline"} { + if {$line ne $backline} { set y broken } close $f1 @@ -2440,7 +2440,7 @@ test io-29.16 {Tcl_Flush on pipe opened only for reading} {stdio openpipe} { test io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf + chan configure $f1 -translation lf puts $f1 hello puts $f1 hello puts $f1 hello @@ -2453,7 +2453,7 @@ test io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} { file delete $path(test1) set x "" set f1 [open $path(test1) w] - fconfigure $f1 -translation lf + chan configure $f1 -translation lf puts $f1 hello puts $f1 hello puts $f1 hello @@ -2471,7 +2471,7 @@ test io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} { test io-29.19 {Explicit and implicit flushes} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} set x "" puts $f1 hello puts $f1 hello @@ -2489,7 +2489,7 @@ test io-29.19 {Explicit and implicit flushes} { test io-29.20 {Implicit flush when buffer is full} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} set line "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" for {set x 0} {$x < 100} {incr x} { puts $f1 $line @@ -2522,7 +2522,7 @@ test io-29.22 {Tcl_Flush called at other end of pipe} {stdio openpipe} { file delete $path(pipe) set f1 [open $path(pipe) w] puts $f1 { - fconfigure stdout -buffering full + chan configure stdout -buffering full puts hello puts hello flush stdout @@ -2576,7 +2576,7 @@ test io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} { close $f set x } "{} {Line 1\nLine 2}" -test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio openpipe fileevent} { +test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio openpipe chan event} { file delete $path(test3) set f [open "|[list [interpreter] $path(cat) | [interpreter] $path(cat) > $path(test3)]" w] puts $f "Line 1" @@ -2627,7 +2627,7 @@ test io-29.27 {Tcl_Flush on closed pipeline} {stdio openpipe} { test io-29.28 {Tcl_WriteChars, lf mode} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts $f hello\nthere\nand\nhere flush $f set s [file size $path(test1)] @@ -2637,7 +2637,7 @@ test io-29.28 {Tcl_WriteChars, lf mode} { test io-29.29 {Tcl_WriteChars, cr mode} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar {} + chan configure $f -translation cr -eofchar {} puts $f hello\nthere\nand\nhere close $f file size $path(test1) @@ -2645,7 +2645,7 @@ test io-29.29 {Tcl_WriteChars, cr mode} { test io-29.30 {Tcl_WriteChars, crlf mode} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar {} + chan configure $f -translation crlf -eofchar {} puts $f hello\nthere\nand\nhere close $f file size $path(test1) @@ -2657,7 +2657,7 @@ test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { file delete $path(output) set f [open $path(pipe) w] puts $f "set f \[[list open $path(output) w]]" - puts $f {fconfigure $f -translation lf} + puts $f {chan configure $f -translation lf} set x [list while {![eof stdin]}] set x "$x {" puts $f $x @@ -2673,7 +2673,7 @@ test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { set f [open $path(output) w] close $f set f [open "|[list [interpreter] $path(pipe)]" r+] - fconfigure $f -blocking off + chan configure $f -blocking off puts -nonewline $f $x close $f set counter 0 @@ -2700,7 +2700,7 @@ test io-29.32 {Tcl_WriteChars, background flush to slow reader} \ file delete $path(output) set f [open $path(pipe) w] puts $f "set f \[[list open $path(output) w]]" - puts $f {fconfigure $f -translation lf} + puts $f {chan configure $f -translation lf} set x [list while {![eof stdin]}] set x "$x \{" puts $f $x @@ -2717,7 +2717,7 @@ test io-29.32 {Tcl_WriteChars, background flush to slow reader} \ set f [open $path(output) w] close $f set f [open "|[list [interpreter] $path(pipe)]" r+] - fconfigure $f -blocking off + chan configure $f -blocking off puts -nonewline $f $x close $f set counter 0 @@ -2734,7 +2734,7 @@ test io-29.32 {Tcl_WriteChars, background flush to slow reader} \ test io-29.33 {Tcl_Flush, implicit flush on exit} {exec} { set f [open $path(script) w] puts $f "set f \[[list open $path(test1) w]]" - puts $f {fconfigure $f -translation lf + puts $f {chan configure $f -translation lf puts $f hello puts $f bye puts $f strange @@ -2750,7 +2750,7 @@ set path(script2) [makeFile {} script2] test io-29.33b {TIP#398, no implicit flush of nonblocking on exit} {exec} { set f [open $path(script) w] puts $f { - fconfigure stdout -blocking 0 + chan configure stdout -blocking 0 puts -nonewline stdout [string repeat A 655360] flush stdout } @@ -2760,13 +2760,13 @@ test io-29.33b {TIP#398, no implicit flush of nonblocking on exit} {exec} { close $f set t1 [clock milliseconds] set ff [open "|[list [interpreter] $path(script2)]" w] - catch {unset ::env(TCL_FLUSH_NONBLOCKING_ON_EXIT)} + unset -nocomplain ::env(TCL_FLUSH_NONBLOCKING_ON_EXIT) exec [interpreter] $path(script) >@ $ff set t2 [clock milliseconds] close $ff - expr {($t2-$t1)/2000 ? $t2-$t1 : 0} + expr {(($t2 - $t1) / 2000) ? ($t2 - $t1) : 0} } 0 -test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac fileevent} { +test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac chan event} { variable c 0 variable x running set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz @@ -2777,8 +2777,8 @@ test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMa } proc accept {s a p} { variable x - fileevent $s readable [namespace code [list readit $s]] - fconfigure $s -blocking off + chan event $s readable [namespace code [list readit $s]] + chan configure $s -blocking off set x accepted } proc readit {s} { @@ -2789,21 +2789,21 @@ test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMa if {[eof $s]} { close $s set x done - } elseif {([string length $l] > 0) || ![fblocked $s]} { + } elseif {([string length $l] > 0) || (![chan blocked $s])} { incr c } } set ss [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - set cs [socket 127.0.0.1 [lindex [fconfigure $ss -sockname] 2]] + set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]] vwait [namespace which -variable x] - fconfigure $cs -blocking off + chan configure $cs -blocking off writelots $cs $l close $cs close $ss vwait [namespace which -variable x] set c } 2000 -test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotMac fileevent} { +test io-29.35 {Tcl_Close vs chan event vs multiple interpreters} {socket tempNotMac fileevent} { # On Mac, this test screws up sockets such that subsequent tests using port 2828 # either cause errors or panic(). @@ -2816,7 +2816,7 @@ test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotM puts $s hello close $s } - set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] + set c [socket 127.0.0.1 [lindex [chan configure $s -sockname] 2]] interp share {} $c x interp share {} $c y close $c @@ -2836,8 +2836,8 @@ test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotM } } } - x eval "fileevent $c readable \{readit $c\}" - y eval "fileevent $c readable \{readit $c\}" + x eval "chan event $c readable \{readit $c\}" + y eval "chan event $c readable \{readit $c\}" y eval [list close $c] update close $s @@ -2850,11 +2850,11 @@ test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotM test io-30.1 {Tcl_Write lf, Tcl_Read lf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation lf + chan configure $f -translation lf set x [read $f] close $f set x @@ -2862,11 +2862,11 @@ test io-30.1 {Tcl_Write lf, Tcl_Read lf} { test io-30.2 {Tcl_Write lf, Tcl_Read cr} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation cr + chan configure $f -translation cr set x [read $f] close $f set x @@ -2874,11 +2874,11 @@ test io-30.2 {Tcl_Write lf, Tcl_Read cr} { test io-30.3 {Tcl_Write lf, Tcl_Read crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [read $f] close $f set x @@ -2886,11 +2886,11 @@ test io-30.3 {Tcl_Write lf, Tcl_Read crlf} { test io-30.4 {Tcl_Write cr, Tcl_Read cr} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation cr + chan configure $f -translation cr set x [read $f] close $f set x @@ -2898,11 +2898,11 @@ test io-30.4 {Tcl_Write cr, Tcl_Read cr} { test io-30.5 {Tcl_Write cr, Tcl_Read lf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation lf + chan configure $f -translation lf set x [read $f] close $f set x @@ -2910,11 +2910,11 @@ test io-30.5 {Tcl_Write cr, Tcl_Read lf} { test io-30.6 {Tcl_Write cr, Tcl_Read crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [read $f] close $f set x @@ -2922,11 +2922,11 @@ test io-30.6 {Tcl_Write cr, Tcl_Read crlf} { test io-30.7 {Tcl_Write crlf, Tcl_Read crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation crlf + chan configure $f -translation crlf set x [read $f] close $f set x @@ -2934,11 +2934,11 @@ test io-30.7 {Tcl_Write crlf, Tcl_Read crlf} { test io-30.8 {Tcl_Write crlf, Tcl_Read lf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation lf + chan configure $f -translation lf set x [read $f] close $f set x @@ -2946,11 +2946,11 @@ test io-30.8 {Tcl_Write crlf, Tcl_Read lf} { test io-30.9 {Tcl_Write crlf, Tcl_Read cr} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation cr + chan configure $f -translation cr set x [read $f] close $f set x @@ -2958,12 +2958,12 @@ test io-30.9 {Tcl_Write crlf, Tcl_Read cr} { test io-30.10 {Tcl_Write lf, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] set c [read $f] - set x [fconfigure $f -translation] + set x [chan configure $f -translation] close $f list $c $x } {{hello @@ -2974,12 +2974,12 @@ here test io-30.11 {Tcl_Write cr, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] set c [read $f] - set x [fconfigure $f -translation] + set x [chan configure $f -translation] close $f list $c $x } {{hello @@ -2990,12 +2990,12 @@ here test io-30.12 {Tcl_Write crlf, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] set c [read $f] - set x [fconfigure $f -translation] + set x [chan configure $f -translation] close $f list $c $x } {{hello @@ -3006,7 +3006,7 @@ here test io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf set line "123456789ABCDE" ;# 14 char plus crlf puts -nonewline $f x ;# shift crlf across block boundary for {set i 0} {$i < 700} {incr i} { @@ -3014,15 +3014,15 @@ test io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} { } close $f set f [open $path(test1) r] - fconfigure $f -translation auto + chan configure $f -translation auto set c [read $f] close $f string length $c -} [expr 700*15+1] +} [expr {(700 * 15) + 1}] test io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf set line "123456789ABCDE" ;# 14 char plus crlf puts -nonewline $f x ;# shift crlf across block boundary for {set i 0} {$i < 700} {incr i} { @@ -3030,19 +3030,19 @@ test io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} { } close $f set f [open $path(test1) r] - fconfigure $f -translation crlf + chan configure $f -translation crlf set c [read $f] close $f string length $c -} [expr 700*15+1] +} [expr {(700 * 15) + 1}] test io-30.15 {Tcl_Write mixed, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello\nthere\nand\rhere close $f set f [open $path(test1) r] - fconfigure $f -translation auto + chan configure $f -translation auto set c [read $f] close $f set c @@ -3054,11 +3054,11 @@ here test io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f hello\nthere\nand\rhere\n\x1a close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + chan configure $f -eofchar \x1a -translation auto set c [read $f] close $f set c @@ -3070,11 +3070,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 -eofchar \x1a -translation lf + chan configure $f -eofchar \x1a -translation lf puts $f hello\nthere\nand\rhere close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + chan configure $f -eofchar \x1a -translation auto set c [read $f] close $f set c @@ -3086,12 +3086,12 @@ here test io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set s [format "abc\ndef\n%cghi\nqrs" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + chan configure $f -eofchar \x1a -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3106,12 +3106,12 @@ test io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} { test io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set s [format "abc\ndef\n%cghi\nqrs" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + chan configure $f -eofchar \x1a -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3126,12 +3126,12 @@ test io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} { test io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set s [format "abc\ndef\n%cghi\nqrs" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set l "" lappend l [gets $f] lappend l [gets $f] @@ -3148,12 +3148,12 @@ test io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} { test io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set s [format "abc\ndef\n%cghi\nqrs" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar {} + chan configure $f -translation cr -eofchar {} set l "" set x [gets $f] lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"] @@ -3166,12 +3166,12 @@ test io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} { test io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set s [format "abc\ndef\n%cghi\nqrs" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar {} + chan configure $f -translation crlf -eofchar {} set l "" set x [gets $f] lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"] @@ -3184,12 +3184,12 @@ test io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} { test io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set c [format abc\ndef\n%cqrs\ntuv 26] puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1a set c [string length [read $f]] set e [eof $f] close $f @@ -3198,12 +3198,12 @@ test io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} { test io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set c [format abc\ndef\n%cqrs\ntuv 26] puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1a + chan configure $f -translation lf -eofchar \x1a set c [string length [read $f]] set e [eof $f] close $f @@ -3212,12 +3212,12 @@ test io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} { test io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr set c [format abc\ndef\n%cqrs\ntuv 26] puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1a set c [string length [read $f]] set e [eof $f] close $f @@ -3226,12 +3226,12 @@ test io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} { test io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr set c [format abc\ndef\n%cqrs\ntuv 26] puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1a + chan configure $f -translation cr -eofchar \x1a set c [string length [read $f]] set e [eof $f] close $f @@ -3240,12 +3240,12 @@ test io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} { test io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf set c [format abc\ndef\n%cqrs\ntuv 26] puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1a set c [string length [read $f]] set e [eof $f] close $f @@ -3254,12 +3254,12 @@ test io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} { test io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf set c [format abc\ndef\n%cqrs\ntuv 26] puts $f $c close $f set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1a + chan configure $f -translation crlf -eofchar \x1a set c [string length [read $f]] set e [eof $f] close $f @@ -3271,88 +3271,88 @@ test io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} { test io-31.1 {Tcl_Write lf, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] set l "" lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] close $f set l } {hello 6 auto there 12 auto} test io-31.2 {Tcl_Write cr, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] set l "" lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] close $f set l } {hello 6 auto there 12 auto} test io-31.3 {Tcl_Write crlf, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] set l "" lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] close $f set l } {hello 7 auto there 14 auto} test io-31.4 {Tcl_Write lf, Tcl_Gets lf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation lf + chan configure $f -translation lf set l "" lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] close $f set l } {hello 6 lf there 12 lf} test io-31.5 {Tcl_Write lf, Tcl_Gets cr} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation cr + chan configure $f -translation cr set l "" lappend l [string length [gets $f]] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] close $f set l @@ -3360,19 +3360,19 @@ test io-31.5 {Tcl_Write lf, Tcl_Gets cr} { test io-31.6 {Tcl_Write lf, Tcl_Gets crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation crlf + chan configure $f -translation crlf set l "" lappend l [string length [gets $f]] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] close $f set l @@ -3380,19 +3380,19 @@ test io-31.6 {Tcl_Write lf, Tcl_Gets crlf} { test io-31.7 {Tcl_Write cr, Tcl_Gets cr} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation cr + chan configure $f -translation cr set l "" lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] close $f set l @@ -3400,19 +3400,19 @@ test io-31.7 {Tcl_Write cr, Tcl_Gets cr} { test io-31.8 {Tcl_Write cr, Tcl_Gets lf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation lf + chan configure $f -translation lf set l "" lappend l [string length [gets $f]] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] close $f set l @@ -3420,19 +3420,19 @@ test io-31.8 {Tcl_Write cr, Tcl_Gets lf} { test io-31.9 {Tcl_Write cr, Tcl_Gets crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation crlf + chan configure $f -translation crlf set l "" lappend l [string length [gets $f]] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] close $f set l @@ -3440,19 +3440,19 @@ test io-31.9 {Tcl_Write cr, Tcl_Gets crlf} { test io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation crlf + chan configure $f -translation crlf set l "" lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] close $f set l @@ -3460,19 +3460,19 @@ test io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} { test io-31.11 {Tcl_Write crlf, Tcl_Gets cr} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation cr + chan configure $f -translation cr set l "" lappend l [gets $f] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] lappend l [string length [gets $f]] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] close $f set l @@ -3480,19 +3480,19 @@ test io-31.11 {Tcl_Write crlf, Tcl_Gets cr} { test io-31.12 {Tcl_Write crlf, Tcl_Gets lf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf puts $f hello\nthere\nand\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation lf + chan configure $f -translation lf set l "" lappend l [string length [gets $f]] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] lappend l [string length [gets $f]] lappend l [tell $f] - lappend l [fconfigure $f -translation] + lappend l [chan configure $f -translation] lappend l [eof $f] close $f set l @@ -3500,8 +3500,8 @@ test io-31.12 {Tcl_Write crlf, Tcl_Gets lf} { test io-31.13 {binary mode is synonym of lf mode} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation binary - set x [fconfigure $f -translation] + chan configure $f -translation binary + set x [chan configure $f -translation] close $f set x } lf @@ -3512,11 +3512,11 @@ test io-31.13 {binary mode is synonym of lf mode} { test io-31.14 {Tcl_Write mixed, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f hello\nthere\rand\r\nhere close $f set f [open $path(test1) r] - fconfigure $f -translation auto + chan configure $f -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3531,11 +3531,11 @@ test io-31.14 {Tcl_Write mixed, Tcl_Gets auto} { test io-31.15 {Tcl_Write mixed, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f hello\nthere\rand\r\nhere\r close $f set f [open $path(test1) r] - fconfigure $f -translation auto + chan configure $f -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3550,7 +3550,7 @@ test io-31.15 {Tcl_Write mixed, Tcl_Gets auto} { test io-31.16 {Tcl_Write mixed, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f hello\nthere\rand\r\nhere\n close $f set f [open $path(test1) r] @@ -3568,11 +3568,11 @@ test io-31.16 {Tcl_Write mixed, Tcl_Gets auto} { test io-31.17 {Tcl_Write mixed, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f hello\nthere\rand\r\nhere\r\n close $f set f [open $path(test1) r] - fconfigure $f -translation auto + chan configure $f -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3587,12 +3587,12 @@ test io-31.17 {Tcl_Write mixed, Tcl_Gets auto} { test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set s [format "hello\nthere\nand\rhere\n\%c" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + chan configure $f -eofchar \x1a -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3607,11 +3607,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 -eofchar \x1a -translation lf + chan configure $f -eofchar \x1a -translation lf puts $f hello\nthere\nand\rhere close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + chan configure $f -eofchar \x1a -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3626,13 +3626,13 @@ test io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} { test io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a - fconfigure $f -translation auto + chan configure $f -eofchar \x1a + chan configure $f -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3645,12 +3645,12 @@ test io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} { test io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -eofchar \x1a -translation auto + chan configure $f -eofchar \x1a -translation auto set l "" lappend l [gets $f] lappend l [gets $f] @@ -3663,12 +3663,12 @@ test io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} { test io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set l "" lappend l [gets $f] lappend l [gets $f] @@ -3685,12 +3685,12 @@ test io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} { test io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar {} + chan configure $f -translation cr -eofchar {} set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar {} + chan configure $f -translation cr -eofchar {} set l "" lappend l [gets $f] lappend l [gets $f] @@ -3707,12 +3707,12 @@ test io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} { test io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar {} + chan configure $f -translation crlf -eofchar {} set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar {} + chan configure $f -translation crlf -eofchar {} set l "" lappend l [gets $f] lappend l [gets $f] @@ -3729,12 +3729,12 @@ test io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} { test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1a set l "" lappend l [gets $f] lappend l [gets $f] @@ -3747,12 +3747,12 @@ test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} { test io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1a + chan configure $f -translation lf -eofchar \x1a set l "" lappend l [gets $f] lappend l [gets $f] @@ -3765,12 +3765,12 @@ test io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} { test io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar {} + chan configure $f -translation cr -eofchar {} set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1a set l "" lappend l [gets $f] lappend l [gets $f] @@ -3783,12 +3783,12 @@ test io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} { test io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar {} + chan configure $f -translation cr -eofchar {} set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1a + chan configure $f -translation cr -eofchar \x1a set l "" lappend l [gets $f] lappend l [gets $f] @@ -3801,12 +3801,12 @@ test io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} { test io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar {} + chan configure $f -translation crlf -eofchar {} set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1a set l "" lappend l [gets $f] lappend l [gets $f] @@ -3819,12 +3819,12 @@ test io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} { test io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar {} + chan configure $f -translation crlf -eofchar {} set s [format "abc\ndef\n%cqrs\ntuv" 26] puts $f $s close $f set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1a + chan configure $f -translation crlf -eofchar \x1a set l "" lappend l [gets $f] lappend l [gets $f] @@ -3837,7 +3837,7 @@ test io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} { test io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf set line "123456789ABCDE" ;# 14 char plus crlf puts -nonewline $f x ;# shift crlf across block boundary for {set i 0} {$i < 700} {incr i} { @@ -3845,18 +3845,18 @@ test io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} { } close $f set f [open $path(test1) r] - fconfigure $f -translation crlf + chan configure $f -translation crlf set c "" while {[gets $f line] >= 0} { append c $line\n } close $f string length $c -} [expr 700*15+1] +} [expr {(700 * 15) + 1}] test io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf set line "123456789ABCDE" ;# 14 char plus crlf puts -nonewline $f x ;# shift crlf across block boundary for {set i 0} {$i < 700} {incr i} { @@ -3864,14 +3864,14 @@ test io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} { } close $f set f [open $path(test1) r] - fconfigure $f -translation auto + chan configure $f -translation auto set c "" while {[gets $f line] >= 0} { append c $line\n } close $f string length $c -} [expr 700*15+1] +} [expr {(700 * 15) + 1}] # Test Tcl_Read and buffering. @@ -3897,7 +3897,7 @@ test io-32.4 {Tcl_Read, positive byte count} { } 1024 test io-32.5 {Tcl_Read, multiple buffers} { set f [open $path(longfile) r] - fconfigure $f -buffersize 100 + chan configure $f -buffersize 100 set x [read $f 1024] set s [string length $x] unset x @@ -3918,7 +3918,7 @@ test io-32.6 {Tcl_Read, very large read} { } ok test io-32.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} { set f1 [open $path(longfile) r] - fconfigure $f1 -blocking off + chan configure $f1 -blocking off set z [read $f1 20] close $f1 set l [string length $z] @@ -3930,7 +3930,7 @@ test io-32.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} { } ok test io-32.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} { set f1 [open $path(longfile) r] - fconfigure $f1 -blocking off + chan configure $f1 -blocking off set z [read $f1 1000000] close $f1 set x ok @@ -4058,7 +4058,7 @@ test io-33.1 {Tcl_Gets, reading what was written} { set f1 [open $path(test1) r] set x [gets $f1] set z ok - if {"$x" != "$y"} { + if {$x ne $y} { set z broken } close $f1 @@ -4086,7 +4086,7 @@ test io-33.3 {Tcl_Gets from pipe} {stdio openpipe} { set x [gets $f1] close $f1 set z ok - if {"$x" != "hello"} { + if {$x ne "hello"} { set z broken } set z @@ -4132,7 +4132,7 @@ test io-33.7 {Tcl_Gets and bad variable} { puts $f "Line 1" puts $f "Line 2" close $f - catch {unset x} + unset -nocomplain x set x 24 set f [open $path(test3) r] set result [list [catch {gets $f x(0)} msg] $msg] @@ -4141,39 +4141,39 @@ test io-33.7 {Tcl_Gets and bad variable} { } {1 {can't set "x(0)": variable isn't array}} test io-33.8 {Tcl_Gets, exercising double buffering} { set f [open $path(test3) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set x "" for {set y 0} {$y < 99} {incr y} {set x "a$x"} for {set y 0} {$y < 100} {incr y} {puts $f $x} close $f set f [open $path(test3) r] - fconfigure $f -translation lf + chan configure $f -translation lf for {set y 0} {$y < 100} {incr y} {gets $f} close $f set y } 100 test io-33.9 {Tcl_Gets, exercising double buffering} { set f [open $path(test3) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set x "" for {set y 0} {$y < 99} {incr y} {set x "a$x"} for {set y 0} {$y < 200} {incr y} {puts $f $x} close $f set f [open $path(test3) r] - fconfigure $f -translation lf + chan configure $f -translation lf for {set y 0} {$y < 200} {incr y} {gets $f} close $f set y } 200 test io-33.10 {Tcl_Gets, exercising double buffering} { set f [open $path(test3) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set x "" for {set y 0} {$y < 99} {incr y} {set x "a$x"} for {set y 0} {$y < 300} {incr y} {puts $f $x} close $f set f [open $path(test3) r] - fconfigure $f -translation lf + chan configure $f -translation lf for {set y 0} {$y < 300} {incr y} {gets $f} close $f set y @@ -4191,7 +4191,7 @@ test io-34.1 {Tcl_Seek to current position at start of file} { test io-34.2 {Tcl_Seek to offset from start} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} puts $f1 "abcdefghijklmnopqrstuvwxyz" puts $f1 "abcdefghijklmnopqrstuvwxyz" close $f1 @@ -4204,7 +4204,7 @@ test io-34.2 {Tcl_Seek to offset from start} { test io-34.3 {Tcl_Seek to end of file} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} puts $f1 "abcdefghijklmnopqrstuvwxyz" puts $f1 "abcdefghijklmnopqrstuvwxyz" close $f1 @@ -4217,7 +4217,7 @@ test io-34.3 {Tcl_Seek to end of file} { test io-34.4 {Tcl_Seek to offset from end of file} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} puts $f1 "abcdefghijklmnopqrstuvwxyz" puts $f1 "abcdefghijklmnopqrstuvwxyz" close $f1 @@ -4230,7 +4230,7 @@ test io-34.4 {Tcl_Seek to offset from end of file} { test io-34.5 {Tcl_Seek to offset from current position} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} puts $f1 "abcdefghijklmnopqrstuvwxyz" puts $f1 "abcdefghijklmnopqrstuvwxyz" close $f1 @@ -4244,7 +4244,7 @@ test io-34.5 {Tcl_Seek to offset from current position} { test io-34.6 {Tcl_Seek to offset from end of file} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} puts $f1 "abcdefghijklmnopqrstuvwxyz" puts $f1 "abcdefghijklmnopqrstuvwxyz" close $f1 @@ -4259,7 +4259,7 @@ test io-34.6 {Tcl_Seek to offset from end of file} { test io-34.7 {Tcl_Seek to offset from end of file, then to current position} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} puts $f1 "abcdefghijklmnopqrstuvwxyz" puts $f1 "abcdefghijklmnopqrstuvwxyz" close $f1 @@ -4282,7 +4282,7 @@ test io-34.8 {Tcl_Seek on pipes: not supported} {stdio openpipe} { test io-34.9 {Tcl_Seek, testing buffered input flushing} { file delete $path(test3) set f [open $path(test3) w] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" close $f set f [open $path(test3) RDWR] @@ -4305,11 +4305,11 @@ test io-34.9 {Tcl_Seek, testing buffered input flushing} { set path(test3) [makeFile {} test3] test io-34.10 {Tcl_Seek testing flushing of buffered input} { set f [open $path(test3) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f xyz\n123 close $f set f [open $path(test3) r+] - fconfigure $f -translation lf + chan configure $f -translation lf set x [gets $f] seek $f 0 current puts $f 456 @@ -4330,11 +4330,11 @@ test io-34.11 {Tcl_Seek testing flushing of buffered output} { } "zzy xyzzy" test io-34.12 {Tcl_Seek testing combination of write, seek back and read} { set f [open $path(test3) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts $f xyz\n123 close $f set f [open $path(test3) a+] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts $f xyzzy flush $f set x [tell $f] @@ -4355,7 +4355,7 @@ test io-34.13 {Tcl_Tell at start of file} { test io-34.14 {Tcl_Tell after seek to end of file} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} puts $f1 "abcdefghijklmnopqrstuvwxyz" puts $f1 "abcdefghijklmnopqrstuvwxyz" close $f1 @@ -4368,7 +4368,7 @@ test io-34.14 {Tcl_Tell after seek to end of file} { test io-34.15 {Tcl_Tell combined with seeking} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} + chan configure $f1 -translation lf -eofchar {} puts $f1 "abcdefghijklmnopqrstuvwxyz" puts $f1 "abcdefghijklmnopqrstuvwxyz" close $f1 @@ -4398,11 +4398,11 @@ test io-34.17 {Tcl_Tell on pipe: always -1} {stdio openpipe} { test io-34.18 {Tcl_Tell combined with seeking and reading} { file delete $path(test2) set f [open $path(test2) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts -nonewline $f "line1\nline2\nline3\nline4\nline5\n" close $f set f [open $path(test2)] - fconfigure $f -translation lf + chan configure $f -translation lf set x [tell $f] read $f 3 lappend x [tell $f] @@ -4417,7 +4417,7 @@ test io-34.18 {Tcl_Tell combined with seeking and reading} { } {0 3 2 12 30} test io-34.19 {Tcl_Tell combined with opening in append mode} { set f [open $path(test3) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts $f "abcdefghijklmnopqrstuvwxyz" puts $f "abcdefghijklmnopqrstuvwxyz" close $f @@ -4444,7 +4444,7 @@ test io-34.20 {Tcl_Tell combined with writing} { test io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} { file delete $path(test3) set f [open $path(test3) w] - fconfigure $f -encoding binary + chan configure $f -encoding binary set l "" lappend l [tell $f] puts -nonewline $f abcdef @@ -4530,7 +4530,7 @@ test io-35.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} { set f [open $path(test1) w] close $f set f [open $path(test1) r] - fconfigure $f -blocking off + chan configure $f -blocking off set l "" lappend l [gets $f] lappend l [eof $f] @@ -4554,12 +4554,12 @@ test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio openpipe} { 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 + chan configure $f -translation lf -eofchar \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 + chan configure $f -translation auto -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4568,12 +4568,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 + chan configure $f -translation lf -eofchar \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 + chan configure $f -translation lf -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4582,12 +4582,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 + chan configure $f -translation cr -eofchar \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 + chan configure $f -translation auto -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4596,12 +4596,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 + chan configure $f -translation cr -eofchar \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 + chan configure $f -translation cr -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4610,12 +4610,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 + chan configure $f -translation crlf -eofchar \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 + chan configure $f -translation auto -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4624,12 +4624,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 + chan configure $f -translation crlf -eofchar \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 + chan configure $f -translation crlf -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4638,13 +4638,13 @@ test io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} { test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set i [format abc\ndef\n%cqrs\nuvw 26] puts $f $i close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4653,13 +4653,13 @@ test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} { test io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} set i [format abc\ndef\n%cqrs\nuvw 26] puts $f $i close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation lf -eofchar \x1a + chan configure $f -translation lf -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4668,13 +4668,13 @@ test io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} { test io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar {} + chan configure $f -translation cr -eofchar {} set i [format abc\ndef\n%cqrs\nuvw 26] puts $f $i close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4683,13 +4683,13 @@ test io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} { test io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr -eofchar {} + chan configure $f -translation cr -eofchar {} set i [format abc\ndef\n%cqrs\nuvw 26] puts $f $i close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation cr -eofchar \x1a + chan configure $f -translation cr -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4698,13 +4698,13 @@ test io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} { test io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar {} + chan configure $f -translation crlf -eofchar {} set i [format abc\ndef\n%cqrs\nuvw 26] puts $f $i close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation auto -eofchar \x1a + chan configure $f -translation auto -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4713,13 +4713,13 @@ test io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} { test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf -eofchar {} + chan configure $f -translation crlf -eofchar {} set i [format abc\ndef\n%cqrs\nuvw 26] puts $f $i close $f set c [file size $path(test1)] set f [open $path(test1) r] - fconfigure $f -translation crlf -eofchar \x1a + chan configure $f -translation crlf -eofchar \x1a set l [string length [read $f]] set e [eof $f] close $f @@ -4733,30 +4733,30 @@ test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} { puts $f1 {puts hello_from_pipe} flush $f1 gets $f1 - fconfigure $f1 -blocking off -buffering full + chan configure $f1 -blocking off -buffering full puts $f1 {puts hello} set x "" lappend x [gets $f1] - lappend x [fblocked $f1] + lappend x [chan blocked $f1] flush $f1 after 200 lappend x [gets $f1] - lappend x [fblocked $f1] + lappend x [chan blocked $f1] lappend x [gets $f1] - lappend x [fblocked $f1] + lappend x [chan blocked $f1] close $f1 set x } {{} 1 hello 0 {} 1} test io-36.2 {Tcl_InputBlocked on blocking pipe} {stdio openpipe} { set f1 [open "|[list [interpreter]]" r+] - fconfigure $f1 -buffering line + chan configure $f1 -buffering line puts $f1 {puts hello_from_pipe} set x "" lappend x [gets $f1] - lappend x [fblocked $f1] + lappend x [chan blocked $f1] puts $f1 {exit} lappend x [gets $f1] - lappend x [fblocked $f1] + lappend x [chan blocked $f1] lappend x [eof $f1] close $f1 set x @@ -4768,11 +4768,11 @@ test io-36.3 {Tcl_InputBlocked vs files, short read} { close $f set f [open $path(test1) r] set l "" - lappend l [fblocked $f] + lappend l [chan blocked $f] lappend l [read $f 3] - lappend l [fblocked $f] + lappend l [chan blocked $f] lappend l [read -nonewline $f] - lappend l [fblocked $f] + lappend l [chan blocked $f] lappend l [eof $f] close $f set l @@ -4790,7 +4790,7 @@ test io-36.4 {Tcl_InputBlocked vs files, event driven read} {fileevent} { close $f set f [open $path(test1) r] set l "" - fileevent $f readable [namespace code [list in $f]] + chan event $f readable [namespace code [list in $f]] variable x vwait [namespace which -variable x] set l @@ -4802,13 +4802,13 @@ test io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles puts $f abcdefghijklmnop close $f set f [open $path(test1) r] - fconfigure $f -blocking off + chan configure $f -blocking off set l "" - lappend l [fblocked $f] + lappend l [chan blocked $f] lappend l [read $f 3] - lappend l [fblocked $f] + lappend l [chan blocked $f] lappend l [read -nonewline $f] - lappend l [fblocked $f] + lappend l [chan blocked $f] lappend l [eof $f] close $f set l @@ -4825,9 +4825,9 @@ test io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles filee puts $f abcdefghijklmnop close $f set f [open $path(test1) r] - fconfigure $f -blocking off + chan configure $f -blocking off set l "" - fileevent $f readable [namespace code [list in $f]] + chan event $f readable [namespace code [list in $f]] variable x vwait [namespace which -variable x] set l @@ -4838,7 +4838,7 @@ test io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles filee test io-37.1 {Tcl_InputBuffered} {testchannel} { set f [open $path(longfile) r] - fconfigure $f -buffersize 4096 + chan configure $f -buffersize 4096 read $f 3 set l "" lappend l [testchannel inputbuffered $f] @@ -4848,7 +4848,7 @@ test io-37.1 {Tcl_InputBuffered} {testchannel} { } {4093 3} test io-37.2 {Tcl_InputBuffered, test input flushing on seek} {testchannel} { set f [open $path(longfile) r] - fconfigure $f -buffersize 4096 + chan configure $f -buffersize 4096 read $f 3 set l "" lappend l [testchannel inputbuffered $f] @@ -4864,26 +4864,26 @@ test io-37.2 {Tcl_InputBuffered, test input flushing on seek} {testchannel} { test io-38.1 {Tcl_GetChannelBufferSize, default buffer size} { set f [open $path(longfile) r] - set s [fconfigure $f -buffersize] + set s [chan configure $f -buffersize] close $f set s } 4096 test io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} { set f [open $path(longfile) r] set l "" - lappend l [fconfigure $f -buffersize] - fconfigure $f -buffersize 10000 - lappend l [fconfigure $f -buffersize] - fconfigure $f -buffersize 1 - lappend l [fconfigure $f -buffersize] - fconfigure $f -buffersize -1 - lappend l [fconfigure $f -buffersize] - fconfigure $f -buffersize 0 - lappend l [fconfigure $f -buffersize] - fconfigure $f -buffersize 100000 - lappend l [fconfigure $f -buffersize] - fconfigure $f -buffersize 10000000 - lappend l [fconfigure $f -buffersize] + lappend l [chan configure $f -buffersize] + chan configure $f -buffersize 10000 + lappend l [chan configure $f -buffersize] + chan configure $f -buffersize 1 + lappend l [chan configure $f -buffersize] + chan configure $f -buffersize -1 + lappend l [chan configure $f -buffersize] + chan configure $f -buffersize 0 + lappend l [chan configure $f -buffersize] + chan configure $f -buffersize 100000 + lappend l [chan configure $f -buffersize] + chan configure $f -buffersize 10000000 + lappend l [chan configure $f -buffersize] close $f set l } {4096 10000 1 1 1 100000 1048576} @@ -4891,9 +4891,9 @@ test io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} { # This test crashes the interp if Bug #427196 is not fixed set chan [open [info script] r] - fconfigure $chan -buffersize 10 + chan configure $chan -buffersize 10 set var [read $chan 2] - fconfigure $chan -buffersize 32 + chan configure $chan -buffersize 32 append var [read $chan] close $chan } {} @@ -4903,7 +4903,7 @@ test io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} { test io-39.1 {Tcl_GetChannelOption} { file delete $path(test1) set f1 [open $path(test1) w] - set x [fconfigure $f1 -blocking] + set x [chan configure $f1 -blocking] close $f1 set x } 1 @@ -4913,15 +4913,15 @@ test io-39.1 {Tcl_GetChannelOption} { test io-39.2 {Tcl_GetChannelOption} { file delete $path(test1) set f1 [open $path(test1) w] - set x [fconfigure $f1 -buffering] + set x [chan configure $f1 -buffering] close $f1 set x } full test io-39.3 {Tcl_GetChannelOption} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -buffering line - set x [fconfigure $f1 -buffering] + chan configure $f1 -buffering line + set x [chan configure $f1 -buffering] close $f1 set x } line @@ -4929,15 +4929,15 @@ test io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} { file delete $path(test1) set f1 [open $path(test1) w] set l "" - lappend l [fconfigure $f1 -buffering] - fconfigure $f1 -buffering line - lappend l [fconfigure $f1 -buffering] - fconfigure $f1 -buffering none - lappend l [fconfigure $f1 -buffering] - fconfigure $f1 -buffering line - lappend l [fconfigure $f1 -buffering] - fconfigure $f1 -buffering full - lappend l [fconfigure $f1 -buffering] + lappend l [chan configure $f1 -buffering] + chan configure $f1 -buffering line + lappend l [chan configure $f1 -buffering] + chan configure $f1 -buffering none + lappend l [chan configure $f1 -buffering] + chan configure $f1 -buffering line + lappend l [chan configure $f1 -buffering] + chan configure $f1 -buffering full + lappend l [chan configure $f1 -buffering] close $f1 set l } {full line none line full} @@ -4945,16 +4945,16 @@ test io-39.5 {Tcl_GetChannelOption, invariance} { file delete $path(test1) set f1 [open $path(test1) w] set l "" - lappend l [fconfigure $f1 -buffering] - lappend l [list [catch {fconfigure $f1 -buffering green} msg] $msg] - lappend l [fconfigure $f1 -buffering] + lappend l [chan configure $f1 -buffering] + lappend l [list [catch {chan configure $f1 -buffering green} msg] $msg] + lappend l [chan configure $f1 -buffering] close $f1 set l } {full {1 {bad value for -buffering: must be one of full, line, or none}} full} test io-39.6 {Tcl_SetChannelOption, multiple options} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -buffering line + chan configure $f1 -translation lf -buffering line puts $f1 hello puts $f1 bye set x [file size $path(test1)] @@ -4964,11 +4964,11 @@ test io-39.6 {Tcl_SetChannelOption, multiple options} { test io-39.7 {Tcl_SetChannelOption, buffering, translation} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf + chan configure $f1 -translation lf puts $f1 hello puts $f1 bye set x "" - fconfigure $f1 -buffering line + chan configure $f1 -buffering line lappend x [file size $path(test1)] puts $f1 really_bye lappend x [file size $path(test1)] @@ -4979,15 +4979,15 @@ test io-39.8 {Tcl_SetChannelOption, different buffering options} { file delete $path(test1) set f1 [open $path(test1) w] set l "" - fconfigure $f1 -translation lf -buffering none -eofchar {} + chan configure $f1 -translation lf -buffering none -eofchar {} puts -nonewline $f1 hello lappend l [file size $path(test1)] puts -nonewline $f1 hello lappend l [file size $path(test1)] - fconfigure $f1 -buffering full + chan configure $f1 -buffering full puts -nonewline $f1 hello lappend l [file size $path(test1)] - fconfigure $f1 -buffering none + chan configure $f1 -buffering none lappend l [file size $path(test1)] puts -nonewline $f1 hello lappend l [file size $path(test1)] @@ -5001,12 +5001,12 @@ test io-39.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} { close $f1 set f1 [open $path(test1) r] set x "" - lappend x [fconfigure $f1 -blocking] - fconfigure $f1 -blocking off - lappend x [fconfigure $f1 -blocking] + lappend x [chan configure $f1 -blocking] + chan configure $f1 -blocking off + lappend x [chan configure $f1 -blocking] lappend x [gets $f1] lappend x [read $f1 1000] - lappend x [fblocked $f1] + lappend x [chan blocked $f1] lappend x [eof $f1] close $f1 set x @@ -5023,24 +5023,24 @@ test io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio openpipe} { close $f1 set x "" set f1 [open "|[list [interpreter] $path(pipe)]" r+] - fconfigure $f1 -blocking off -buffering line - lappend x [fconfigure $f1 -blocking] + chan configure $f1 -blocking off -buffering line + lappend x [chan configure $f1 -blocking] lappend x [gets $f1] - lappend x [fblocked $f1] - fconfigure $f1 -blocking on + lappend x [chan blocked $f1] + chan configure $f1 -blocking on puts $f1 hello - fconfigure $f1 -blocking off + chan configure $f1 -blocking off lappend x [gets $f1] - lappend x [fblocked $f1] - fconfigure $f1 -blocking on + lappend x [chan blocked $f1] + chan configure $f1 -blocking on puts $f1 bye - fconfigure $f1 -blocking off + chan configure $f1 -blocking off lappend x [gets $f1] - lappend x [fblocked $f1] - fconfigure $f1 -blocking on - lappend x [fconfigure $f1 -blocking] + lappend x [chan blocked $f1] + chan configure $f1 -blocking on + lappend x [chan configure $f1 -blocking] lappend x [gets $f1] - lappend x [fblocked $f1] + lappend x [chan blocked $f1] lappend x [eof $f1] lappend x [gets $f1] lappend x [eof $f1] @@ -5050,35 +5050,35 @@ test io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio openpipe} { test io-39.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size clipped to lower bound} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -buffersize -10 - set x [fconfigure $f -buffersize] + chan configure $f -buffersize -10 + set x [chan configure $f -buffersize] close $f set x } 1 test io-39.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size clipped to upper bound} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -buffersize 10000000 - set x [fconfigure $f -buffersize] + chan configure $f -buffersize 10000000 + set x [chan configure $f -buffersize] close $f set x } 1048576 test io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -buffersize 40000 - set x [fconfigure $f -buffersize] + chan configure $f -buffersize 40000 + set x [chan configure $f -buffersize] close $f set x } 40000 test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -encoding {} + chan configure $f -encoding {} puts -nonewline $f \xe7\x89\xa6 close $f set f [open $path(test1) r] - fconfigure $f -encoding utf-8 + chan configure $f -encoding utf-8 set x [read $f] close $f set x @@ -5086,11 +5086,11 @@ test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} { test io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -encoding binary + chan configure $f -encoding binary puts -nonewline $f \xe7\x89\xa6 close $f set f [open $path(test1) r] - fconfigure $f -encoding utf-8 + chan configure $f -encoding utf-8 set x [read $f] close $f set x @@ -5098,26 +5098,26 @@ test io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} { test io-39.16 {Tcl_SetChannelOption: -encoding, errors} { file delete $path(test1) set f [open $path(test1) w] - set result [list [catch {fconfigure $f -encoding foobar} msg] $msg] + set result [list [catch {chan configure $f -encoding foobar} msg] $msg] close $f set result } {1 {unknown encoding "foobar"}} test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio openpipe fileevent} { set f [open "|[list [interpreter] $path(cat)]" r+] - fconfigure $f -encoding binary + chan configure $f -encoding binary puts -nonewline $f "\xe7" flush $f - fconfigure $f -encoding utf-8 -blocking 0 + chan configure $f -encoding utf-8 -blocking 0 variable x {} - fileevent $f readable [namespace code { lappend x [read $f] }] + chan event $f readable [namespace code { lappend x [read $f] }] vwait [namespace which -variable x] after 300 [namespace code { lappend x timeout }] vwait [namespace which -variable x] - fconfigure $f -encoding utf-8 + chan configure $f -encoding utf-8 vwait [namespace which -variable x] after 300 [namespace code { lappend x timeout }] vwait [namespace which -variable x] - fconfigure $f -encoding binary + chan configure $f -encoding binary vwait [namespace which -variable x] after 300 [namespace code { lappend x timeout }] vwait [namespace which -variable x] @@ -5128,11 +5128,11 @@ test io-39.18 {Tcl_SetChannelOption, setting read mode independently} \ {socket} { proc accept {s a p} {close $s} set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $s1 -sockname] 2] + set port [lindex [chan configure $s1 -sockname] 2] set s2 [socket 127.0.0.1 $port] update - fconfigure $s2 -translation {auto lf} - set modes [fconfigure $s2 -translation] + chan configure $s2 -translation {auto lf} + set modes [chan configure $s2 -translation] close $s1 close $s2 set modes @@ -5141,11 +5141,11 @@ test io-39.19 {Tcl_SetChannelOption, setting read mode independently} \ {socket} { proc accept {s a p} {close $s} set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $s1 -sockname] 2] + set port [lindex [chan configure $s1 -sockname] 2] set s2 [socket 127.0.0.1 $port] update - fconfigure $s2 -translation {auto crlf} - set modes [fconfigure $s2 -translation] + chan configure $s2 -translation {auto crlf} + set modes [chan configure $s2 -translation] close $s1 close $s2 set modes @@ -5154,11 +5154,11 @@ test io-39.20 {Tcl_SetChannelOption, setting read mode independently} \ {socket} { proc accept {s a p} {close $s} set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $s1 -sockname] 2] + set port [lindex [chan configure $s1 -sockname] 2] set s2 [socket 127.0.0.1 $port] update - fconfigure $s2 -translation {auto cr} - set modes [fconfigure $s2 -translation] + chan configure $s2 -translation {auto cr} + set modes [chan configure $s2 -translation] close $s1 close $s2 set modes @@ -5167,11 +5167,11 @@ test io-39.21 {Tcl_SetChannelOption, setting read mode independently} \ {socket} { proc accept {s a p} {close $s} set s1 [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $s1 -sockname] 2] + set port [lindex [chan configure $s1 -sockname] 2] set s2 [socket 127.0.0.1 $port] update - fconfigure $s2 -translation {auto auto} - set modes [fconfigure $s2 -translation] + chan configure $s2 -translation {auto auto} + set modes [chan configure $s2 -translation] close $s1 close $s2 set modes @@ -5180,11 +5180,11 @@ test io-39.22 {Tcl_SetChannelOption, invariance} {unix} { file delete $path(test1) set f1 [open $path(test1) w+] set l "" - lappend l [fconfigure $f1 -eofchar] - fconfigure $f1 -eofchar {ON GO} - lappend l [fconfigure $f1 -eofchar] - fconfigure $f1 -eofchar D - lappend l [fconfigure $f1 -eofchar] + lappend l [chan configure $f1 -eofchar] + chan configure $f1 -eofchar {ON GO} + lappend l [chan configure $f1 -eofchar] + chan configure $f1 -eofchar D + lappend l [chan configure $f1 -eofchar] close $f1 set l } {{{} {}} {O G} {D D}} @@ -5192,11 +5192,11 @@ 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} - 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] + chan configure $f1 -eofchar {ON GO} + 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] close $f1 set l } {{O G} {D D} {1 {bad value for -eofchar: should be a list of zero, one, or two elements}}} @@ -5204,7 +5204,7 @@ 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] set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation] + lappend l [chan configure $sock -eofchar] [chan configure $sock -translation] close $sock set l } {{{}} auto} @@ -5212,8 +5212,8 @@ test io-39.24 {Tcl_SetChannelOption, server socket is not readable or writable so we can't change -eofchar or -translation } { set l [list] set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - fconfigure $sock -eofchar D -translation lf - lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation] + chan configure $sock -eofchar D -translation lf + lappend l [chan configure $sock -eofchar] [chan configure $sock -translation] close $sock set l } {{{}} auto} @@ -5252,15 +5252,15 @@ test io-40.3 {POSIX open access modes: CREAT} {unix umask} { close $f file stat $path(test3) stats format "0%o" [expr $stats(mode)&0o777] -} [format %04o [expr {0o666 & ~ $umaskValue}]] +} [format %04o [expr {0o666 & ( ~ $umaskValue )}]] test io-40.4 {POSIX open access modes: CREAT} { file delete $path(test3) set f [open $path(test3) w] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} puts $f xyzzy close $f set f [open $path(test3) {WRONLY CREAT}] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} puts -nonewline $f "ab" close $f set f [open $path(test3) r] @@ -5271,17 +5271,17 @@ test io-40.4 {POSIX open access modes: CREAT} { test io-40.5 {POSIX open access modes: APPEND} { file delete $path(test3) set f [open $path(test3) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts $f xyzzy close $f set f [open $path(test3) {WRONLY APPEND}] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f "new line" seek $f 0 puts $f "abc" close $f set f [open $path(test3) r] - fconfigure $f -translation lf + chan configure $f -translation lf set x "" seek $f 6 current lappend x [gets $f] @@ -5299,7 +5299,7 @@ test io-40.6 {POSIX open access modes: EXCL} -match regexp -body { test io-40.7 {POSIX open access modes: EXCL} { file delete $path(test3) set f [open $path(test3) {WRONLY CREAT EXCL}] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} puts $f "A test line" close $f viewFile test3 @@ -5350,7 +5350,7 @@ test io-40.12 {POSIX open access modes: WRONLY} -match regexp -body { test io-40.13 {POSIX open access modes: WRONLY} { makeFile xyzzy test3 set f [open $path(test3) WRONLY] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} puts -nonewline $f "ab" seek $f 0 current set x [list [catch {gets $f} msg] $msg] @@ -5388,82 +5388,81 @@ test io-40.17 {tilde substitution in open} { } {1 {couldn't find HOME environment variable to expand path}} test io-41.1 {Tcl_FileeventCmd: errors} {fileevent} { - list [catch {fileevent foo} msg] $msg -} {1 {wrong # args: should be "fileevent channelId event ?script?"}} + list [catch {chan event foo} msg] $msg +} {1 {wrong # args: should be "chan event channelId event ?script?"}} test io-41.2 {Tcl_FileeventCmd: errors} {fileevent} { - list [catch {fileevent foo bar baz q} msg] $msg -} {1 {wrong # args: should be "fileevent channelId event ?script?"}} + list [catch {chan event foo bar baz q} msg] $msg +} {1 {wrong # args: should be "chan event channelId event ?script?"}} test io-41.3 {Tcl_FileeventCmd: errors} {fileevent} { - list [catch {fileevent gorp readable} msg] $msg + list [catch {chan event gorp readable} msg] $msg } {1 {can not find channel named "gorp"}} test io-41.4 {Tcl_FileeventCmd: errors} {fileevent} { - list [catch {fileevent gorp writable} msg] $msg + list [catch {chan event gorp writable} msg] $msg } {1 {can not find channel named "gorp"}} test io-41.5 {Tcl_FileeventCmd: errors} {fileevent} { - list [catch {fileevent gorp who-knows} msg] $msg + list [catch {chan event gorp who-knows} msg] $msg } {1 {bad event name "who-knows": must be readable or writable}} # -# Test fileevent on a file +# Test chan event on a file # set path(foo) [makeFile {} foo] set f [open $path(foo) w+] test io-42.1 {Tcl_FileeventCmd: creating, deleting, querying} {fileevent} { - list [fileevent $f readable] [fileevent $f writable] + list [chan event $f readable] [chan event $f writable] } {{} {}} test io-42.2 {Tcl_FileeventCmd: replacing} {fileevent} { - set result {} - fileevent $f r "first script" - lappend result [fileevent $f readable] - fileevent $f r "new script" - lappend result [fileevent $f readable] - fileevent $f r "yet another" - lappend result [fileevent $f readable] - fileevent $f r "" - lappend result [fileevent $f readable] + set result [list] + chan event $f r "first script" + lappend result [chan event $f readable] + chan event $f r "new script" + lappend result [chan event $f readable] + chan event $f r "yet another" + lappend result [chan event $f readable] + chan event $f r "" + lappend result [chan event $f readable] } {{first script} {new script} {yet another} {}} test io-42.3 {Tcl_FileeventCmd: replacing, with NULL chars in script} {fileevent} { - set result {} - fileevent $f r "first scr\0ipt" - lappend result [string length [fileevent $f readable]] - fileevent $f r "new scr\0ipt" - lappend result [string length [fileevent $f readable]] - fileevent $f r "yet ano\0ther" - lappend result [string length [fileevent $f readable]] - fileevent $f r "" - lappend result [fileevent $f readable] + set result [list] + chan event $f r "first scr\0ipt" + lappend result [string length [chan event $f readable]] + chan event $f r "new scr\0ipt" + lappend result [string length [chan event $f readable]] + chan event $f r "yet ano\0ther" + lappend result [string length [chan event $f readable]] + chan event $f r "" + lappend result [chan event $f readable] } {13 11 12 {}} - test io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} {stdio unixExecs fileevent} { - set result {} - fileevent $f readable "script 1" - lappend result [fileevent $f readable] [fileevent $f writable] - fileevent $f writable "write script" - lappend result [fileevent $f readable] [fileevent $f writable] - fileevent $f readable {} - lappend result [fileevent $f readable] [fileevent $f writable] - fileevent $f writable {} - lappend result [fileevent $f readable] [fileevent $f writable] + set result [list] + chan event $f readable "script 1" + lappend result [chan event $f readable] [chan event $f writable] + chan event $f writable "write script" + lappend result [chan event $f readable] [chan event $f writable] + chan event $f readable {} + lappend result [chan event $f readable] [chan event $f writable] + chan event $f writable {} + lappend result [chan event $f readable] [chan event $f writable] } {{script 1} {} {script 1} {write script} {} {write script} {} {}} test io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] } -constraints {stdio unixExecs fileevent openpipe} -body { - set result {} - lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] - fileevent $f r "read f" - fileevent $f2 r "read f2" - fileevent $f3 r "read f3" - lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] - fileevent $f2 r {} - lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] - fileevent $f3 r {} - lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] - fileevent $f r {} - lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r] + set result [list] + lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] + chan event $f r "read f" + chan event $f2 r "read f2" + chan event $f3 r "read f3" + lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] + chan event $f2 r {} + lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] + chan event $f3 r {} + lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] + chan event $f r {} + lappend result [chan event $f r] [chan event $f2 r] [chan event $f3 r] } -cleanup { catch {close $f2} catch {close $f3} @@ -5473,8 +5472,8 @@ test io-44.1 {FileEventProc procedure: normal read event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] } -constraints {stdio unixExecs fileevent openpipe} -body { - fileevent $f2 readable [namespace code { - set x [gets $f2]; fileevent $f2 readable {} + chan event $f2 readable [namespace code { + set x [gets $f2]; chan event $f2 readable {} }] puts $f2 text; flush $f2 variable x initial @@ -5495,11 +5494,11 @@ test io-44.2 {FileEventProc procedure: error in read event} -constraints { set handler [interp bgerror {}] interp bgerror {} [namespace which myHandler] } -body { - fileevent $f2 readable {error bogus} + chan event $f2 readable {error bogus} puts $f2 text; flush $f2 variable x initial vwait [namespace which -variable x] - list $x [fileevent $f2 readable] + list $x [chan event $f2 readable] } -cleanup { interp bgerror {} $handler catch {close $f2} @@ -5509,11 +5508,11 @@ test io-44.3 {FileEventProc procedure: normal write event} -setup { set f2 [open "|[list cat -u]" r+] set f3 [open "|[list cat -u]" r+] } -constraints {stdio unixExecs fileevent openpipe} -body { - fileevent $f2 writable [namespace code { + chan event $f2 writable [namespace code { lappend x "triggered" incr count -1 if {$count <= 0} { - fileevent $f2 writable {} + chan event $f2 writable {} } }] variable x initial @@ -5537,10 +5536,10 @@ test io-44.4 {FileEventProc procedure: eror in write event} -constraints { set handler [interp bgerror {}] interp bgerror {} [namespace which myHandler] } -body { - fileevent $f2 writable {error bad-write} + chan event $f2 writable {error bad-write} variable x initial vwait [namespace which -variable x] - list $x [fileevent $f2 writable] + list $x [chan event $f2 writable] } -cleanup { interp bgerror {} $handler catch {close $f2} @@ -5548,10 +5547,10 @@ test io-44.4 {FileEventProc procedure: eror in write event} -constraints { } -result {bad-write {}} test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fileevent} { set f4 [open "|[list [interpreter] $path(cat) << foo]" r] - fileevent $f4 readable [namespace code { + chan event $f4 readable [namespace code { if {[gets $f4 line] < 0} { lappend x eof - fileevent $f4 readable {} + chan event $f4 readable {} } else { lappend x $line } @@ -5568,9 +5567,9 @@ makeFile "foo bar" foo test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} { set f [open $path(foo) r] - fileevent $f readable [namespace code { + chan event $f readable [namespace code { lappend x "binding triggered: \"[gets $f]\"" - fileevent $f readable {} + chan event $f readable {} }] close $f set x initial @@ -5582,13 +5581,13 @@ test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} { test io-45.2 {DeleteFileEvent, cleanup on close} {fileevent} { set f [open $path(foo) r] set f2 [open $path(foo) r] - fileevent $f readable [namespace code { + chan event $f readable [namespace code { lappend x "f triggered: \"[gets $f]\"" - fileevent $f readable {} + chan event $f readable {} }] - fileevent $f2 readable [namespace code { + chan event $f2 readable [namespace code { lappend x "f2 triggered: \"[gets $f2]\"" - fileevent $f2 readable {} + chan event $f2 readable {} }] close $f variable x initial @@ -5600,22 +5599,22 @@ test io-45.3 {DeleteFileEvent, cleanup on close} {fileevent} { set f [open $path(foo) r] set f2 [open $path(foo) r] set f3 [open $path(foo) r] - fileevent $f readable {f script} - fileevent $f2 readable {f2 script} - fileevent $f3 readable {f3 script} + chan event $f readable {f script} + chan event $f2 readable {f2 script} + chan event $f3 readable {f3 script} set x {} close $f2 - lappend x [catch {fileevent $f readable} msg] $msg \ - [catch {fileevent $f2 readable}] \ - [catch {fileevent $f3 readable} msg] $msg + lappend x [catch {chan event $f readable} msg] $msg \ + [catch {chan event $f2 readable}] \ + [catch {chan event $f3 readable} msg] $msg close $f3 - lappend x [catch {fileevent $f readable} msg] $msg \ - [catch {fileevent $f2 readable}] \ - [catch {fileevent $f3 readable}] + lappend x [catch {chan event $f readable} msg] $msg \ + [catch {chan event $f2 readable}] \ + [catch {chan event $f3 readable}] close $f - lappend x [catch {fileevent $f readable}] \ - [catch {fileevent $f2 readable}] \ - [catch {fileevent $f3 readable}] + lappend x [catch {chan event $f readable}] \ + [catch {chan event $f2 readable}] \ + [catch {chan event $f3 readable}] } {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1} # Execute these tests only if the "testfevent" command is present. @@ -5625,9 +5624,9 @@ test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent} { set script "set f \[[list open $path(foo) r]]\n" append script { set x "no event" - fileevent $f readable [namespace code { + chan event $f readable [namespace code { set x "f triggered: [gets $f]" - fileevent $f readable {} + chan event $f readable {} }] } testfevent cmd $script @@ -5663,36 +5662,36 @@ test io-47.1 {fileevent vs multiple interpreters} {testfevent fileevent} { set f [open $path(foo) r] set f2 [open $path(foo) r] set f3 [open $path(foo) r] - fileevent $f readable {script 1} + chan event $f readable {script 1} testfevent create testfevent share $f2 - testfevent cmd "fileevent $f2 readable {script 2}" - fileevent $f3 readable {sript 3} + testfevent cmd "chan event $f2 readable {script 2}" + chan event $f3 readable {sript 3} set x {} - lappend x [fileevent $f2 readable] + lappend x [chan event $f2 readable] testfevent delete - lappend x [fileevent $f readable] [fileevent $f2 readable] \ - [fileevent $f3 readable] + lappend x [chan event $f readable] [chan event $f2 readable] \ + [chan event $f3 readable] close $f close $f2 close $f3 set x } {{} {script 1} {} {sript 3}} -test io-47.2 {deleting fileevent on interpreter delete} {testfevent fileevent} { +test io-47.2 {deleting chan event on interpreter delete} {testfevent fileevent} { set f [open $path(foo) r] set f2 [open $path(foo) r] set f3 [open $path(foo) r] set f4 [open $path(foo) r] - fileevent $f readable {script 1} + chan event $f readable {script 1} testfevent create testfevent share $f2 testfevent share $f3 - testfevent cmd "fileevent $f2 readable {script 2} - fileevent $f3 readable {script 3}" - fileevent $f4 readable {script 4} + testfevent cmd "chan event $f2 readable {script 2} + chan event $f3 readable {script 3}" + chan event $f4 readable {script 4} testfevent delete - set x [list [fileevent $f readable] [fileevent $f2 readable] \ - [fileevent $f3 readable] [fileevent $f4 readable]] + set x [list [chan event $f readable] [chan event $f2 readable] \ + [chan event $f3 readable] [chan event $f4 readable]] close $f close $f2 close $f3 @@ -5707,13 +5706,13 @@ test io-47.3 {deleting fileevent on interpreter delete} {testfevent fileevent} { testfevent create testfevent share $f3 testfevent share $f4 - fileevent $f readable {script 1} - fileevent $f2 readable {script 2} - testfevent cmd "fileevent $f3 readable {script 3} - fileevent $f4 readable {script 4}" + chan event $f readable {script 1} + chan event $f2 readable {script 2} + testfevent cmd "chan event $f3 readable {script 3} + chan event $f4 readable {script 4}" testfevent delete - set x [list [fileevent $f readable] [fileevent $f2 readable] \ - [fileevent $f3 readable] [fileevent $f4 readable]] + set x [list [chan event $f readable] [chan event $f2 readable] \ + [chan event $f3 readable] [chan event $f4 readable]] close $f close $f2 close $f3 @@ -5725,12 +5724,12 @@ test io-47.4 {file events on shared files and multiple interpreters} {testfevent set f2 [open $path(foo) r] testfevent create testfevent share $f - testfevent cmd "fileevent $f readable {script 1}" - fileevent $f readable {script 2} - fileevent $f2 readable {script 3} - set x [list [fileevent $f2 readable] \ - [testfevent cmd "fileevent $f readable"] \ - [fileevent $f readable]] + testfevent cmd "chan event $f readable {script 1}" + chan event $f readable {script 2} + chan event $f2 readable {script 3} + set x [list [chan event $f2 readable] \ + [testfevent cmd "chan event $f readable"] \ + [chan event $f readable]] testfevent delete close $f close $f2 @@ -5740,11 +5739,11 @@ test io-47.5 {file events on shared files, deleting file events} {testfevent fil set f [open $path(foo) r] testfevent create testfevent share $f - testfevent cmd "fileevent $f readable {script 1}" - fileevent $f readable {script 2} - testfevent cmd "fileevent $f readable {}" - set x [list [testfevent cmd "fileevent $f readable"] \ - [fileevent $f readable]] + testfevent cmd "chan event $f readable {script 1}" + chan event $f readable {script 2} + testfevent cmd "chan event $f readable {}" + set x [list [testfevent cmd "chan event $f readable"] \ + [chan event $f readable]] testfevent delete close $f set x @@ -5753,11 +5752,11 @@ test io-47.6 {file events on shared files, deleting file events} {testfevent fil set f [open $path(foo) r] testfevent create testfevent share $f - testfevent cmd "fileevent $f readable {script 1}" - fileevent $f readable {script 2} - fileevent $f readable {} - set x [list [testfevent cmd "fileevent $f readable"] \ - [fileevent $f readable]] + testfevent cmd "chan event $f readable {script 1}" + chan event $f readable {script 2} + chan event $f readable {} + set x [list [testfevent cmd "chan event $f readable"] \ + [chan event $f readable]] testfevent delete close $f set x @@ -5774,7 +5773,7 @@ test io-48.1 {testing readability conditions} {fileevent} { puts $f abcdefg close $f set f [open $path(bar) r] - fileevent $f readable [namespace code [list consume $f]] + chan event $f readable [namespace code [list consume $f]] proc consume {f} { variable l variable x @@ -5800,8 +5799,8 @@ test io-48.2 {testing readability conditions} {nonBlockFiles fileevent} { puts $f abcdefg close $f set f [open $path(bar) r] - fileevent $f readable [namespace code [list consume $f]] - fconfigure $f -blocking off + chan event $f readable [namespace code [list consume $f]] + chan configure $f -blocking off proc consume {f} { variable x variable l @@ -5839,9 +5838,9 @@ test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles openpipe } close $f set f [open "|[list [interpreter]]" r+] - fileevent $f readable [namespace code [list consume $f]] - fconfigure $f -buffering line - fconfigure $f -blocking off + chan event $f readable [namespace code [list consume $f]] + chan configure $f -buffering line + chan configure $f -blocking off proc consume {f} { variable l variable x @@ -5849,9 +5848,9 @@ test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles openpipe set x done } else { gets $f - lappend l [fblocked $f] + lappend l [chan blocked $f] gets $f - lappend l [fblocked $f] + lappend l [chan blocked $f] } } set l "" @@ -5867,7 +5866,7 @@ test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles openpipe test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf variable c [format "abc\ndef\n%c" 26] puts -nonewline $f $c close $f @@ -5886,8 +5885,8 @@ 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 - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -translation auto -eofchar \x1a + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -5895,7 +5894,7 @@ test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fi test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set c [format "abc\ndef\n%cfoo\nbar\n" 26] puts -nonewline $f $c close $f @@ -5914,8 +5913,8 @@ 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 -eofchar \x1a -translation auto - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -eofchar \x1a -translation auto + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -5923,7 +5922,7 @@ test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {file test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr set c [format "abc\ndef\n%c" 26] puts -nonewline $f $c close $f @@ -5942,8 +5941,8 @@ 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 - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -translation auto -eofchar \x1a + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -5951,7 +5950,7 @@ test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {fi test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr set c [format "abc\ndef\n%cfoo\nbar\n" 26] puts -nonewline $f $c close $f @@ -5970,8 +5969,8 @@ 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 -eofchar \x1a -translation auto - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -eofchar \x1a -translation auto + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -5979,7 +5978,7 @@ test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {file test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf set c [format "abc\ndef\n%c" 26] puts -nonewline $f $c close $f @@ -5998,8 +5997,8 @@ 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 - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -translation auto -eofchar \x1a + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -6007,7 +6006,7 @@ test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} { test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf set c [format "abc\ndef\n%cfoo\nbar\n" 26] puts -nonewline $f $c close $f @@ -6026,8 +6025,8 @@ 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 -eofchar \x1a -translation auto - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -eofchar \x1a -translation auto + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -6035,7 +6034,7 @@ test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {fi test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set c [format "abc\ndef\n%cfoo\nbar\n" 26] puts -nonewline $f $c close $f @@ -6054,8 +6053,8 @@ 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 -eofchar \x1a -translation lf - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -eofchar \x1a -translation lf + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -6063,7 +6062,7 @@ test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {filee test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf set c [format "abc\ndef\n%c" 26] puts -nonewline $f $c close $f @@ -6082,8 +6081,8 @@ 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 - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -translation lf -eofchar \x1a + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -6091,7 +6090,7 @@ test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {fil test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr set c [format "abc\ndef\n%cfoo\nbar\n" 26] puts -nonewline $f $c close $f @@ -6110,8 +6109,8 @@ 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 -eofchar \x1a -translation cr - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -eofchar \x1a -translation cr + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -6119,7 +6118,7 @@ test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {filee test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation cr + chan configure $f -translation cr set c [format "abc\ndef\n%c" 26] puts -nonewline $f $c close $f @@ -6138,8 +6137,8 @@ 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 - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -translation cr -eofchar \x1a + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -6147,7 +6146,7 @@ test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {fil test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf set c [format "abc\ndef\n%cfoo\nbar\n" 26] puts -nonewline $f $c close $f @@ -6166,8 +6165,8 @@ 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 -eofchar \x1a -translation crlf - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -eofchar \x1a -translation crlf + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -6175,7 +6174,7 @@ test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {f test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {fileevent} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation crlf + chan configure $f -translation crlf set c [format "abc\ndef\n%c" 26] puts -nonewline $f $c close $f @@ -6194,8 +6193,8 @@ 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 - fileevent $f readable [namespace code [list consume $f]] + chan configure $f -translation crlf -eofchar \x1a + chan event $f readable [namespace code [list consume $f]] variable x vwait [namespace which -variable x] list $c $l @@ -6204,13 +6203,13 @@ test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {filee test io-49.1 {testing crlf reading, leftover cr disgorgment} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "a\rb\rc\r\n" close $f set f [open $path(test1) r] set l "" lappend l [file size $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf lappend l [read $f 1] lappend l [tell $f] lappend l [read $f 1] @@ -6233,13 +6232,13 @@ test io-49.1 {testing crlf reading, leftover cr disgorgment} { test io-49.2 {testing crlf reading, leftover cr disgorgment} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "a\rb\rc\r\n" close $f set f [open $path(test1) r] set l "" lappend l [file size $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf lappend l [read $f 2] lappend l [tell $f] lappend l [read $f 2] @@ -6256,13 +6255,13 @@ test io-49.2 {testing crlf reading, leftover cr disgorgment} { test io-49.3 {testing crlf reading, leftover cr disgorgment} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "a\rb\rc\r\n" close $f set f [open $path(test1) r] set l "" lappend l [file size $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf lappend l [read $f 3] lappend l [tell $f] lappend l [read $f 3] @@ -6277,13 +6276,13 @@ test io-49.3 {testing crlf reading, leftover cr disgorgment} { test io-49.4 {testing crlf reading, leftover cr disgorgment} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "a\rb\rc\r\n" close $f set f [open $path(test1) r] set l "" lappend l [file size $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf lappend l [read $f 3] lappend l [tell $f] lappend l [gets $f] @@ -6298,13 +6297,13 @@ test io-49.4 {testing crlf reading, leftover cr disgorgment} { test io-49.5 {testing crlf reading, leftover cr disgorgment} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts -nonewline $f "a\rb\rc\r\n" close $f set f [open $path(test1) r] set l "" lappend l [file size $path(test1)] - fconfigure $f -translation crlf + chan configure $f -translation crlf lappend l [set x [gets $f]] lappend l [tell $f] lappend l [gets $f] @@ -6383,7 +6382,7 @@ test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent} { proc delrecursive {f} { variable z variable u - if {"$u" == "recursive"} { + if {$u eq "recursive"} { testchannelevent $f delete 0 lappend z "delrecursive deleting recursive" } else { @@ -6413,7 +6412,7 @@ test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent} { proc del {f} { variable u variable z - if {"$u" == "recursive"} { + if {$u eq "recursive"} { testchannelevent $f delete 1 testchannelevent $f delete 0 lappend z "del deleted notcalled" @@ -6443,7 +6442,7 @@ test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} { proc first {f} { variable u variable z - if {"$u" == "toplevel"} { + if {$u eq "toplevel"} { lappend z "first called" set u first update @@ -6455,11 +6454,11 @@ test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} { proc second {f} { variable u variable z - if {"$u" == "first"} { + if {$u eq "first"} { lappend z "second called, first time" set u second testchannelevent $f delete 0 - } elseif {"$u" == "second"} { + } elseif {$u eq "second"} { lappend z "second called, second time" testchannelevent $f delete 0 } else { @@ -6483,13 +6482,13 @@ test io-51.1 {Test old socket deletion on Macintosh} {socket} { proc accept {s a p} { variable x variable wait - fconfigure $s -blocking off + chan configure $s -blocking off puts $s "sock[incr x]" close $s set wait done } set ss [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $ss -sockname] 2] + set port [lindex [chan configure $ss -sockname] 2] variable wait "" set cs [socket 127.0.0.1 $port] @@ -6522,8 +6521,8 @@ test io-52.1 {TclCopyChannel} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fcopy $f1 $f2 -command { # } - catch { fcopy $f1 $f2 } msg + chan copy $f1 $f2 -command { # } + catch { chan copy $f1 $f2 } msg close $f1 close $f2 string compare $msg "channel \"$f1\" is busy" @@ -6533,8 +6532,8 @@ test io-52.2 {TclCopyChannel} {fcopy} { set f1 [open $thisScript] set f2 [open $path(test1) w] set f3 [open $thisScript] - fcopy $f1 $f2 -command { # } - catch { fcopy $f3 $f2 } msg + chan copy $f1 $f2 -command { # } + catch { chan copy $f3 $f2 } msg close $f1 close $f2 close $f3 @@ -6544,15 +6543,15 @@ test io-52.3 {TclCopyChannel} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation cr -blocking 0 - set s0 [fcopy $f1 $f2] - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation cr -blocking 0 + set s0 [chan copy $f1 $f2] + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] close $f1 close $f2 set s1 [file size $thisScript] set s2 [file size $path(test1)] - if {("$s1" == "$s2") && ($s0 == $s1)} { + if {($s1 == $s2) && ($s0 == $s1)} { lappend result ok } set result @@ -6561,10 +6560,10 @@ test io-52.4 {TclCopyChannel} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation cr -blocking 0 - fcopy $f1 $f2 -size 40 - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation cr -blocking 0 + chan copy $f1 $f2 -size 40 + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] close $f1 close $f2 lappend result [file size $path(test1)] @@ -6573,15 +6572,15 @@ 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 - fcopy $f1 $f2 -size -1 ;# -1 means 'copy all', same as if no -size specified. - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation lf -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]] close $f1 close $f2 set s1 [file size $thisScript] set s2 [file size $path(test1)] - if {"$s1" == "$s2"} { + if {$s1 == $s2} { lappend result ok } set result @@ -6590,15 +6589,15 @@ 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 - fcopy $f1 $f2 -size -2 ;# < 0 behaves like -1, copy all - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation lf -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]] close $f1 close $f2 set s1 [file size $thisScript] set s2 [file size $path(test1)] - if {"$s1" == "$s2"} { + if {$s1 == $s2} { lappend result ok } set result @@ -6607,15 +6606,15 @@ 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 - fcopy $f1 $f2 -size 3221176172 ;# Wrapped to < 0, behaves like -1, copy all - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation lf -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]] close $f1 close $f2 set s1 [file size $thisScript] set s2 [file size $path(test1)] - if {"$s1" == "$s2"} { + if {$s1 == $s2} { lappend result ok } set result @@ -6624,15 +6623,15 @@ test io-52.6 {TclCopyChannel} {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 - set s0 [fcopy $f1 $f2 -size [expr [file size $thisScript] + 5]] - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation lf -blocking 0 + set s0 [chan copy $f1 $f2 -size [expr [file size $thisScript] + 5]] + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] close $f1 close $f2 set s1 [file size $thisScript] set s2 [file size $path(test1)] - if {("$s1" == "$s2") && ($s0 == $s1)} { + if {($s1 == $s2) && ($s0 == $s1)} { lappend result ok } set result @@ -6641,15 +6640,15 @@ test io-52.7 {TclCopyChannel} {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 - fcopy $f1 $f2 - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation lf -blocking 0 + chan copy $f1 $f2 + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] set s1 [file size $thisScript] set s2 [file size $path(test1)] close $f1 close $f2 - if {"$s1" == "$s2"} { + if {$s1 == $s2} { lappend result ok } set result @@ -6658,24 +6657,24 @@ test io-52.8 {TclCopyChannel} {stdio openpipe fcopy} { file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] - fconfigure $f1 -translation lf + chan configure $f1 -translation lf puts $f1 " puts ready gets stdin set f1 \[open [list $thisScript] r\] - fconfigure \$f1 -translation lf + chan configure \$f1 -translation lf puts \[read \$f1 100\] close \$f1 " close $f1 set f1 [open "|[list [interpreter] $path(pipe)]" r+] - fconfigure $f1 -translation lf + chan configure $f1 -translation lf gets $f1 puts $f1 ready flush $f1 set f2 [open $path(test1) w] - fconfigure $f2 -translation lf - set s0 [fcopy $f1 $f2 -size 40] + chan configure $f2 -translation lf + set s0 [chan copy $f1 $f2 -size 40] catch {close $f1} close $f2 list $s0 [file size $path(test1)] @@ -6686,33 +6685,33 @@ set path(utf8-fcopy.txt) [makeFile {} utf8-fcopy.txt] set path(utf8-rp.txt) [makeFile {} utf8-rp.txt] # Create kyrillic file, use lf translation to avoid os eol issues set out [open $path(kyrillic.txt) w] -fconfigure $out -encoding koi8-r -translation lf -puts $out "\u0410\u0410" -close $out +chan configure $out -encoding koi8-r -translation lf +chan puts $out "\u0410\u0410" +chan close $out test io-52.9 {TclCopyChannel & encodings} {fcopy} { - # Copy kyrillic to UTF-8, using fcopy. + # Copy kyrillic to UTF-8, using chan copy. set in [open $path(kyrillic.txt) r] set out [open $path(utf8-fcopy.txt) w] - fconfigure $in -encoding koi8-r -translation lf - fconfigure $out -encoding utf-8 -translation lf + chan configure $in -encoding koi8-r -translation lf + chan configure $out -encoding utf-8 -translation lf - fcopy $in $out - close $in - close $out + chan copy $in $out + chan close $in + chan close $out # Do the same again, but differently (read/puts). set in [open $path(kyrillic.txt) r] set out [open $path(utf8-rp.txt) w] - fconfigure $in -encoding koi8-r -translation lf - fconfigure $out -encoding utf-8 -translation lf + chan configure $in -encoding koi8-r -translation lf + chan configure $out -encoding utf-8 -translation lf - puts -nonewline $out [read $in] + chan puts -nonewline $out [read $in] - close $in + chan close $in close $out list [file size $path(kyrillic.txt)] \ @@ -6726,11 +6725,11 @@ test io-52.10 {TclCopyChannel & encodings} {fcopy} { set in [open $path(kyrillic.txt) r] set out [open $path(utf8-fcopy.txt) w] - fconfigure $in -encoding koi8-r -translation lf + chan configure $in -encoding koi8-r -translation lf # -translation binary is also -encoding binary - fconfigure $out -translation binary + chan configure $out -translation binary - fcopy $in $out + chan copy $in $out close $in close $out @@ -6744,10 +6743,10 @@ test io-52.11 {TclCopyChannel & encodings} {fcopy} { set out [open $path(kyrillic.txt) w] # -translation binary is also -encoding binary - fconfigure $in -translation binary - fconfigure $out -encoding koi8-r -translation lf + chan configure $in -translation binary + chan configure $out -encoding koi8-r -translation lf - fcopy $in $out + chan copy $in $out close $in close $out @@ -6758,10 +6757,10 @@ test io-53.1 {CopyData} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation cr -blocking 0 - fcopy $f1 $f2 -size 0 - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation cr -blocking 0 + chan copy $f1 $f2 -size 0 + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] close $f1 close $f2 lappend result [file size $path(test1)] @@ -6770,17 +6769,17 @@ test io-53.2 {CopyData} {fcopy} { file delete $path(test1) set f1 [open $thisScript] set f2 [open $path(test1) w] - fconfigure $f1 -translation lf -blocking 0 - fconfigure $f2 -translation cr -blocking 0 - fcopy $f1 $f2 -command [namespace code {set s0}] - set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]] + chan configure $f1 -translation lf -blocking 0 + chan configure $f2 -translation cr -blocking 0 + chan copy $f1 $f2 -command [namespace code {set s0}] + set result [list [chan configure $f1 -blocking] [chan configure $f2 -blocking]] variable s0 vwait [namespace which -variable s0] close $f1 close $f2 set s1 [file size $thisScript] set s2 [file size $path(test1)] - if {("$s1" == "$s2") && ($s0 == $s1)} { + if {($s1 == $s2) && ($s0 == $s1)} { lappend result ok } set result @@ -6792,12 +6791,12 @@ test io-53.3 {CopyData: background read underflow} {stdio unix openpipe fcopy} { puts -nonewline $f1 { puts ready flush stdout ;# Don't assume line buffered! - fcopy stdin stdout -command { set x } + chan copy stdin stdout -command { set x } vwait x set f [} puts $f1 [list open $path(test1) w]] puts $f1 { - fconfigure $f -translation lf + chan configure $f -translation lf puts $f "done" close $f } @@ -6828,22 +6827,22 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven set f1 [open $path(pipe) w] puts $f1 { puts ready - fcopy stdin stdout -command { set x } + chan copy stdin stdout -command { set x } vwait x set f [open $path(test1) w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f "done" close $f } close $f1 set f1 [open "|[list [interpreter] $path(pipe)]" r+] set result [gets $f1] - fconfigure $f1 -blocking 0 + chan configure $f1 -blocking 0 puts $f1 $big flush $f1 after 500 set result "" - fileevent $f1 read [namespace code { + chan event $f1 read [namespace code { append result [read $f1 1024] if {[string length $result] >= [string length $big]} { set x done @@ -6851,10 +6850,10 @@ test io-53.4 {CopyData: background write overflow} {stdio unix openpipe fileeven }] vwait [namespace which -variable x] close $f1 - set big {} + set big "" set x } done -set result {} +set result "" proc FcopyTestAccept {sock args} { after 1000 "close $sock" } @@ -6866,14 +6865,14 @@ proc FcopyTestDone {bytes {error {}}} { set fcopyTestDone 0 } } -test io-53.5 {CopyData: error during fcopy} {socket fcopy} { +test io-53.5 {CopyData: error during chan copy} {socket fcopy} { variable fcopyTestDone set listen [socket -server [namespace code FcopyTestAccept] -myaddr 127.0.0.1 0] set in [open $thisScript] ;# 126 K - set out [socket 127.0.0.1 [lindex [fconfigure $listen -sockname] 2]] - catch {unset fcopyTestDone} + set out [socket 127.0.0.1 [lindex [chan configure $listen -sockname] 2]] + unset -nocomplain fcopyTestDone close $listen ;# This means the socket open never really succeeds - fcopy $in $out -command [namespace code FcopyTestDone] + chan copy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone if ![info exists fcopyTestDone] { vwait [namespace which -variable fcopyTestDone] ;# The error occurs here in the b.g. @@ -6882,17 +6881,17 @@ test io-53.5 {CopyData: error during fcopy} {socket fcopy} { close $out set fcopyTestDone ;# 1 for error condition } 1 -test io-53.6 {CopyData: error during fcopy} {stdio openpipe fcopy} { +test io-53.6 {CopyData: error during chan copy} {stdio openpipe fcopy} { variable fcopyTestDone file delete $path(pipe) file delete $path(test1) - catch {unset fcopyTestDone} + unset -nocomplain fcopyTestDone set f1 [open $path(pipe) w] puts $f1 "exit 1" close $f1 set in [open "|[list [interpreter] $path(pipe)]" r+] set out [open $path(test1) w] - fcopy $in $out -command [namespace code FcopyTestDone] + chan copy $in $out -command [namespace code FcopyTestDone] variable fcopyTestDone if ![info exists fcopyTestDone] { vwait [namespace which -variable fcopyTestDone] @@ -6910,15 +6909,15 @@ proc doFcopy {in out {bytes 0} {error {}}} { } elseif {[eof $in]} { set fcopyTestDone 0 } else { - # Delay next fcopy to wait for size>0 input bytes - after 100 [list fcopy $in $out -size 1000 \ + # Delay next chan copy to wait for size>0 input bytes + after 100 [list chan copy $in $out -size 1000 \ -command [namespace code [list doFcopy $in $out]]] } } -test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio openpipe fcopy} { +test io-53.7 {CopyData: Flooding chan copy from pipe} {stdio openpipe fcopy} { variable fcopyTestDone file delete $path(pipe) - catch {unset fcopyTestDone} + unset -nocomplain fcopyTestDone set fcopyTestCount 0 set f1 [open $path(pipe) w] puts $f1 { @@ -6931,7 +6930,7 @@ test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio openpipe fcopy} { set ::ready 1 } } - fconfigure stdout -buffering none + chan configure stdout -buffering none Write 345 ;# 3450 bytes ~3.45 sec vwait ready exit 0 @@ -6965,13 +6964,13 @@ test io-53.8 {CopyData: async callback and error handling, Bug 1932639} -setup { set foo [makeFile ashgdfashdgfasdhgfasdhgf foo] set bar [makeFile {} bar] # Channels to copy between - set f [open $foo r] ; fconfigure $f -translation binary - set g [open $bar w] ; fconfigure $g -translation binary -buffering none + set f [open $foo r] ; chan configure $f -translation binary + set g [open $bar w] ; chan configure $g -translation binary -buffering none } -constraints {stdio openpipe fcopy} -body { # Record input size, so that result is always defined lappend ::RES [file size $bar] # Run the copy. Should not invoke -command now. - fcopy $f $g -size 2 -command ::cmd + chan copy $f $g -size 2 -command ::cmd # Check that -command was not called synchronously set sbs [file size $bar] lappend ::RES [expr {($sbs > 0) ? "sync/FAIL" : "sync/OK"}] $sbs @@ -6988,10 +6987,9 @@ test io-53.8 {CopyData: async callback and error handling, Bug 1932639} -setup { } -cleanup { close $f close $g - catch {unset ::RES} - catch {unset ::forever} - rename ::cmd {} - rename ::bgerror {} + unset -nocomplain ::RES ::forever + rename ::cmd "" + rename ::bgerror "" removeFile foo removeFile bar } -result {0 sync/OK 0 {CMD 2} {bgerror/OK !STOP}} @@ -7006,14 +7004,14 @@ test io-53.8a {CopyData: async callback and error handling, Bug 1932639, at eof} set foo [makeFile ashgdfashdgfasdhgfasdhgf foo] set bar [makeFile {} bar] # Channels to copy between - set f [open $foo r] ; fconfigure $f -translation binary - set g [open $bar w] ; fconfigure $g -translation binary -buffering none + set f [open $foo r] ; chan configure $f -translation binary + set g [open $bar w] ; chan configure $g -translation binary -buffering none } -constraints {stdio openpipe fcopy} -body { # Initialize and force eof on the input. seek $f 0 end ; read $f 1 set ::RES [eof $f] # Run the copy. Should not invoke -command now. - fcopy $f $g -size 2 -command ::cmd + chan copy $f $g -size 2 -command ::cmd # Check that -command was not called synchronously lappend ::RES [expr {([llength $::RES] > 1) ? "sync/FAIL" : "sync/OK"}] # Now let the async part happen. Should capture the eof in cmd @@ -7029,8 +7027,7 @@ test io-53.8a {CopyData: async callback and error handling, Bug 1932639, at eof} } -cleanup { close $f close $g - catch {unset ::RES} - catch {unset ::forever} + unset -nocomplain ::RES ::forever rename ::cmd {} removeFile foo removeFile bar @@ -7046,12 +7043,12 @@ test io-53.8b {CopyData: async callback and -size 0} -setup { set foo [makeFile ashgdfashdgfasdhgfasdhgf foo] set bar [makeFile {} bar] # Channels to copy between - set f [open $foo r] ; fconfigure $f -translation binary - set g [open $bar w] ; fconfigure $g -translation binary -buffering none + set f [open $foo r] ; chan configure $f -translation binary + set g [open $bar w] ; chan configure $g -translation binary -buffering none } -constraints {stdio openpipe fcopy} -body { set ::RES {} # Run the copy. Should not invoke -command now. - fcopy $f $g -size 0 -command ::cmd + chan copy $f $g -size 0 -command ::cmd # Check that -command was not called synchronously lappend ::RES [expr {([llength $::RES] > 1) ? "sync/FAIL" : "sync/OK"}] # Now let the async part happen. Should capture the eof in cmd @@ -7067,8 +7064,7 @@ test io-53.8b {CopyData: async callback and -size 0} -setup { } -cleanup { close $f close $g - catch {unset ::RES} - catch {unset ::forever} + unset -nocomplain ::RES ::forever rename ::cmd {} removeFile foo removeFile bar @@ -7077,9 +7073,9 @@ test io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { set out [makeFile {} out] set err [makeFile {} err] set pipe [open "|[list [info nameofexecutable] 2> $err]" r+] - fconfigure $pipe -translation binary -buffering line + chan configure $pipe -translation binary -buffering line puts $pipe { - fconfigure stdout -translation binary -buffering line + chan configure stdout -translation binary -buffering line puts stderr Waiting... after 1000 foreach x {a b c} { @@ -7096,7 +7092,7 @@ test io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { } } puts stderr Now-sleeping-forever - fileevent stdin readable bye + chan event stdin readable bye vwait forever } proc ::done args { @@ -7106,9 +7102,9 @@ test io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { set ::forever {} set out [open $out w] } -constraints {stdio openpipe fcopy} -body { - fcopy $pipe $out -size 6 -command ::done + chan copy $pipe $out -size 6 -command ::done set token [after 5000 { - set ::forever {fcopy hangs} + set ::forever {chan copy hangs} }] vwait ::forever catch {after cancel $token} @@ -7120,14 +7116,14 @@ test io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup { catch {close $out} catch {removeFile out} catch {removeFile err} - catch {unset ::forever} + unset -nocomplain ::forever } -result OK -test io-53.10 {Bug 1350564, multi-directional fcopy} -setup { +test io-53.10 {Bug 1350564, multi-directional chan copy} -setup { set err [makeFile {} err] set pipe [open "|[list [info nameofexecutable] 2> $err]" r+] - fconfigure $pipe -translation binary -buffering line + chan configure $pipe -translation binary -buffering line puts $pipe { - fconfigure stderr -buffering line + chan configure stderr -buffering line # Kill server when pipe closed by invoker. proc bye args { if {![eof stdin]} { gets stdin ; return } @@ -7142,13 +7138,13 @@ test io-53.10 {Bug 1350564, multi-directional fcopy} -setup { proc new {sok args} { puts stderr NEW/$sok global l srv - fconfigure $sok -translation binary -buffering none + chan configure $sok -translation binary -buffering none lappend l $sok - if {[llength $l]==2} { + if {[llength $l] == 2} { close $srv - foreach {a b} $l break - fcopy $a $b -command [list geof $a] - fcopy $b $a -command [list geof $b] + lassign $l a b + chan copy $a $b -command [list geof $a] + chan copy $b $a -command [list geof $b] puts stderr 2COPY } puts stderr ... @@ -7157,7 +7153,7 @@ test io-53.10 {Bug 1350564, multi-directional fcopy} -setup { set l {} set srv [socket -server new 9999] puts stderr WAITING - fileevent stdin readable bye + chan event stdin readable bye puts OK vwait forever } @@ -7171,10 +7167,10 @@ test io-53.10 {Bug 1350564, multi-directional fcopy} -setup { } set a [socket 127.0.0.1 9999] set b [socket 127.0.0.1 9999] - fconfigure $a -translation binary -buffering none - fconfigure $b -translation binary -buffering none - fileevent $a readable [list ::done $a] - fileevent $b readable [list ::done $b] + chan configure $a -translation binary -buffering none + chan configure $b -translation binary -buffering none + chan event $a readable [list ::done $a] + chan event $b readable [list ::done $b] } -constraints {stdio openpipe fcopy} -body { # Now pass data through the server in both directions. set ::forever {} @@ -7190,19 +7186,19 @@ test io-53.10 {Bug 1350564, multi-directional fcopy} -setup { rename ::done {} after 1000 ;# Give Windows time to kill the process removeFile err - catch {unset ::forever} + unset -nocomplain ::forever } -result {AB BA} test io-53.11 {Bug 2895565} -setup { set in [makeFile {} in] set f [open $in w] - fconfigure $f -encoding utf-8 -translation binary + chan configure $f -encoding utf-8 -translation binary puts -nonewline $f [string repeat "Ho hum\n" 11] close $f set inChan [open $in r] - fconfigure $inChan -translation binary + chan configure $inChan -translation binary set out [makeFile {} out] set outChan [open $out w] - fconfigure $outChan -encoding cp1252 -translation crlf + chan configure $outChan -encoding cp1252 -translation crlf proc CopyDone {bytes args} { variable done if {[llength $args]} { @@ -7214,7 +7210,7 @@ test io-53.11 {Bug 2895565} -setup { } -body { variable done after 2000 [list set [namespace which -variable done] timeout] - fcopy $inChan $outChan -size 40 -command [namespace which CopyDone] + chan copy $inChan $outChan -size 40 -command [namespace which CopyDone] vwait [namespace which -variable done] set done } -cleanup { @@ -7230,7 +7226,7 @@ test io-54.1 {Recursive channel events} {socket fileevent} { proc accept {s a p} { variable as - fconfigure $s -translation lf + chan configure $s -translation lf puts $s "line 1\nline2\nline3" flush $s set as $s @@ -7240,7 +7236,7 @@ test io-54.1 {Recursive channel events} {socket fileevent} { variable result lappend result $next if {$next == 1} { - fileevent $s readable [namespace code [list readit $s 2]] + chan event $s readable [namespace code [list readit $s 2]] vwait [namespace which -variable x] } incr x @@ -7252,7 +7248,7 @@ test io-54.1 {Recursive channel events} {socket fileevent} { set done 0 for {set i 0} {$i < 10} {incr i} { - if {![catch {set cs [socket 127.0.0.1 [lindex [fconfigure $ss -sockname] 2]]}]} { + if {![catch {set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]]}]} { set done 1 break } @@ -7266,10 +7262,10 @@ test io-54.1 {Recursive channel events} {socket fileevent} { variable x 0 variable as vwait [namespace which -variable as] - fconfigure $cs -translation lf + chan configure $cs -translation lf lappend result [gets $cs] - fconfigure $cs -blocking off - fileevent $cs readable [namespace code [list readit $cs 1]] + chan configure $cs -blocking off + chan event $cs readable [namespace code [list readit $cs 1]] set a [after 2000 [namespace code { set x failure }]] vwait [namespace which -variable x] after cancel $a @@ -7288,8 +7284,8 @@ test io-54.2 {Testing for busy-wait in recursive channel events} {socket fileeve set accept $s set counter 0 - fconfigure $s -blocking off -buffering line -translation lf - fileevent $s readable [namespace code "doit $s"] + chan configure $s -blocking off -buffering line -translation lf + chan event $s readable [namespace code "doit $s"] } proc doit {s} { variable counter @@ -7297,8 +7293,8 @@ test io-54.2 {Testing for busy-wait in recursive channel events} {socket fileeve incr counter set l [gets $s] - if {"$l" == ""} { - fileevent $s readable [namespace code "doit1 $s"] + if {$l eq ""} { + chan event $s readable [namespace code "doit1 $s"] set after [after 1000 [namespace code newline]] } } @@ -7309,14 +7305,14 @@ test io-54.2 {Testing for busy-wait in recursive channel events} {socket fileeve incr counter set l [gets $s] close $s - set accept {} + set accept "" } proc producer {} { variable s variable writer - set writer [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]] - fconfigure $writer -buffering line + set writer [socket 127.0.0.1 [lindex [chan configure $s -sockname] 2]] + chan configure $writer -buffering line puts -nonewline $writer hello flush $writer } @@ -7357,7 +7353,7 @@ test io-55.1 {ChannelEventScriptInvoker: deletion} -constraints { interp bgerror {} [namespace which myHandler] } -body { set f [open $path(fooBar) w] - fileevent $f writable [namespace code [list eventScript $f]] + chan event $f writable [namespace code [list eventScript $f]] variable x not_done vwait [namespace which -variable x] set x @@ -7392,11 +7388,11 @@ test io-57.1 {buffered data and file events, gets} {fileevent} { set s2 $sock } set server [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - set s [socket 127.0.0.1 [lindex [fconfigure $server -sockname] 2]] + set s [socket 127.0.0.1 [lindex [chan configure $server -sockname] 2]] variable s2 vwait [namespace which -variable s2] update - fileevent $s2 readable [namespace code {lappend result readable}] + chan event $s2 readable [namespace code {lappend result readable}] puts $s "12\n34567890" flush $s variable result [gets $s2] @@ -7415,11 +7411,11 @@ test io-57.2 {buffered data and file events, read} {fileevent} { set s2 $sock } set server [socket -server [namespace code accept] -myaddr 127.0.0.1 0] - set s [socket 127.0.0.1 [lindex [fconfigure $server -sockname] 2]] + set s [socket 127.0.0.1 [lindex [chan configure $server -sockname] 2]] variable s2 vwait [namespace which -variable s2] update - fileevent $s2 readable [namespace code {lappend result readable}] + chan event $s2 readable [namespace code {lappend result readable}] puts -nonewline $s "1234567890" flush $s variable result [read $s2 1] @@ -7453,7 +7449,7 @@ test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc openpipe } close $out set pipe [open "|[list [interpreter] $path(script)]" r] - fileevent $pipe readable [namespace code [list readit $pipe]] + chan event $pipe readable [namespace code [list readit $pipe]] variable x "" set result "" vwait [namespace which -variable x] @@ -7494,7 +7490,7 @@ test io-60.1 {writing illegal utf sequences} {openpipe fileevent} { } close $out set pipe [open "|[list [interpreter] $path(script)]" r] - fileevent $pipe readable [namespace code [list readit $pipe]] + chan event $pipe readable [namespace code [list readit $pipe]] variable x "" set result "" vwait [namespace which -variable x] @@ -7507,7 +7503,7 @@ test io-60.1 {writing illegal utf sequences} {openpipe fileevent} { test io-61.1 {Reset eof state after changing the eof char} -setup { set datafile [makeFile {} eofchar] set f [open $datafile w] - fconfigure $f -translation binary + chan configure $f -translation binary puts -nonewline $f [string repeat "Ho hum\n" 11] puts $f = set line [string repeat "Ge gla " 4] @@ -7515,10 +7511,10 @@ test io-61.1 {Reset eof state after changing the eof char} -setup { close $f } -body { set f [open $datafile r] - fconfigure $f -eofchar = + chan configure $f -eofchar = set res {} lappend res [read $f; tell $f] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} lappend res [read $f 1] lappend res [read $f; tell $f] # Any seek zaps the internals into a good state. @@ -7556,12 +7552,11 @@ test io-70.0 {Cutting & Splicing channels} {testchannel} { set res } {0 1 0} - test io-70.1 {Transfer channel} {testchannel thread} { set f [makeFile {... dummy ...} cutsplice] set c [open $f r] - set res {} + set res [list] lappend res [catch {seek $c 0 start}] testchannel cut $c lappend res [catch {seek $c 0 start}] diff --git a/tests/ioCmd.test b/tests/ioCmd.test index 03242be..50c8040 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -1,6 +1,6 @@ # -*- tcl -*- # Commands covered: open, close, gets, read, puts, seek, tell, eof, flush, -# fblocked, fconfigure, open, channel, fcopy +# chan blocked, chan configure, open, channel, chan copy # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -48,21 +48,21 @@ set path(test1) [makeFile {} test1] test iocmd-1.6 {puts command} { set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts -nonewline $f foobar close $f file size $path(test1) } 6 test iocmd-1.7 {puts command} { set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts $f foobar close $f file size $path(test1) } 7 test iocmd-1.8 {puts command} { set f [open $path(test1) w] - fconfigure $f -translation lf -eofchar {} -encoding iso8859-1 + chan configure $f -translation lf -eofchar {} -encoding iso8859-1 puts -nonewline $f [binary format a4a5 foo bar] close $f file size $path(test1) @@ -206,111 +206,111 @@ test iocmd-7.5 {close command} -setup { close $chan } -returnCodes error -result "Half-close of write-side not possible, side not opened or already closed" -test iocmd-8.1 {fconfigure command} { - list [catch {fconfigure} msg] $msg -} {1 {wrong # args: should be "fconfigure channelId ?-option value ...?"}} -test iocmd-8.2 {fconfigure command} { - list [catch {fconfigure a b c d e f} msg] $msg -} {1 {wrong # args: should be "fconfigure channelId ?-option value ...?"}} -test iocmd-8.3 {fconfigure command} { - list [catch {fconfigure a b} msg] $msg +test iocmd-8.1 {chan configure command} { + list [catch {chan configure} msg] $msg +} {1 {wrong # args: should be "chan configure channelId ?-option value ...?"}} +test iocmd-8.2 {chan configure command} { + list [catch {chan configure a b c d e f} msg] $msg +} {1 {wrong # args: should be "chan configure channelId ?-option value ...?"}} +test iocmd-8.3 {chan configure command} { + list [catch {chan configure a b} msg] $msg } {1 {can not find channel named "a"}} -test iocmd-8.4 {fconfigure command} { +test iocmd-8.4 {chan configure command} { file delete $path(test1) set f1 [open $path(test1) w] - set x [list [catch {fconfigure $f1 froboz} msg] $msg] + set x [list [catch {chan configure $f1 froboz} msg] $msg] close $f1 set x } {1 {bad option "froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} -test iocmd-8.5 {fconfigure command} { - list [catch {fconfigure stdin -buffering froboz} msg] $msg +test iocmd-8.5 {chan configure command} { + list [catch {chan configure stdin -buffering froboz} msg] $msg } {1 {bad value for -buffering: must be one of full, line, or none}} -test iocmd-8.6 {fconfigure command} { - list [catch {fconfigure stdin -translation froboz} msg] $msg +test iocmd-8.6 {chan configure command} { + list [catch {chan configure stdin -translation froboz} msg] $msg } {1 {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}} -test iocmd-8.7 {fconfigure command} { +test iocmd-8.7 {chan configure command} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -eofchar {} -encoding unicode - set x [fconfigure $f1] + chan configure $f1 -translation lf -eofchar {} -encoding unicode + set x [chan configure $f1] close $f1 set x } {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf} -test iocmd-8.8 {fconfigure command} { +test iocmd-8.8 {chan configure command} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation lf -buffering line -buffersize 3030 \ + chan configure $f1 -translation lf -buffering line -buffersize 3030 \ -eofchar {} -encoding unicode set x "" - lappend x [fconfigure $f1 -buffering] - lappend x [fconfigure $f1] + lappend x [chan configure $f1 -buffering] + lappend x [chan configure $f1] close $f1 set x } {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}} -test iocmd-8.9 {fconfigure command} { +test iocmd-8.9 {chan configure command} { file delete $path(test1) set f1 [open $path(test1) w] - fconfigure $f1 -translation binary -buffering none -buffersize 4040 \ + chan configure $f1 -translation binary -buffering none -buffersize 4040 \ -eofchar {} -encoding binary - set x [fconfigure $f1] + set x [chan configure $f1] close $f1 set x } {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf} -test iocmd-8.10 {fconfigure command} { - list [catch {fconfigure a b} msg] $msg +test iocmd-8.10 {chan configure command} { + list [catch {chan configure a b} msg] $msg } {1 {can not find channel named "a"}} set path(fconfigure.dummy) [makeFile {} fconfigure.dummy] -test iocmd-8.11 {fconfigure command} { +test iocmd-8.11 {chan configure command} { set chan [open $path(fconfigure.dummy) r] - set res [list [catch {fconfigure $chan -froboz blarfo} msg] $msg] + set res [list [catch {chan configure $chan -froboz blarfo} msg] $msg] close $chan set res } {1 {bad option "-froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} -test iocmd-8.12 {fconfigure command} { +test iocmd-8.12 {chan configure command} { set chan [open $path(fconfigure.dummy) r] - set res [list [catch {fconfigure $chan -b blarfo} msg] $msg] + set res [list [catch {chan configure $chan -b blarfo} msg] $msg] close $chan set res } {1 {bad option "-b": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} -test iocmd-8.13 {fconfigure command} { +test iocmd-8.13 {chan configure command} { set chan [open $path(fconfigure.dummy) r] - set res [list [catch {fconfigure $chan -buffer blarfo} msg] $msg] + set res [list [catch {chan configure $chan -buffer blarfo} msg] $msg] close $chan set res } {1 {bad option "-buffer": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}} -removeFile fconfigure.dummy -test iocmd-8.14 {fconfigure command} { - fconfigure stdin -buffers +removeFile chan configure.dummy +test iocmd-8.14 {chan configure command} { + chan configure stdin -buffers } 4096 -test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOrPc} -setup { +test iocmd-8.15.1 {chan configure command / tcp channel} -constraints {socket unixOrPc} -setup { set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $srv -sockname] 2] + set port [lindex [chan configure $srv -sockname] 2] proc iocmdSRV {sock ip port} {close $sock} set cli [socket 127.0.0.1 $port] } -body { - fconfigure $cli -blah + chan configure $cli -blah } -cleanup { close $cli close $srv unset cli srv port rename iocmdSRV {} } -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, -peername, or -sockname} -test iocmd-8.16 {fconfigure command / tcp channel} -constraints socket -setup { +test iocmd-8.16 {chan configure command / tcp channel} -constraints socket -setup { set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $srv -sockname] 2] + set port [lindex [chan configure $srv -sockname] 2] proc iocmdSRV {sock ip port} {close $sock} set cli [socket 127.0.0.1 $port] } -body { - expr {[lindex [fconfigure $cli -peername] 2] == $port} + expr {[lindex [chan configure $cli -peername] 2] == $port} } -cleanup { close $cli close $srv unset cli srv port rename iocmdSRV {} } -result 1 -test iocmd-8.17 {fconfigure command / tcp channel} -constraints nonPortable -setup { +test iocmd-8.17 {chan configure command / tcp channel} -constraints nonPortable -setup { set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $srv -sockname] 2] + set port [lindex [chan configure $srv -sockname] 2] proc iocmdSRV {sock ip port} {close $sock} set cli [socket 127.0.0.1 $port] } -body { @@ -320,30 +320,30 @@ test iocmd-8.17 {fconfigure command / tcp channel} -constraints nonPortable -set puts $cli "blah" flush $cli; # that flush could/should fail too update - regsub -all {can([^:])+: } [catch {fconfigure $cli -peername} msg] {} + regsub -all {can([^:])+: } [catch {chan configure $cli -peername} msg] {} } -cleanup { close $cli close $srv unset cli srv port rename iocmdSRV {} } -result 1 -test iocmd-8.18 {fconfigure command / unix tty channel} -constraints {nonPortable unix} -setup { +test iocmd-8.18 {chan configure command / unix tty channel} -constraints {nonPortable unix} -setup { set tty "" } -body { # might fail if /dev/ttya is unavailable set tty [open /dev/ttya] - fconfigure $tty -blah blih + chan configure $tty -blah blih } -cleanup { if {$tty ne ""} { close $tty } } -returnCodes error -result {bad option "-blah": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, -translation, or -mode} -test iocmd-8.19 {fconfigure command / win tty channel} -constraints {nonPortable win} -setup { +test iocmd-8.19 {chan configure command / win tty channel} -constraints {nonPortable win} -setup { set tty "" } -body { # might fail early if com1 is unavailable set tty [open com1] - fconfigure $tty -blah blih + chan configure $tty -blah blih } -cleanup { if {$tty ne ""} { close $tty @@ -365,29 +365,29 @@ test iocmd-9.3 {eof command} { # The tests for Tcl_ExecObjCmd are in exec.test -test iocmd-10.1 {fblocked command} { - list [catch {fblocked} msg] $msg -} {1 {wrong # args: should be "fblocked channelId"}} -test iocmd-10.2 {fblocked command} { - list [catch {fblocked a b c d e f g} msg] $msg -} {1 {wrong # args: should be "fblocked channelId"}} -test iocmd-10.3 {fblocked command} { - list [catch {fblocked file1000} msg] $msg +test iocmd-10.1 {chan blocked command} { + list [catch {chan blocked} msg] $msg +} {1 {wrong # args: should be "chan blocked channelId"}} +test iocmd-10.2 {chan blocked command} { + list [catch {chan blocked a b c d e f g} msg] $msg +} {1 {wrong # args: should be "chan blocked channelId"}} +test iocmd-10.3 {chan blocked command} { + list [catch {chan blocked file1000} msg] $msg } {1 {can not find channel named "file1000"}} -test iocmd-10.4 {fblocked command} { - list [catch {fblocked stdout} msg] $msg +test iocmd-10.4 {chan blocked command} { + list [catch {chan blocked stdout} msg] $msg } {1 {channel "stdout" wasn't opened for reading}} -test iocmd-10.5 {fblocked command} { - fblocked stdin +test iocmd-10.5 {chan blocked command} { + chan blocked stdin } 0 -set path(test4) [makeFile {} test4] -set path(test5) [makeFile {} test5] +set path(test4) [makeFile "" test4] +set path(test5) [makeFile "" test5] -file delete $path(test5) +file delete -- $path(test5) test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} { set f [open $path(test4) w] - close $f + chan close $f list [catch {open "| cat < \"$path(test4)\" > \"$path(test5)\"" w} msg] $msg $::errorCode } {1 {can't write input to command: standard input was redirected} {TCL OPERATION EXEC BADREDIRECT}} test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} { @@ -426,17 +426,17 @@ test iocmd-12.3 {POSIX open access modes: WRONLY} -match regexp -body { test iocmd-12.4 {POSIX open access modes: WRONLY} {unix} { file delete $path(test3) set f [open $path(test3) w] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} puts $f xyzzy close $f set f [open $path(test3) WRONLY] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} puts -nonewline $f "ab" seek $f 0 current set x [list [catch {gets $f} msg] $msg] close $f set f [open $path(test3) r] - fconfigure $f -eofchar {} + chan configure $f -eofchar {} lappend x [gets $f] close $f set y [list 1 [format "channel \"%s\" wasn't opened for reading" $f] abzzy] @@ -470,7 +470,7 @@ test iocmd-12.10 {POSIX open access modes: BINARY} { puts -nonewline $f c ;# contents are now 5 bytes: a\nb\nc close $f set f [open $path(test1) r] - fconfigure $f -translation binary + chan configure $f -translation binary set result [string length [read $f]] close $f set result @@ -480,7 +480,7 @@ test iocmd-12.11 {POSIX open access modes: BINARY} { puts $f \u0248 ;# gets truncated to \u0048 close $f set f [open $path(test1) r] - fconfigure $f -translation binary + chan configure $f -translation binary set result [read -nonewline $f] close $f set result @@ -566,7 +566,6 @@ test ioCmd-13.11 {open ... a+ must not use O_APPEND: Bug 1773127} -setup { removeFile $f } -result 341234x6 - test iocmd-14.1 {file id parsing errors} { list [catch {eof gorp} msg] $msg $::errorCode } {1 {can not find channel named "gorp"} {TCL LOOKUP CHANNEL gorp}} @@ -603,21 +602,21 @@ test iocmd-14.10 {file id parsing errors} { list [catch {eof $f} msg] $msg } $expect -test iocmd-15.1 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy} msg] $msg -} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} -test iocmd-15.2 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy 1} msg] $msg -} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} -test iocmd-15.3 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy 1 2 3 4 5 6 7} msg] $msg -} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} -test iocmd-15.4 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy 1 2 3} msg] $msg -} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} -test iocmd-15.5 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy 1 2 3 4 5} msg] $msg -} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} +test iocmd-15.1 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy} msg] $msg +} {1 {wrong # args: should be "chan copy input output ?-size size? ?-command callback?"}} +test iocmd-15.2 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy 1} msg] $msg +} {1 {wrong # args: should be "chan copy input output ?-size size? ?-command callback?"}} +test iocmd-15.3 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy 1 2 3 4 5 6 7} msg] $msg +} {1 {wrong # args: should be "chan copy input output ?-size size? ?-command callback?"}} +test iocmd-15.4 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy 1 2 3} msg] $msg +} {1 {wrong # args: should be "chan copy input output ?-size size? ?-command callback?"}} +test iocmd-15.5 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy 1 2 3 4 5} msg] $msg +} {1 {wrong # args: should be "chan copy input output ?-size size? ?-command callback?"}} set path(test2) [makeFile {} test2] set f [open $path(test1) w] @@ -625,26 +624,26 @@ close $f set rfile [open $path(test1) r] set wfile [open $path(test2) w] -test iocmd-15.6 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy foo $wfile} msg] $msg +test iocmd-15.6 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy foo $wfile} msg] $msg } {1 {can not find channel named "foo"}} -test iocmd-15.7 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy $rfile foo} msg] $msg +test iocmd-15.7 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy $rfile foo} msg] $msg } {1 {can not find channel named "foo"}} -test iocmd-15.8 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy $wfile $wfile} msg] $msg +test iocmd-15.8 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy $wfile $wfile} msg] $msg } "1 {channel \"$wfile\" wasn't opened for reading}" -test iocmd-15.9 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy $rfile $rfile} msg] $msg +test iocmd-15.9 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy $rfile $rfile} msg] $msg } "1 {channel \"$rfile\" wasn't opened for writing}" -test iocmd-15.10 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy $rfile $wfile foo bar} msg] $msg +test iocmd-15.10 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy $rfile $wfile foo bar} msg] $msg } {1 {bad switch "foo": must be -size or -command}} -test iocmd-15.11 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy $rfile $wfile -size foo} msg] $msg +test iocmd-15.11 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy $rfile $wfile -size foo} msg] $msg } {1 {expected integer but got "foo"}} -test iocmd-15.12 {Tcl_FcopyObjCmd} {fcopy} { - list [catch {fcopy $rfile $wfile -command bar -size foo} msg] $msg +test iocmd-15.12 {Tcl_FcopyObjCmd} {chan copy} { + list [catch {chan copy $rfile $wfile -command bar -size foo} msg] $msg } {1 {expected integer but got "foo"}} close $rfile @@ -1233,7 +1232,7 @@ test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} set c [chan create {r w} foo] - note [fconfigure $c] + note [chan configure $c] close $c rename foo {} set res @@ -1242,7 +1241,7 @@ test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return ""} set c [chan create {r w} foo] - note [fconfigure $c] + note [chan configure $c] close $c rename foo {} set res @@ -1254,7 +1253,7 @@ test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { return "-bar foo -snarf x" } set c [chan create {r w} foo] - note [fconfigure $c] + note [chan configure $c] close $c rename foo {} set res @@ -1266,7 +1265,7 @@ test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -ma return "-bar" } set c [chan create {r w} foo] - note [catch {fconfigure $c} msg]; note $msg + note [catch {chan configure $c} msg]; note $msg close $c rename foo {} set res @@ -1278,7 +1277,7 @@ test iocmd-25.5 {chan configure, cgetall, bad result, not a list} -match glob -b return "\{" } set c [chan create {r w} foo] - note [catch {fconfigure $c} msg]; note $msg + note [catch {chan configure $c} msg]; note $msg close $c rename foo {} set res @@ -1290,7 +1289,7 @@ test iocmd-25.6 {chan configure, cgetall, error return} -match glob -body { return -code error BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c} msg]; note $msg + note [catch {chan configure $c} msg]; note $msg close $c rename foo {} set res @@ -1302,7 +1301,7 @@ test iocmd-25.7 {chan configure, cgetall, break return is error} -match glob -bo return -code break BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c} msg]; note $msg + note [catch {chan configure $c} msg]; note $msg close $c rename foo {} set res @@ -1314,7 +1313,7 @@ test iocmd-25.8 {chan configure, cgetall, continue return is error} -match glob return -code continue BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c} msg]; note $msg + note [catch {chan configure $c} msg]; note $msg close $c rename foo {} set res @@ -1326,7 +1325,7 @@ test iocmd-25.9 {chan configure, cgetall, custom return is error} -match glob -b return -code 777 BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c} msg]; note $msg + note [catch {chan configure $c} msg]; note $msg close $c rename foo {} set res @@ -1338,7 +1337,7 @@ test iocmd-25.10 {chan configure, cgetall, level is ignored} -match glob -body { return -level 55 -code 777 BANG } set c [chan create {r w} foo] - note [catch {fconfigure $c} msg opt]; note $msg; noteOpts $opt + note [catch {chan configure $c} msg opt]; note $msg; noteOpts $opt close $c rename foo {} set res @@ -1353,7 +1352,7 @@ test iocmd-26.1 {chan configure, set standard option} -match glob -body { oninit configure; onfinal; track; note MUST_NOT_HAPPEN; return } set c [chan create {r w} foo] - note [fconfigure $c -translation lf] + note [chan configure $c -translation lf] close $c rename foo {} set res @@ -1365,7 +1364,7 @@ test iocmd-26.2 {chan configure, set option, error return} -match glob -body { return -code error BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo bar} msg]; note $msg + note [catch {chan configure $c -rc-foo bar} msg]; note $msg close $c rename foo {} set res @@ -1374,7 +1373,7 @@ test iocmd-26.3 {chan configure, set option, ok return} -match glob -body { set res {} proc foo {args} {oninit configure; onfinal; track; return} set c [chan create {r w} foo] - note [fconfigure $c -rc-foo bar] + note [chan configure $c -rc-foo bar] close $c rename foo {} set res @@ -1386,7 +1385,7 @@ test iocmd-26.4 {chan configure, set option, break return is error} -match glob return -code break BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo bar} msg]; note $msg + note [catch {chan configure $c -rc-foo bar} msg]; note $msg close $c rename foo {} set res @@ -1398,7 +1397,7 @@ test iocmd-26.5 {chan configure, set option, continue return is error} -match gl return -code continue BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo bar} msg]; note $msg + note [catch {chan configure $c -rc-foo bar} msg]; note $msg close $c rename foo {} set res @@ -1410,7 +1409,7 @@ test iocmd-26.6 {chan configure, set option, custom return is error} -match glob return -code 444 BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo bar} msg]; note $msg + note [catch {chan configure $c -rc-foo bar} msg]; note $msg close $c rename foo {} set res @@ -1422,7 +1421,7 @@ test iocmd-26.7 {chan configure, set option, level is ignored} -match glob -body return -level 55 -code 444 BANG } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo bar} msg opt]; note $msg; noteOpts $opt + note [catch {chan configure $c -rc-foo bar} msg opt]; note $msg; noteOpts $opt close $c rename foo {} set res @@ -1435,7 +1434,7 @@ test iocmd-27.1 {chan configure, get option, ok return} -match glob -body { set res {} proc foo {args} {oninit cget cgetall; onfinal; track; return foo} set c [chan create {r w} foo] - note [fconfigure $c -rc-foo] + note [chan configure $c -rc-foo] close $c rename foo {} set res @@ -1447,7 +1446,7 @@ test iocmd-27.2 {chan configure, get option, error return} -match glob -body { return -code error BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo} msg]; note $msg + note [catch {chan configure $c -rc-foo} msg]; note $msg close $c rename foo {} set res @@ -1459,7 +1458,7 @@ test iocmd-27.3 {chan configure, get option, break return is error} -match glob return -code error BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo} msg]; note $msg + note [catch {chan configure $c -rc-foo} msg]; note $msg close $c rename foo {} set res @@ -1471,7 +1470,7 @@ test iocmd-27.4 {chan configure, get option, continue return is error} -match gl return -code continue BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo} msg]; note $msg + note [catch {chan configure $c -rc-foo} msg]; note $msg close $c rename foo {} set res @@ -1483,7 +1482,7 @@ test iocmd-27.5 {chan configure, get option, custom return is error} -match glob return -code 333 BOOM! } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo} msg]; note $msg + note [catch {chan configure $c -rc-foo} msg]; note $msg close $c rename foo {} set res @@ -1495,7 +1494,7 @@ test iocmd-27.6 {chan configure, get option, level is ignored} -match glob -body return -level 77 -code 333 BANG } set c [chan create {r w} foo] - note [catch {fconfigure $c -rc-foo} msg opt]; note $msg; noteOpts $opt + note [catch {chan configure $c -rc-foo} msg opt]; note $msg; noteOpts $opt close $c rename foo {} set res @@ -1689,7 +1688,7 @@ test iocmd-29.1 {chan blocking, no handler support} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} set c [chan create {r w} foo] - note [fconfigure $c -blocking] + note [chan configure $c -blocking] close $c rename foo {} set res @@ -1698,8 +1697,8 @@ test iocmd-29.2 {chan blocking, no handler support} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} set c [chan create {r w} foo] - note [fconfigure $c -blocking 0] - note [fconfigure $c -blocking] + note [chan configure $c -blocking 0] + note [chan configure $c -blocking] close $c rename foo {} set res @@ -1708,7 +1707,7 @@ test iocmd-29.3 {chan blocking, retrieval, handler support} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; note MUST_NOT_HAPPEN; return} set c [chan create {r w} foo] - note [fconfigure $c -blocking] + note [chan configure $c -blocking] close $c rename foo {} set res @@ -1717,8 +1716,8 @@ test iocmd-29.4 {chan blocking, resetting, handler support} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return} set c [chan create {r w} foo] - note [fconfigure $c -blocking 0] - note [fconfigure $c -blocking] + note [chan configure $c -blocking 0] + note [chan configure $c -blocking] close $c rename foo {} set res @@ -1727,8 +1726,8 @@ test iocmd-29.5 {chan blocking, setting, handler support} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return} set c [chan create {r w} foo] - note [fconfigure $c -blocking 1] - note [fconfigure $c -blocking] + note [chan configure $c -blocking 1] + note [chan configure $c -blocking] close $c rename foo {} set res @@ -1737,7 +1736,7 @@ test iocmd-29.6 {chan blocking, error return} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; error BOOM!} set c [chan create {r w} foo] - note [catch {fconfigure $c -blocking 0} msg]; note $msg + note [catch {chan configure $c -blocking 0} msg]; note $msg # Catch the close. It changes blocking mode internally, and runs into the error result. catch {close $c} rename foo {} @@ -1747,7 +1746,7 @@ test iocmd-29.7 {chan blocking, break return is error} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return -code break BOOM!} set c [chan create {r w} foo] - note [catch {fconfigure $c -blocking 0} msg]; note $msg + note [catch {chan configure $c -blocking 0} msg]; note $msg catch {close $c} rename foo {} set res @@ -1756,7 +1755,7 @@ test iocmd-29.8 {chan blocking, continue return is error} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return -code continue BOOM!} set c [chan create {r w} foo] - note [catch {fconfigure $c -blocking 0} msg]; note $msg + note [catch {chan configure $c -blocking 0} msg]; note $msg catch {close $c} rename foo {} set res @@ -1765,7 +1764,7 @@ test iocmd-29.9 {chan blocking, custom return is error} -match glob -body { set res {} proc foo {args} {oninit blocking; onfinal; track; return -code 44 BOOM!} set c [chan create {r w} foo] - note [catch {fconfigure $c -blocking 0} msg]; note $msg + note [catch {chan configure $c -blocking 0} msg]; note $msg catch {close $c} rename foo {} set res @@ -1775,7 +1774,7 @@ test iocmd-29.10 {chan blocking, level is ignored} -match glob -setup { } -body { proc foo {args} {oninit blocking; onfinal; track; return -level 99 -code 44 BANG} set c [chan create {r w} foo] - note [catch {fconfigure $c -blocking 0} msg opt]; note $msg; noteOpts $opt + note [catch {chan configure $c -blocking 0} msg opt]; note $msg; noteOpts $opt catch {close $c} return $res } -cleanup { @@ -1785,7 +1784,7 @@ test iocmd-29.11 {chan blocking, regular return ok, value ignored} -match glob - set res {} proc foo {args} {oninit blocking; onfinal; track; return BOGUS} set c [chan create {r w} foo] - note [catch {fconfigure $c -blocking 0} msg]; note $msg + note [catch {chan configure $c -blocking 0} msg]; note $msg catch {close $c} rename foo {} set res @@ -1798,7 +1797,7 @@ test iocmd-30.1 {chan watch, read interest, some return} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return IGNORED} set c [chan create {r w} foo] - note [fileevent $c readable {set tick $tick}] + note [chan event $c readable {set tick $tick}] close $c ;# 2nd watch, interest zero. rename foo {} set res @@ -1807,8 +1806,8 @@ test iocmd-30.2 {chan watch, write interest, error return} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return -code error BOOM!_IGNORED} set c [chan create {r w} foo] - note [fileevent $c writable {set tick $tick}] - note [fileevent $c writable {}] + note [chan event $c writable {set tick $tick}] + note [chan event $c writable {}] close $c rename foo {} set res @@ -1817,10 +1816,10 @@ test iocmd-30.3 {chan watch, accumulated interests} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return} set c [chan create {r w} foo] - note [fileevent $c writable {set tick $tick}] - note [fileevent $c readable {set tick $tick}] - note [fileevent $c writable {}] - note [fileevent $c readable {}] + note [chan event $c writable {set tick $tick}] + note [chan event $c readable {set tick $tick}] + note [chan event $c writable {}] + note [chan event $c readable {}] close $c rename foo {} set res @@ -1829,9 +1828,9 @@ test iocmd-30.4 {chan watch, unchanged interest not forwarded} -match glob -body set res {} proc foo {args} {oninit; onfinal; track; return} set c [chan create {r w} foo] - note [fileevent $c writable {set tick $tick}] - note [fileevent $c readable {set tick $tick}] ;# Script is changing, - note [fileevent $c readable {set tock $tock}] ;# interest does not. + note [chan event $c writable {set tick $tick}] + note [chan event $c readable {set tick $tick}] ;# Script is changing, + note [chan event $c readable {set tock $tock}] ;# interest does not. close $c ;# 3rd and 4th watch, removing the event handlers. rename foo {} set res @@ -1887,7 +1886,7 @@ test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return} set c [chan create {r w} foo] - note [fileevent $c readable {note TOCK}] + note [chan event $c readable {note TOCK}] set stop [after 10000 {note TIMEOUT}] after 1000 {note [chan postevent $c r]} vwait ::res @@ -1900,7 +1899,7 @@ test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return} set c [chan create {r w} foo] - note [fileevent $c writable {note TOCK}] + note [chan event $c writable {note TOCK}] set stop [after 10000 {note TIMEOUT}] after 1000 {note [chan postevent $c w]} vwait ::res @@ -1913,7 +1912,7 @@ test iocmd-31.8 {chan postevent after close throws error} -match glob -setup { proc foo {args} {oninit; onfinal; track; return} proc dummy args { return } set c [chan create {r w} foo] - fileevent $c readable dummy + chan event $c readable dummy } -body { close $c chan postevent $c read @@ -1941,7 +1940,7 @@ test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body { set chan [interp eval $ida { proc foo {args} {oninit seek; onfinal; track; return} set chan [chan create {r w} foo] - fconfigure $chan -buffering none + chan configure $chan -buffering none set chan }] @@ -1982,7 +1981,7 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m interp delete {} return} set chan [chan create {r w} foo] - fconfigure $chan -buffering none + chan configure $chan -buffering none set chan }] @@ -2707,8 +2706,8 @@ test iocmd.tf-24.17.bug3522560 {postevent for transfered channel} \ LOG "<- [info level 0]" } LOG THREAD-FILEEVENT - fconfigure $thech -translation binary -blocking 0 - fileevent $thech readable [list PROCESS $thech] + chan configure $thech -translation binary -blocking 0 + chan event $thech readable [list PROCESS $thech] LOG THREAD-NOEVENT-LOOP set done 0 while {!$done} { @@ -2741,7 +2740,7 @@ test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c] + note [chan configure $c] close $c notes } c] @@ -2754,7 +2753,7 @@ test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { proc foo {args} {oninit cget cgetall; onfinal; track; return ""} set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c] + note [chan configure $c] close $c notes } c] @@ -2770,7 +2769,7 @@ test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { } set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c] + note [chan configure $c] close $c notes } c] @@ -2786,7 +2785,7 @@ test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c} msg] + note [catch {chan configure $c} msg] note $msg close $c notes @@ -2802,7 +2801,7 @@ test iocmd.tf-25.5 {chan configure, cgetall, bad result, not a list} -match glob } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c} msg] + note [catch {chan configure $c} msg] note $msg close $c notes @@ -2818,7 +2817,7 @@ test iocmd.tf-25.6 {chan configure, cgetall, error return} -match glob -body { } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c} msg] + note [catch {chan configure $c} msg] note $msg close $c notes @@ -2834,7 +2833,7 @@ test iocmd.tf-25.7 {chan configure, cgetall, break return is error} -match glob } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c} msg] + note [catch {chan configure $c} msg] note $msg close $c notes @@ -2851,7 +2850,7 @@ test iocmd.tf-25.8 {chan configure, cgetall, continue return is error} -match gl } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c} msg] + note [catch {chan configure $c} msg] note $msg close $c notes @@ -2868,7 +2867,7 @@ test iocmd.tf-25.9 {chan configure, cgetall, custom return is error} -match glob } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c} msg] + note [catch {chan configure $c} msg] note $msg close $c notes @@ -2885,7 +2884,7 @@ test iocmd.tf-25.10 {chan configure, cgetall, level is ignored} -match glob -bod } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c} msg opt] + note [catch {chan configure $c} msg opt] note $msg noteOpts $opt close $c @@ -2906,7 +2905,7 @@ test iocmd.tf-26.1 {chan configure, set standard option} -match glob -body { } set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c -translation lf] + note [chan configure $c -translation lf] close $c notes } c] @@ -2921,7 +2920,7 @@ test iocmd.tf-26.2 {chan configure, set option, error return} -match glob -body } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -rc-foo bar} msg] + note [catch {chan configure $c -rc-foo bar} msg] note $msg close $c notes @@ -2934,7 +2933,7 @@ test iocmd.tf-26.3 {chan configure, set option, ok return} -match glob -body { proc foo {args} {oninit configure; onfinal; track; return} set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c -rc-foo bar] + note [chan configure $c -rc-foo bar] close $c notes } c] @@ -2949,7 +2948,7 @@ test iocmd.tf-26.4 {chan configure, set option, break return is error} -match gl } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -rc-foo bar} msg] + note [catch {chan configure $c -rc-foo bar} msg] note $msg close $c notes @@ -2966,7 +2965,7 @@ test iocmd.tf-26.5 {chan configure, set option, continue return is error} -match } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -rc-foo bar} msg] + note [catch {chan configure $c -rc-foo bar} msg] note $msg close $c notes @@ -2983,7 +2982,7 @@ test iocmd.tf-26.6 {chan configure, set option, custom return is error} -match g } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -rc-foo bar} msg] + note [catch {chan configure $c -rc-foo bar} msg] note $msg close $c notes @@ -3000,7 +2999,7 @@ test iocmd.tf-26.7 {chan configure, set option, level is ignored} -match glob -b } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -rc-foo bar} msg opt] + note [catch {chan configure $c -rc-foo bar} msg opt] note $msg noteOpts $opt close $c @@ -3019,7 +3018,7 @@ test iocmd.tf-27.1 {chan configure, get option, ok return} -match glob -body { proc foo {args} {oninit cget cgetall; onfinal; track; return foo} set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c -rc-foo] + note [chan configure $c -rc-foo] close $c notes } c] @@ -3034,7 +3033,7 @@ test iocmd.tf-27.2 {chan configure, get option, error return} -match glob -body } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -rc-foo} msg] + note [catch {chan configure $c -rc-foo} msg] note $msg close $c notes @@ -3050,7 +3049,7 @@ test iocmd.tf-27.3 {chan configure, get option, break return is error} -match gl } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -rc-foo} msg] + note [catch {chan configure $c -rc-foo} msg] note $msg close $c notes @@ -3067,7 +3066,7 @@ test iocmd.tf-27.4 {chan configure, get option, continue return is error} -match } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -rc-foo} msg] + note [catch {chan configure $c -rc-foo} msg] note $msg close $c notes @@ -3084,7 +3083,7 @@ test iocmd.tf-27.5 {chan configure, get option, custom return is error} -match g } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -rc-foo} msg] + note [catch {chan configure $c -rc-foo} msg] note $msg close $c notes @@ -3101,7 +3100,7 @@ test iocmd.tf-27.6 {chan configure, get option, level is ignored} -match glob -b } set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -rc-foo} msg opt] + note [catch {chan configure $c -rc-foo} msg opt] note $msg noteOpts $opt close $c @@ -3394,7 +3393,7 @@ test iocmd.tf-29.1 {chan blocking, no handler support} -match glob -body { proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c -blocking] + note [chan configure $c -blocking] close $c notes } c] @@ -3407,8 +3406,8 @@ test iocmd.tf-29.2 {chan blocking, no handler support} -match glob -body { proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c -blocking 0] - note [fconfigure $c -blocking] + note [chan configure $c -blocking 0] + note [chan configure $c -blocking] close $c notes } c] @@ -3421,7 +3420,7 @@ test iocmd.tf-29.3 {chan blocking, retrieval, handler support} -match glob -body proc foo {args} {oninit blocking; onfinal; track; note MUST_NOT_HAPPEN; return} set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c -blocking] + note [chan configure $c -blocking] close $c notes } c] @@ -3434,8 +3433,8 @@ test iocmd.tf-29.4 {chan blocking, resetting, handler support} -match glob -body proc foo {args} {oninit blocking; onfinal; track; return} set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c -blocking 0] - note [fconfigure $c -blocking] + note [chan configure $c -blocking 0] + note [chan configure $c -blocking] close $c notes } c] @@ -3448,8 +3447,8 @@ test iocmd.tf-29.5 {chan blocking, setting, handler support} -match glob -body { proc foo {args} {oninit blocking; onfinal; track; return} set c [chan create {r w} foo] notes [inthread $c { - note [fconfigure $c -blocking 1] - note [fconfigure $c -blocking] + note [chan configure $c -blocking 1] + note [chan configure $c -blocking] close $c notes } c] @@ -3462,7 +3461,7 @@ test iocmd.tf-29.6 {chan blocking, error return} -match glob -body { proc foo {args} {oninit blocking; onfinal; track; error BOOM!} set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -blocking 0} msg] + note [catch {chan configure $c -blocking 0} msg] note $msg # Catch the close. It changes blocking mode internally, and runs into the error result. catch {close $c} @@ -3477,7 +3476,7 @@ test iocmd.tf-29.7 {chan blocking, break return is error} -match glob -body { proc foo {args} {oninit blocking; onfinal; track; return -code break BOOM!} set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -blocking 0} msg] + note [catch {chan configure $c -blocking 0} msg] note $msg catch {close $c} notes @@ -3491,7 +3490,7 @@ test iocmd.tf-29.8 {chan blocking, continue return is error} -match glob -body { proc foo {args} {oninit blocking; onfinal; track; return -code continue BOOM!} set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -blocking 0} msg] + note [catch {chan configure $c -blocking 0} msg] note $msg catch {close $c} notes @@ -3505,7 +3504,7 @@ test iocmd.tf-29.9 {chan blocking, custom return is error} -match glob -body { proc foo {args} {oninit blocking; onfinal; track; return -code 44 BOOM!} set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -blocking 0} msg] + note [catch {chan configure $c -blocking 0} msg] note $msg catch {close $c} notes @@ -3519,7 +3518,7 @@ test iocmd.tf-29.10 {chan blocking, level is ignored} -match glob -body { proc foo {args} {oninit blocking; onfinal; track; return -level 99 -code 44 BANG} set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -blocking 0} msg opt] + note [catch {chan configure $c -blocking 0} msg opt] note $msg noteOpts $opt catch {close $c} @@ -3534,7 +3533,7 @@ test iocmd.tf-29.11 {chan blocking, regular return ok, value ignored} -match glo proc foo {args} {oninit blocking; onfinal; track; return BOGUS} set c [chan create {r w} foo] notes [inthread $c { - note [catch {fconfigure $c -blocking 0} msg] + note [catch {chan configure $c -blocking 0} msg] note $msg catch {close $c} notes @@ -3552,7 +3551,7 @@ test iocmd.tf-30.1 {chan watch, read interest, some return} -match glob -body { proc foo {args} {oninit; onfinal; track; return IGNORED} set c [chan create {r w} foo] notes [inthread $c { - note [fileevent $c readable {set tick $tick}] + note [chan event $c readable {set tick $tick}] close $c ;# 2nd watch, interest zero. notes } c] @@ -3564,8 +3563,8 @@ test iocmd.tf-30.2 {chan watch, write interest, error return} -match glob -body proc foo {args} {oninit; onfinal; track; return -code error BOOM!_IGNORED} set c [chan create {r w} foo] notes [inthread $c { - note [fileevent $c writable {set tick $tick}] - note [fileevent $c writable {}] + note [chan event $c writable {set tick $tick}] + note [chan event $c writable {}] close $c notes } c] @@ -3577,10 +3576,10 @@ test iocmd.tf-30.3 {chan watch, accumulated interests} -match glob -body { proc foo {args} {oninit; onfinal; track; return} set c [chan create {r w} foo] notes [inthread $c { - note [fileevent $c writable {set tick $tick}] - note [fileevent $c readable {set tick $tick}] - note [fileevent $c writable {}] - note [fileevent $c readable {}] + note [chan event $c writable {set tick $tick}] + note [chan event $c readable {set tick $tick}] + note [chan event $c writable {}] + note [chan event $c readable {}] close $c notes } c] @@ -3593,9 +3592,9 @@ test iocmd.tf-30.4 {chan watch, unchanged interest not forwarded} -match glob -b proc foo {args} {oninit; onfinal; track; return} set c [chan create {r w} foo] notes [inthread $c { - note [fileevent $c writable {set tick $tick}] - note [fileevent $c readable {set tick $tick}] ;# Script is changing, - note [fileevent $c readable {set tock $tock}] ;# interest does not. + note [chan event $c writable {set tick $tick}] + note [chan event $c readable {set tick $tick}] ;# Script is changing, + note [chan event $c readable {set tock $tock}] ;# interest does not. close $c ;# 3rd and 4th watch, removing the event handlers. notes } c] @@ -3643,7 +3642,7 @@ test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body { set chan [thread::send $tida { proc foo {args} {oninit seek; onfinal; track; return} set chan [chan create {r w} foo] - fconfigure $chan -buffering none + chan configure $chan -buffering none set chan }] @@ -3697,7 +3696,7 @@ test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -mat thread::exit } set chan [chan create {r w} foo] - fconfigure $chan -buffering none + chan configure $chan -buffering none set chan }] diff --git a/tests/ioTrans.test b/tests/ioTrans.test index 5a8874c..28e0bfc 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -36,7 +36,7 @@ testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] # can access this variable. set helperscript { - if {[lsearch [namespace children] ::tcltest] == -1} { + if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -967,7 +967,7 @@ test iortrans-11.0 {origin interpreter of moved transform gone} -setup { return } set chan [chan push $tempchan foo] - fconfigure $chan -buffering none + chan configure $chan -buffering none set chan }] # Move channel to 2nd interpreter, transform goes with it. @@ -1008,7 +1008,7 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces interp delete {} return} set chan [chan push [tempchan] foo] - fconfigure $chan -buffering none + chan configure $chan -buffering none set chan }] # Move channel to 2nd thread, transform goes with it. @@ -1801,7 +1801,7 @@ test iortrans.tf-11.0 {origin thread of moved transform gone} -setup { return } set chan [chan push [tempchan] foo] - fconfigure $chan -buffering none + chan configure $chan -buffering none set chan }] @@ -1846,7 +1846,7 @@ test iortrans.tf-11.1 {origin thread of moved transform destroyed during access} thread::exit } set chan [chan push [tempchan] foo] - fconfigure $chan -buffering none + chan configure $chan -buffering none set chan }] diff --git a/tests/iogt.test b/tests/iogt.test index d4c31d2..5a9a186 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -21,16 +21,16 @@ catch [list package require -exact Tcltest [info patchlevel]] namespace eval ::tcl::test::iogt { namespace import ::tcltest::* -testConstraint testchannel [llength [info commands testchannel]] +tcltest::testConstraint testchannel [llength [info commands testchannel]] -set path(dummy) [makeFile {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-= +set path(dummy) [tcltest::makeFile {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-= } dummy] # " capture coloring of quotes -set path(dummyout) [makeFile {} dummyout] +set path(dummyout) [tcltest::makeFile {} dummyout] -set path(__echo_srv__.tcl) [makeFile { +set path(__echo_srv__.tcl) [tcltest::makeFile { #!/usr/local/bin/tclsh # -*- tcl -*- # echo server @@ -60,8 +60,8 @@ proc newconn {sock rhost rport} { set conn(data) "" set conn(delay) $fdelay - fileevent $sock readable [list echoGet $c $sock] - fconfigure $sock -translation binary -buffering none -blocking 0 + chan event $sock readable [list echoGet $c $sock] + chan configure $sock -translation binary -buffering none -blocking 0 } proc echoGet {c sock} { @@ -76,7 +76,7 @@ proc echoGet {c sock} { #puts stdout "G $c $sock $conn(data) <<$conn(data)>>" ; flush stdout - if {$conn(after) == {}} { + if {$conn(after) eq ""} { set conn(after) [after $conn(delay) [list echoPut $c $sock]] } } @@ -118,7 +118,7 @@ proc echoPut {c sock} { set conn(after) [after $conn(delay) [list echoPut $c $sock]] } -#fileevent stdin readable {exit ;#cut} +#chan event stdin readable {exit ;#cut} # main socket -server newconn -myaddr 127.0.0.1 $port @@ -143,8 +143,8 @@ proc fevent {fdelay idelay blocks script data} { #puts stdout "> $port"; flush stdout set sk [socket localhost $port] - fconfigure $sk -blocking 0 -buffering full \ - -buffersize [expr {10+[llength $data]}] + chan configure $sk -blocking 0 -buffering full \ + -buffersize [expr {10 + [llength $data]}] puts -nonewline $sk $data # The channel is prepared to go off. @@ -152,7 +152,7 @@ proc fevent {fdelay idelay blocks script data} { #puts stdout ">>>>>"; flush stdout set res [uplevel 1 $script] - catch {close $sk} + catch {chan close $sk} return $res } @@ -170,11 +170,12 @@ proc id {op data} { query/maxRead { return -1 } + default {} } } proc id_optrail {var op data} { - variable $var + variable [set var] upvar 0 $var trail lappend trail $op @@ -197,7 +198,7 @@ proc id_optrail {var op data} { } proc id_fulltrail {var op data} { - namespace upvar [namespace current] $var trail + namespace upvar [namespace current] [set var] trail #puts stdout ">> $var $op $data" ; flush stdout @@ -211,6 +212,7 @@ proc id_fulltrail {var op data} { query/maxRead { set res -1 } + default {} } #catch {puts stdout "\t>* $res" ; flush stdout} @@ -221,7 +223,7 @@ proc id_fulltrail {var op data} { } proc counter {var op data} { - namespace upvar [namespace current] $var n + namespace upvar [namespace current] [set var] n switch -- $op { create/write - create/read - delete/write - delete/read - clear_read { @@ -245,11 +247,12 @@ proc counter {var op data} { query/maxRead { return $n } + default {} } } proc counter_audit {var vtrail op data} { - namespace upvar [namespace current] $var n $vtrail trail + namespace upvar [namespace current] [set var] n [set vtrail] trail switch -- $op { create/write - create/read - delete/write - delete/read - clear_read { @@ -273,6 +276,7 @@ proc counter_audit {var vtrail op data} { query/maxRead { set res $n } + default {} } lappend trail [list counter:$op $data $res] @@ -280,19 +284,19 @@ proc counter_audit {var vtrail op data} { } proc rblocks {var vtrail n op data} { - namespace upvar [namespace current] $var n $vtrail trail + namespace upvar [namespace current] [set var] n [set vtrail] trail - set res {} + set res "" switch -- $op { create/write - create/read - delete/write - delete/read - clear_read { - set buf {} + set buf "" } flush/write { } flush/read { set res $buf - set buf {} + set buf "" } write { set data @@ -308,6 +312,7 @@ proc rblocks {var vtrail n op data} { query/maxRead { set res -1 } + default {} } lappend trail [list rblock | $op $data $res | $buf] @@ -327,12 +332,12 @@ proc audit_flow {var -attach channel} { testchannel transform $channel -command [namespace code [list id_fulltrail $var]] } proc stopafter {var n -attach channel} { - namespace upvar [namespace current] $var vn + namespace upvar [namespace current] [set var] n set vn $n testchannel transform $channel -command [namespace code [list counter $var]] } proc stopafter_audit {var trail n -attach channel} { - namespace upvar [namespace current] $var vn + namespace upvar [namespace current] [set var] n set vn $n testchannel transform $channel -command [namespace code [list counter_audit $var $trail]] } @@ -344,7 +349,7 @@ proc rblocks_t {var trail n -attach channel} { # serialize an array, with keys in sorted order. proc array_sget {v} { - upvar $v a + upvar 1 $v a set res [list] foreach n [lsort [array names a]] { lappend res $n $a($n) @@ -372,11 +377,11 @@ test iogt-1.2 {stack/close} testchannel { } {} test iogt-1.3 {stack/unstack, configuration, options} testchannel { set fh [open $path(dummy) r] - set ca [asort [fconfigure $fh]] + set ca [asort [chan configure $fh]] identity -attach $fh - set cb [asort [fconfigure $fh]] + set cb [asort [chan configure $fh]] testchannel unstack $fh - set cc [asort [fconfigure $fh]] + set cc [asort [chan configure $fh]] close $fh # With this system none of the buffering, translation and encoding option # may change their values with channels stacked upon each other or not. @@ -386,13 +391,13 @@ test iogt-1.3 {stack/unstack, configuration, options} testchannel { test iogt-1.4 {stack/unstack, configuration} -setup { set fh [open $path(dummy) r] } -constraints testchannel -body { - set ca [asort [fconfigure $fh]] + set ca [asort [chan configure $fh]] identity -attach $fh - fconfigure $fh -buffering line -translation cr -encoding shiftjis + chan configure $fh -buffering line -translation cr -encoding shiftjis testchannel unstack $fh - set cc [asort [fconfigure $fh]] - list [string equal $ca $cc] [fconfigure $fh -buffering] \ - [fconfigure $fh -translation] [fconfigure $fh -encoding] + set cc [asort [chan configure $fh]] + list [string equal $ca $cc] [chan configure $fh -buffering] \ + [chan configure $fh -translation] [chan configure $fh -encoding] } -cleanup { close $fh } -result {0 line cr shiftjis} @@ -403,7 +408,7 @@ test iogt-2.0 {basic I/O going through transform} -setup { } -constraints testchannel -body { identity -attach $fin identity -attach $fout - fcopy $fin $fout + chan copy $fin $fout close $fin close $fout set fin [open $path(dummy) r] @@ -420,9 +425,9 @@ test iogt-2.1 {basic I/O, operation trail} {testchannel unix} { set ain [list]; set aout [list] audit_ops ain -attach $fin audit_ops aout -attach $fout - fconfigure $fin -buffersize 10 - fconfigure $fout -buffersize 10 - fcopy $fin $fout + chan configure $fin -buffersize 10 + chan configure $fout -buffersize 10 + chan copy $fin $fout close $fin close $fout set res "[join $ain \n]\n--------\n[join $aout \n]" @@ -464,9 +469,9 @@ test iogt-2.2 {basic I/O, data trail} {testchannel unix} { set ain [list]; set aout [list] audit_flow ain -attach $fin audit_flow aout -attach $fout - fconfigure $fin -buffersize 10 - fconfigure $fout -buffersize 10 - fcopy $fin $fout + chan configure $fin -buffersize 10 + chan configure $fout -buffersize 10 + chan copy $fin $fout close $fin close $fout set res "[join $ain \n]\n--------\n[join $aout \n]" @@ -512,9 +517,9 @@ test iogt-2.3 {basic I/O, mixed trail} {testchannel unix} { set trail [list] audit_flow trail -attach $fin audit_flow trail -attach $fout - fconfigure $fin -buffersize 20 - fconfigure $fout -buffersize 10 - fcopy $fin $fout + chan configure $fin -buffersize 20 + chan configure $fout -buffersize 10 + chan copy $fin $fout close $fin close $fout join $trail \n @@ -552,23 +557,23 @@ test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup { } } -constraints {testchannel hangs} -body { # This test to check the validity of aquired Tcl_Channel references is not - # possible because even a backgrounded fcopy will immediately start to + # possible because even a backgrounded chan copy will immediately start to # copy data, without waiting for the event loop. This is done only in case # of an underflow on the read size!. So stacking transforms after the - # fcopy will miss information, or are not used at all. + # chan copy will miss information, or are not used at all. # # I was able to circumvent this by using the echo.tcl server with a big - # delay, causing the fcopy to underflow immediately. + # delay, causing the chan copy to underflow immediately. set fin [open $path(dummy) r] fevent 1000 500 {20 20 20 10 1 1} { close $fin set fout [open dummyout w] - flush $sock; # now, or fcopy will error us out + flush $sock; # now, or chan copy will error us out # But the 1 second delay should be enough to initialize everything # else here. - fcopy $sock $fout -command [namespace code DoneCopy] - # Transform after fcopy got its handles! They should be still valid - # for fcopy. + chan copy $sock $fout -command [namespace code DoneCopy] + # Transform after chan copy got its handles! They should be still valid + # for chan copy. set trail [list] audit_ops trail -attach $fout vwait [namespace which -variable copy] @@ -585,7 +590,7 @@ test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup { rename DoneCopy {} } -result {1 {create/write create/read write flush/write flush/read delete/write delete/read}} -test iogt-4.0 {fileevent readable, after transform} -setup { +test iogt-4.0 {chan event readable, after transform} -setup { set fin [open $path(dummy) r] set data [read $fin] close $fin @@ -598,7 +603,7 @@ test iogt-4.0 {fileevent readable, after transform} -setup { fevent 1000 500 {20 20 20 10 1} { audit_flow trail -attach $sock rblocks_t rbuf trail 23 -attach $sock - fileevent $sock readable [namespace code { + chan event $sock readable [namespace code { if {[eof $sock]} { Done lappend trail "xxxxxxxxxxxxx" @@ -611,7 +616,7 @@ test iogt-4.0 {fileevent readable, after transform} -setup { #read $sock } }] - flush $sock; # Now, or fcopy will error us out + flush $sock; # Now, or chan copy will error us out # But the 1 second delay should be enough to initialize everything # else here. vwait [namespace which -variable stop] @@ -710,13 +715,13 @@ test iogt-5.0 {EOF simulation} -setup { audit_flow trail -attach $fin stopafter_audit d trail 20 -attach $fin audit_flow trail -attach $fout - fconfigure $fin -buffersize 20 - fconfigure $fout -buffersize 10 - fcopy $fin $fout + chan configure $fin -buffersize 20 + chan configure $fout -buffersize 10 + chan copy $fin $fout testchannel unstack $fin # now copy the rest in the channel lappend trail {**after unstack**} - fcopy $fin $fout + chan copy $fin $fout close $fin close $fout join $trail \n @@ -763,6 +768,7 @@ proc constX {op data} { query/maxRead { return -1 } + default {} } } proc constx {-attach channel} { diff --git a/tests/join.test b/tests/join.test index 4abe233..f6c6dbe 100644 --- a/tests/join.test +++ b/tests/join.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } diff --git a/tests/lindex.test b/tests/lindex.test index b86e2e0..2c52026 100644 --- a/tests/lindex.test +++ b/tests/lindex.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.2 namespace import -force ::tcltest::* } @@ -447,7 +447,7 @@ test lindex-17.1 {Bug 1718580} {*}{ -returnCodes 1 } -catch { unset minus } +unset -nocomplain minus # cleanup ::tcltest::cleanupTests diff --git a/tests/link.test b/tests/link.test index 00e490c..ec310de 100644 --- a/tests/link.test +++ b/tests/link.test @@ -21,9 +21,7 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testlink [llength [info commands testlink]] -foreach i {int real bool string} { - unset -nocomplain $i -} +unset -nocomplain int real bool string test link-1.1 {reading C variables from Tcl} -constraints {testlink} -setup { testlink delete @@ -296,9 +294,7 @@ test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} { catch {testlink set 0 0 0 - 0 0 0 0 0 0 0 0 0 0} catch {testlink delete} -foreach i {int real bool string wide} { - unset -nocomplain $i -} +unset -nocomplain int real bool string wide # cleanup ::tcltest::cleanupTests diff --git a/tests/linsert.test b/tests/linsert.test index 4939e5c..c10e213 100644 --- a/tests/linsert.test +++ b/tests/linsert.test @@ -11,12 +11,12 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } -catch {unset lis} +unset -nocomplain lis catch {rename p ""} test linsert-1.1 {linsert command} { @@ -107,13 +107,13 @@ test linsert-3.1 {linsert won't modify shared argument objects} { p } "a b c" test linsert-3.2 {linsert won't modify shared argument objects} { - catch {unset lis} + unset -nocomplain lis set lis [format "a \"%s\" c" "b"] linsert $lis 0 [string length $lis] } "7 a b c" # cleanup -catch {unset lis} +unset -nocomplain lis catch {rename p ""} ::tcltest::cleanupTests return diff --git a/tests/list.test b/tests/list.test index dff5d50..3ec1967 100644 --- a/tests/list.test +++ b/tests/list.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -91,33 +91,33 @@ lcheck list-2.12 a\\} {a \}b} {a \{c} lcheck list-2.13 xyz \\ 1\\\n2 lcheck list-2.14 "{ab}\\" "{ab}xy" abc -concat {} +concat "" # Check that tclListObj.c's SetListFromAny handles possible overlarge # string rep lengths in the source object. -proc slowsort list { - set result {} - set last [expr [llength $list] - 1] +proc slowsort {list} { + set result "" + set last [expr {[llength $list] - 1}] while {$last > 0} { - set minIndex [expr [llength $list] - 1] + set minIndex [expr {[llength $list] - 1}] set min [lindex $list $last] - set i [expr $minIndex-1] + set i [expr {$minIndex - 1}] while {$i >= 0} { if {[string compare [lindex $list $i] $min] < 0} { set minIndex $i set min [lindex $list $i] } - set i [expr $i-1] + set i [expr {$i - 1}] } set result [concat $result [list $min]] if {$minIndex == 0} { set list [lrange $list 1 end] } else { - set list [concat [lrange $list 0 [expr $minIndex-1]] \ - [lrange $list [expr $minIndex+1] end]] + set list [concat [lrange $list 0 [expr {$minIndex - 1}]] \ + [lrange $list [expr {$minIndex + 1}] end]] } - set last [expr $last-1] + set last [expr {$last - 1}] } return [concat $result $list] } diff --git a/tests/listObj.test b/tests/listObj.test index 937fb1d..081e88a 100644 --- a/tests/listObj.test +++ b/tests/listObj.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -21,14 +21,14 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testobj [llength [info commands testobj]] -catch {unset x} +unset -nocomplain x test listobj-1.1 {Tcl_GetListObjType} emptyTest { # Test removed; tested an internal detail # that's no longer correct, and duplicated test obj-1.1 } {} test listobj-2.1 {Tcl_SetListObj, use in lappend} { - catch {unset x} + unset -nocomplain x list [lappend x 1 abc def] [lappend x 1 ghi jkl] $x } {{1 abc def} {1 abc def 1 ghi jkl} {1 abc def 1 ghi jkl}} test listobj-2.2 {Tcl_SetListObj, use in ObjInterpProc} { @@ -42,7 +42,7 @@ test listobj-2.3 {Tcl_SetListObj, zero element count} { } {} test listobj-3.1 {Tcl_ListObjAppend, list conversion} { - catch {unset x} + unset -nocomplain x list [lappend x 1 2 abc "long string"] $x } {{1 2 abc {long string}} {1 2 abc {long string}}} test listobj-3.2 {Tcl_ListObjAppend, list conversion} { @@ -64,7 +64,7 @@ test listobj-3.5 {Tcl_ListObjAppend, force internal rep array to grow} { } {{1 1} {1 1 2 2} {1 1 2 2 3 3} {1 1 2 2 3 3 4 4} {1 1 2 2 3 3 4 4 5 5} {1 1 2 2 3 3 4 4 5 5 6 6} {1 1 2 2 3 3 4 4 5 5 6 6 7 7} {1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8} {1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8}} test listobj-4.1 {Tcl_ListObjAppendElement, list conversion} { - catch {unset x} + unset -nocomplain x list [lappend x 1] $x } {1 1} test listobj-4.2 {Tcl_ListObjAppendElement, list conversion} { diff --git a/tests/llength.test b/tests/llength.test index 169c7ca..469cd5f 100644 --- a/tests/llength.test +++ b/tests/llength.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } diff --git a/tests/lmap.test b/tests/lmap.test index 7baa77b..dd8ddf1 100644 --- a/tests/lmap.test +++ b/tests/lmap.test @@ -142,7 +142,7 @@ unset -nocomplain a # "lmap" with "continue" and "break" (non-compiled) test lmap-3.1 {continue tests} { lmap i {a b c d} { - if {[string compare $i "b"] == 0} continue + if {$i eq "b"} continue set i } } {a c d} @@ -150,7 +150,7 @@ test lmap-3.2 {continue tests} { set x 0 list [lmap i {a b c d} { incr x - if {[string compare $i "b"] != 0} continue + if {$i ne "b"} continue set i }] $x } {b 4} @@ -158,7 +158,7 @@ test lmap-3.3 {break tests} { set x 0 list [lmap i {a b c d} { incr x - if {[string compare $i "c"] == 0} break + if {$i eq "c"} break set i }] $x } {{a b} 3} @@ -308,7 +308,7 @@ test lmap-5.10 {lmap only supports local scalar variables} { test lmap-6.1 {continue tests} { apply {{} { lmap i {a b c d} { - if {[string compare $i "b"] == 0} continue + if {$i eq "b"} continue set i } }} @@ -317,7 +317,7 @@ test lmap-6.2 {continue tests} { apply {{} { list [lmap i {a b c d} { incr x - if {[string compare $i "b"] != 0} continue + if {$i ne "b"} continue set i }] $x }} @@ -326,7 +326,7 @@ test lmap-6.3 {break tests} { apply {{} { list [lmap i {a b c d} { incr x - if {[string compare $i "c"] == 0} break + if {$i eq "c"} break set i }] $x }} diff --git a/tests/load.test b/tests/load.test index cded85d..c74b7c2 100644 --- a/tests/load.test +++ b/tests/load.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/lrange.test b/tests/lrange.test index 17a757e..24d91db 100644 --- a/tests/lrange.test +++ b/tests/lrange.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } diff --git a/tests/lrepeat.test b/tests/lrepeat.test index 788bb9b..2e027dd 100644 --- a/tests/lrepeat.test +++ b/tests/lrepeat.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/lreplace.test b/tests/lreplace.test index 5f675bc..ffcd837 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -92,14 +92,13 @@ test lreplace-1.25 {lreplace command} { concat \"[lreplace {\}\ hello} end end]\" } {"\}\ "} test lreplace-1.26 {lreplace command} { - catch {unset foo} + unset -nocomplain foo set foo {a b} list [set foo [lreplace $foo end end]] \ [set foo [lreplace $foo end end]] \ [set foo [lreplace $foo end end]] } {a {} {}} - test lreplace-2.1 {lreplace errors} { list [catch lreplace msg] $msg } {1 {wrong # args: should be "lreplace list first last ?element ...?"}} @@ -131,6 +130,6 @@ test lreplace-3.1 {lreplace won't modify shared argument objects} { } "a b c" # cleanup -catch {unset foo} +unset -nocomplain foo ::tcltest::cleanupTests return diff --git a/tests/lsearch.test b/tests/lsearch.test index f36e987..e9d1cd4 100644 --- a/tests/lsearch.test +++ b/tests/lsearch.test @@ -112,11 +112,11 @@ test lsearch-4.2 {binary data} { } 1 # Make a sorted list -set l {} -set l2 {} +set l [list] +set l2 [list] for {set i 0} {$i < 100} {incr i} { lappend l $i - lappend l2 [expr {double($i)/2}] + lappend l2 [expr {($i * 1.0) / 2}] } set increasingIntegers [lsort -integer $l] set decreasingIntegers [lsort -decreasing -integer $l] @@ -127,7 +127,7 @@ set decreasingStrings [lsort -decreasing {48 6a 18b 22a 21aa 35 36}] set increasingDictionary [lsort -dictionary {48 6a 18b 22a 21aa 35 36}] set decreasingDictionary [lsort -dictionary -decreasing $increasingDictionary] -set l {} +set l [list] for {set i 0} {$i < 10} {incr i} { lappend l $i $i $i $i $i } @@ -135,14 +135,14 @@ set repeatingIncreasingIntegers [lsort -integer $l] set repeatingDecreasingIntegers [lsort -integer -decreasing $l] test lsearch-5.1 {binary search} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -integer -sorted $increasingIntegers $i] } set res } $increasingIntegers test lsearch-5.2 {binary search} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -integer -decreasing -sorted \ $decreasingIntegers $i] @@ -150,14 +150,14 @@ test lsearch-5.2 {binary search} { set res } $decreasingIntegers test lsearch-5.3 {binary search finds leftmost occurances} { - set res {} + set res [list] for {set i 0} {$i < 10} {incr i} { lappend res [lsearch -integer -sorted $repeatingIncreasingIntegers $i] } set res } [list 0 5 10 15 20 25 30 35 40 45] test lsearch-5.4 {binary search -decreasing finds leftmost occurances} { - set res {} + set res [list] for {set i 9} {$i >= 0} {incr i -1} { lappend res [lsearch -sorted -integer -decreasing \ $repeatingDecreasingIntegers $i] @@ -166,14 +166,14 @@ test lsearch-5.4 {binary search -decreasing finds leftmost occurances} { } [list 0 5 10 15 20 25 30 35 40 45] test lsearch-6.1 {integer search} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -exact -integer $increasingIntegers $i] } set res } [lrange $increasingIntegers 0 99] test lsearch-6.2 {decreasing integer search} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -exact -integer -decreasing \ $decreasingIntegers $i] @@ -181,14 +181,14 @@ test lsearch-6.2 {decreasing integer search} { set res } [lrange $decreasingIntegers 0 99] test lsearch-6.3 {sorted integer search} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -sorted -integer $increasingIntegers $i] } set res } [lrange $increasingIntegers 0 99] test lsearch-6.4 {sorted decreasing integer search} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -integer -sorted -decreasing \ $decreasingIntegers $i] @@ -197,7 +197,7 @@ test lsearch-6.4 {sorted decreasing integer search} { } [lrange $decreasingIntegers 0 99] test lsearch-7.1 {double search} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -exact -real $increasingDoubles \ [expr {double($i)/2}]] @@ -205,7 +205,7 @@ test lsearch-7.1 {double search} { set res } [lrange $increasingIntegers 0 99] test lsearch-7.2 {decreasing double search} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -exact -real -decreasing \ $decreasingDoubles [expr {double($i)/2}]] @@ -213,7 +213,7 @@ test lsearch-7.2 {decreasing double search} { set res } [lrange $decreasingIntegers 0 99] test lsearch-7.3 {sorted double search} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -sorted -real \ $increasingDoubles [expr {double($i)/2}]] @@ -221,7 +221,7 @@ test lsearch-7.3 {sorted double search} { set res } [lrange $increasingIntegers 0 99] test lsearch-7.4 {sorted decreasing double search} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -sorted -real -decreasing \ $decreasingDoubles [expr {double($i)/2}]] @@ -230,28 +230,28 @@ test lsearch-7.4 {sorted decreasing double search} { } [lrange $decreasingIntegers 0 99] test lsearch-8.1 {dictionary search} { - set res {} + set res [list] foreach val {6a 18b 21aa 22a 35 36 48} { lappend res [lsearch -exact -dictionary $increasingDictionary $val] } set res } [list 0 1 2 3 4 5 6] test lsearch-8.2 {decreasing dictionary search} { - set res {} + set res [list] foreach val {6a 18b 21aa 22a 35 36 48} { lappend res [lsearch -exact -dictionary $decreasingDictionary $val] } set res } [list 6 5 4 3 2 1 0] test lsearch-8.3 {sorted dictionary search} { - set res {} + set res [list] foreach val {6a 18b 21aa 22a 35 36 48} { lappend res [lsearch -sorted -dictionary $increasingDictionary $val] } set res } [list 0 1 2 3 4 5 6] test lsearch-8.4 {decreasing sorted dictionary search} { - set res {} + set res [list] foreach val {6a 18b 21aa 22a 35 36 48} { lappend res [lsearch -decreasing -sorted -dictionary \ $decreasingDictionary $val] @@ -260,28 +260,28 @@ test lsearch-8.4 {decreasing sorted dictionary search} { } [list 6 5 4 3 2 1 0] test lsearch-9.1 {ascii search} { - set res {} + set res [list] foreach val {18b 21aa 22a 35 36 48 6a} { lappend res [lsearch -exact -ascii $increasingStrings $val] } set res } [list 0 1 2 3 4 5 6] test lsearch-9.2 {decreasing ascii search} { - set res {} + set res [list] foreach val {18b 21aa 22a 35 36 48 6a} { lappend res [lsearch -exact -ascii $decreasingStrings $val] } set res } [list 6 5 4 3 2 1 0] test lsearch-9.3 {sorted ascii search} { - set res {} + set res [list] foreach val {18b 21aa 22a 35 36 48 6a} { lappend res [lsearch -sorted -ascii $increasingStrings $val] } set res } [list 0 1 2 3 4 5 6] test lsearch-9.4 {decreasing sorted ascii search} { - set res {} + set res [list] foreach val {18b 21aa 22a 35 36 48 6a} { lappend res [lsearch -decreasing -sorted -ascii \ $decreasingStrings $val] @@ -305,7 +305,7 @@ test lsearch-10.5 {offset searching} -returnCodes error -body { lsearch -start 1 2 } -result {missing starting index} test lsearch-10.6 {binary search with offset} { - set res {} + set res [list] for {set i 0} {$i < 100} {incr i} { lappend res [lsearch -integer -start 2 -sorted $increasingIntegers $i] } @@ -471,7 +471,7 @@ test lsearch-21.2 {lsearch shimmering crash} { } 0 test lsearch-22.1 {lsearch -bisect} -setup { - set res {} + set res [list] } -body { foreach i {0 1 5 6 7 8 15 16} { lappend res [lsearch -bisect -integer {1 4 5 7 9 15} $i] @@ -479,7 +479,7 @@ test lsearch-22.1 {lsearch -bisect} -setup { return $res } -result {-1 0 2 2 3 3 5 5} test lsearch-22.2 {lsearch -bisect, last of equals} -setup { - set res {} + set res [list] } -body { foreach i {0 1 2 3} { lappend res [lsearch -bisect -integer {0 0 1 1 1 2 2 2 3 3 3} $i] @@ -487,7 +487,7 @@ test lsearch-22.2 {lsearch -bisect, last of equals} -setup { return $res } -result {1 4 7 10} test lsearch-22.3 {lsearch -bisect decreasing order} -setup { - set res {} + set res [list] } -body { foreach i {0 1 5 6 7 8 15 16} { lappend res [lsearch -bisect -integer -decreasing {15 9 7 5 4 1} $i] @@ -495,7 +495,7 @@ test lsearch-22.3 {lsearch -bisect decreasing order} -setup { return $res } -result {5 5 3 2 2 1 0 -1} test lsearch-22.4 {lsearch -bisect, last of equals, decreasing} -setup { - set res {} + set res [list] } -body { foreach i {0 1 2 3} { lappend res [lsearch -bisect -integer -decreasing \ @@ -511,15 +511,7 @@ test lsearch-22.6 {lsearch -sorted, all equal} { } {0} # cleanup -catch {unset res} -catch {unset increasingIntegers} -catch {unset decreasingIntegers} -catch {unset increasingDoubles} -catch {unset decreasingDoubles} -catch {unset increasingStrings} -catch {unset decreasingStrings} -catch {unset increasingDictionary} -catch {unset decreasingDictionary} +unset -nocomplain res increasingIntegers decreasingIntegers increasingDoubles decreasingDoubles increasingStrings decreasingStrings increasingDictionary decreasingDictionary ::tcltest::cleanupTests return diff --git a/tests/lset.test b/tests/lset.test index 1c1300b..8624ab5 100644 --- a/tests/lset.test +++ b/tests/lset.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -470,11 +470,9 @@ test lset-16.8 {lset - append to inner list} testevalex { testevalex {lset x end end end+1 4} } {test {1 2 {3 4}}} -catch {unset noRead} -catch {unset noWrite} -catch {rename failTrace {}} -catch {unset ::x} -catch {unset ::y} +unset -nocomplain noRead noWrite +catch {rename failTrace ""} +unset -nocomplain ::x ::y # cleanup ::tcltest::cleanupTests diff --git a/tests/lsetComp.test b/tests/lsetComp.test index 6846cbf..6bc1721 100755 --- a/tests/lsetComp.test +++ b/tests/lsetComp.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -423,8 +423,7 @@ test lsetComp-3.9 {lset, compiled, flat args, error - is string preserved} { } "{ { 1 2 } { 3 4 } } { 3 4 }" catch { rename evalInProc {} } -catch { unset ::x } -catch { unset ::y } +unset -nocomplain ::x ::y # cleanup ::tcltest::cleanupTests diff --git a/tests/macOSXFCmd.test b/tests/macOSXFCmd.test index 071f11b..4c06b59 100644 --- a/tests/macOSXFCmd.test +++ b/tests/macOSXFCmd.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -21,9 +21,9 @@ cd [temporaryDirectory] # check whether macosx file attributes are supported testConstraint macosxFileAttr 0 -if {[testConstraint unix] && $tcl_platform(os) eq "Darwin"} { +if {[testConstraint unix] && ($tcl_platform(os) eq "Darwin")} { catch {file delete -force -- foo.test} - close [open foo.test w] + chan close [open foo.test w] catch { file attributes foo.test -creator testConstraint macosxFileAttr 1 @@ -104,7 +104,7 @@ test macOSXFCmd-2.7 {MacOSXSetFileAttribute - rsrclength} {macosxFileAttr notRoo close [open foo.test w] catch { set f [open foo.test/..namedfork/rsrc w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts -nonewline $f "foo" close $f } @@ -121,7 +121,7 @@ test macOSXFCmd-3.1 {MacOSXCopyFileAttributes} {macosxFileAttr notRoot} { catch { file attributes foo.test -creator FOOC -type FOOT -hidden 1 set f [open foo.test/..namedfork/rsrc w] - fconfigure $f -translation lf -eofchar {} + chan configure $f -translation lf -eofchar {} puts -nonewline $f "foo" close $f file copy foo.test bar.test diff --git a/tests/macOSXLoad.test b/tests/macOSXLoad.test index 12c77e0..ad699b2 100644 --- a/tests/macOSXLoad.test +++ b/tests/macOSXLoad.test @@ -10,15 +10,16 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } set oldTSF $::tcltest::testSingleFile set ::tcltest::testSingleFile false -if {[testConstraint unix] && $tcl_platform(os) eq "Darwin" && - ![string match *pkga* [info loaded]]} { +if {[testConstraint unix] && + ($tcl_platform(os) eq "Darwin") && + (![string match "*pkga*" [info loaded]])} { # On Darwin, test .bundle (un)loading in addition to .dylib set ext .bundle source [file join [file dirname [info script]] load.test] diff --git a/tests/mathop.test b/tests/mathop.test index f122b7b..a29eb1c 100644 --- a/tests/mathop.test +++ b/tests/mathop.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.1 namespace import -force ::tcltest::* } @@ -27,11 +27,12 @@ namespace eval ::testmathop2 { # Shared / unshared arguments # Original / imported proc TestOp {op args} { - set results {} + global errorCode + set results [list] # Non byte compiled version, shared args if {[catch {::tcl::mathop::$op {*}$args} res]} { - append res " $::errorCode" + append res " $errorCode" } lappend results $res @@ -41,20 +42,20 @@ proc TestOp {op args} { append cmd " \[format %s [list $arg]\]" } if {[catch $cmd res]} { - append res " $::errorCode" + append res " $errorCode" } lappend results $res # Non byte compiled imported if {[catch {::testmathop2::$op {*}$args} res]} { - append res " $::errorCode" + append res " $errorCode" } lappend results [string map {testmathop2 tcl::mathop} $res] # BC version - set argList1 {} - set argList2 {} - set argList3 {} + set argList1 [list] + set argList2 [list] + set argList3 [list] for {set t 0} {$t < [llength $args]} {incr t} { lappend argList1 a$t lappend argList2 \$a$t @@ -69,18 +70,18 @@ proc TestOp {op args} { set ::tcl_traceCompile 0 ;# Set to 2 to help with debug if {[catch {_TestOp {*}$args} res]} { - append res " $::errorCode" + append res " $errorCode" } set ::tcl_traceCompile 0 lappend results $res if {[catch {_TestOp2 {*}$args} res]} { - append res " $::errorCode" + append res " $errorCode" } lappend results $res if {[catch {_TestOp3 {*}$args} res]} { - append res " $::errorCode" + append res " $errorCode" } lappend results [string map {testmathop2 tcl::mathop} $res] @@ -719,14 +720,14 @@ namespace eval ::testmathop { } test mathop-20.1 { zero args, return unit } { - set res {} + set res [list] foreach op {+ * & ^ | ** < <= > >= == eq} { lappend res [TestOp $op] } set res } {0 1 -1 0 0 1 1 1 1 1 1 1} test mathop-20.2 { zero args, not allowed } { - set exp {} + set exp [list] foreach op {~ ! << >> % != ne in ni - /} { set res [TestOp $op] if {[string match "wrong # args: should be * TCL WRONGARGS" $res]} { @@ -738,17 +739,17 @@ test mathop-20.2 { zero args, not allowed } { set exp } {0 0 0 0 0 0 0 0 0 0 0} test mathop-20.3 { one arg } { - set res {} + set res [list] foreach val {7 8.3} { foreach op {+ ** - * / < <= > >= == eq !} { lappend res [TestOp $op $val] } } set res -} [list 7 7 -7 7 [expr {1.0/7.0}] 1 1 1 1 1 1 0 \ - 8.3 8.3 -8.3 8.3 [expr {1.0/8.3}] 1 1 1 1 1 1 0] +} [list 7 7 -7 7 [expr {1.0 / 7.0}] 1 1 1 1 1 1 0 \ + 8.3 8.3 -8.3 8.3 [expr {1.0 / 8.3}] 1 1 1 1 1 1 0] test mathop-20.4 { one arg, integer only ops } { - set res {} + set res [list] foreach val {23} { foreach op {& | ^ ~} { lappend res [TestOp $op $val] @@ -757,7 +758,7 @@ test mathop-20.4 { one arg, integer only ops } { set res } [list 23 23 23 -24] test mathop-20.5 { one arg, not allowed } { - set exp {} + set exp [list] foreach op {% != ne in ni << >>} { set res [TestOp $op 1] if {[string match "wrong # args: should be * TCL WRONGARGS" $res]} { @@ -769,8 +770,8 @@ test mathop-20.5 { one arg, not allowed } { set exp } {0 0 0 0 0 0 0} test mathop-20.6 { one arg, error } { - set res {} - set exp {} + set res [list] + set exp [list] foreach vals {x {1 x} {1 1 x} {1 x 1}} { # skipping - for now, knownbug... foreach op {+ * / & | ^ **} { @@ -787,7 +788,7 @@ test mathop-20.6 { one arg, error } { expr {$res eq $exp ? 0 : $res} } 0 test mathop-20.7 { multi arg } { - set res {} + set res [list] foreach vals {{1 2} {3 4 5} {4 3 2 1}} { foreach op {+ - * /} { lappend res [TestOp $op {*}$vals] @@ -796,7 +797,7 @@ test mathop-20.7 { multi arg } { set res } [list 3 -1 2 0 12 -6 60 0 10 -2 24 0] test mathop-20.8 { multi arg, double } { - set res {} + set res [list] foreach vals {{1.0 2} {3.0 4 5} {4 3.0 2 1} {1.0 -1.0 1e-18} {1.0 1.0 1e-18}} { foreach op {+ - * /} { @@ -804,10 +805,10 @@ test mathop-20.8 { multi arg, double } { } } set res -} [list 3.0 -1.0 2.0 0.5 12.0 -6.0 60.0 0.15 10.0 -2.0 24.0 [expr {2.0/3}] 1e-18 2.0 -1e-18 [expr {-1.0/1e-18}] 2.0 -1e-18 1e-18 [expr {1.0/1e-18}]] +} [list 3.0 -1.0 2.0 0.5 12.0 -6.0 60.0 0.15 10.0 -2.0 24.0 [expr {2.0 / 3}] 1e-18 2.0 -1e-18 [expr {-1.0 / 1e-18}] 2.0 -1e-18 1e-18 [expr {1.0 / 1e-18}]] test mathop-21.1 { unary ops, bitnot } { - set res {} + set res [list] lappend res [TestOp ~ 7] lappend res [TestOp ~ -5] lappend res [TestOp ~ 354657483923456] @@ -815,7 +816,7 @@ test mathop-21.1 { unary ops, bitnot } { set res } [list -8 4 -354657483923457 -123456789123456789123456790] test mathop-21.2 { unary ops, logical not } { - set res {} + set res [list] lappend res [TestOp ! 0] lappend res [TestOp ! 1] lappend res [TestOp ! true] @@ -825,7 +826,7 @@ test mathop-21.2 { unary ops, logical not } { set res } [list 1 0 0 1 0 0] test mathop-21.3 { unary ops, negation } { - set res {} + set res [list] lappend res [TestOp - 7.2] lappend res [TestOp - -5] lappend res [TestOp - -2147483648] ;# -2**31 @@ -836,7 +837,7 @@ test mathop-21.3 { unary ops, negation } { } [list -7.2 5 2147483648 9223372036854775808 -354657483923456 \ -123456789123456789123456789] test mathop-21.4 { unary ops, inversion } { - set res {} + set res [list] lappend res [TestOp / 1] lappend res [TestOp / 5] lappend res [TestOp / 5.6] @@ -847,8 +848,8 @@ test mathop-21.4 { unary ops, inversion } { } [list 1.0 0.2 0.17857142857142858 -0.125 \ 2.8196218755553604e-15 8.10000006561e-27] test mathop-21.5 { unary ops, bad values } { - set res {} - set exp {} + set res [list] + set exp [list] lappend res [TestOp / x] lappend exp "can't use non-numeric string as operand of \"/\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp - x] @@ -862,7 +863,7 @@ test mathop-21.5 { unary ops, bad values } { expr {$res eq $exp ? 0 : $res} } 0 test mathop-21.6 { unary ops, too many } { - set exp {} + set exp [list] foreach op {~ !} { set res [TestOp $op 7 8] if {[string match "wrong # args: should be * TCL WRONGARGS" $res]} { @@ -875,7 +876,7 @@ test mathop-21.6 { unary ops, too many } { } {0 0} test mathop-22.1 { bitwise ops } { - set res {} + set res [list] foreach vals {5 {1 6} {1 2 3} {1 2 3 4}} { foreach op {& | ^} { lappend res [TestOp $op {*}$vals] @@ -891,14 +892,14 @@ test mathop-22.2 { bitwise ops on bignums } { set bn [expr {~$b}] set cn [expr {~$c}] - set res {} + set res [list] foreach vals [list [list $a $b] [list $a $c] [list $b $c] \ [list $a $bn] [list $bn $c] [list $bn $cn]] { foreach op {& | ^} { lappend res [TestOp $op {*}$vals] } } - set exp {} + set exp [list] foreach d {5 7 2 1 D C 1 F E 0 -D -D 8 -9 -1 -0 -E E} { if {[string match "-*" $d]} { set d [format %X [expr 15-0x[string range $d 1 end]]] @@ -918,7 +919,7 @@ test mathop-22.3 { bitwise ops } { set small1 87345 set small2 16753 - set res {} + set res [list] foreach op {& | ^} { lappend res [TestOp $op $big1 $big2] lappend res [TestOp $op $big1 $wide2] @@ -961,8 +962,8 @@ test mathop-22.3 { bitwise ops } { 70720 \ ] test mathop-22.4 { unary ops, bad values } { - set res {} - set exp {} + set res [list] + set exp [list] 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}" @@ -973,7 +974,7 @@ test mathop-22.4 { unary ops, bad values } { } 0 test mathop-23.1 { comparison ops, numerical } { - set res {} + set res [list] set todo {5 {1 6} {1 2 2 3} {4 3 2 1} {5.0 5.0} {6 3 3 1} {5.0 5}} lappend todo [list 2342476234762482734623842342 234827463876473 3434] lappend todo [list 2653 453735910264536 453735910264537 2384762472634982746239847637] @@ -1006,7 +1007,7 @@ test mathop-23.1 { comparison ops, numerical } { 0 1 0 1 1 1 \ ] test mathop-23.2 { comparison ops, string } { - set res {} + set res [list] set todo {a {a b} {5 b b c} {d c b a} {xy xy} {gy ef ef ab}} set a x lappend todo [list $a $a] @@ -1025,7 +1026,7 @@ test mathop-23.2 { comparison ops, string } { 0 1 0 1 1 1 \ ] test mathop-23.3 { comparison ops, nonequal} { - set res {} + set res [list] foreach vals {{a b} {17.0 0x11} {foo foo} {10 10}} { foreach op {!= ne} { lappend res [TestOp $op {*}$vals] @@ -1035,7 +1036,7 @@ test mathop-23.3 { comparison ops, nonequal} { } [list 1 1 0 1 0 0 0 0 ] test mathop-24.1 { binary ops } { - set res {} + set res [list] foreach vals {{3 5} {17 7} {199 5} {293234675763434238476239486 17} \ {5 1} {0 7}} { foreach op {% << >> in ni} { @@ -1048,7 +1049,7 @@ test mathop-24.1 { binary ops } { 0 10 2 0 1 0 0 0 0 1] test mathop-24.2 { binary ops, modulo } { # Test different combinations to get all code paths - set res {} + set res [list] set bigbig 14372423674564535234543545248972634923869 set big 12135435435354435435342423948763867876 @@ -1076,8 +1077,8 @@ test mathop-24.2 { binary ops, modulo } { 0 \ ] test mathop-24.3 { binary ops, bad values } { - set res {} - set exp {} + set res [list] + set exp [list] 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}" @@ -1105,7 +1106,7 @@ test mathop-24.3 { binary ops, bad values } { expr {$res eq $exp ? 0 : $res} } 0 test mathop-24.4 { binary ops, negative shift } { - set res {} + set res [list] set big -12135435435354435435342423948763867876 set wide -12345678912345 @@ -1122,8 +1123,8 @@ test mathop-24.4 { binary ops, negative shift } { expr {$res eq $exp ? 0 : $res} } 0 test mathop-24.5 { binary ops, large shift } { - set res {} - set exp {} + set res [list] + set exp [list] set big 12135435435354435435342423948763867876 set wide 12345678912345 @@ -1160,7 +1161,7 @@ test mathop-24.5 { binary ops, large shift } { } 0 test mathop-24.6 { binary ops, shift } { # Test different combinations to get all code paths - set res {} + set res [list] set bigbig 14372423674564535234543545248972634923869 set big 12135435435354435435342423948763867876 @@ -1176,7 +1177,7 @@ test mathop-24.6 { binary ops, shift } { 385802466010 \ ] test mathop-24.7 { binary ops, list search } { - set res {} + set res [list] foreach op {in ni} { lappend res [TestOp $op 5 {7 5 8}] @@ -1186,7 +1187,7 @@ test mathop-24.7 { binary ops, list search } { set res } [list 1 1 0 0 0 1] test mathop-24.8 { binary ops, too many } { - set exp {} + set exp [list] foreach op {<< >> % != ne in ni ~ !} { set res [TestOp $op 7 8 9] if {[string match "wrong # args: should be * TCL WRONGARGS" $res]} { @@ -1221,8 +1222,8 @@ test mathop-25.20 { exp operator } {TestOp ** -1 4} 1 test mathop-25.21 { exp operator } {TestOp ** 2 63} 9223372036854775808 test mathop-25.22 { exp operator } {TestOp ** 83756485763458746358734658473567847567473 2} 7015148907444467657897585474493757781161998914521537835809623408157343003287605729 test mathop-25.23 { exp operator errors } { - set res {} - set exp {} + set res [list] + set exp [list] set huge [string repeat 145782 1000] set big 12135435435354435435342423948763867876 @@ -1255,7 +1256,7 @@ test mathop-26.1 { misc ops, size combinations } { set small1 87345 set small2 16753 - set res {} + set res [list] foreach op {+ * - /} { lappend res [TestOp $op $big1 $big2] lappend res [TestOp $op $big1 $wide2] @@ -1307,7 +1308,7 @@ test mathop-26.1 { misc ops, size combinations } { 5 \ ] test mathop-26.2 { misc ops, corner cases } { - set res {} + set res [list] lappend res [TestOp - 0 -2147483648] ;# -2**31 lappend res [TestOp - 0 -9223372036854775808] ;# -2**63 lappend res [TestOp / -9223372036854775808 -1] @@ -1316,7 +1317,7 @@ test mathop-26.2 { misc ops, corner cases } { set res } [list 2147483648 9223372036854775808 9223372036854775808 4294967296 18446744073709551616] -if 0 { +if {0} { # Compare ops to expr bytecodes namespace import ::tcl::mathop::* proc _X {a b c} { diff --git a/tests/misc.test b/tests/misc.test index 6ddc718..ca299e1 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -69,7 +69,7 @@ missing close-brace for variable name invoked from within "tstProc"}] -for {set i 1} {$i<300} {incr i} { +for {set i 1} {$i < 300} {incr i} { test misc-2.$i {hash table with sys-alloc} testhashsystemhash \ "testhashsystemhash $i" OK } diff --git a/tests/namespace-old.test b/tests/namespace-old.test index 1d8ba31..2e262e9 100644 --- a/tests/namespace-old.test +++ b/tests/namespace-old.test @@ -606,11 +606,11 @@ test namespace-old-9.5 {empty import list in "namespace import" command} { test namespace-old-9.7 {empty forget list for "namespace forget" command} { namespace forget } {} -catch {rename cmd1 {}} -catch {rename cmd2 {}} -catch {rename ncmd {}} -catch {rename ncmd1 {}} -catch {rename ncmd2 {}} +catch {rename cmd1 ""} +catch {rename cmd2 ""} +catch {rename ncmd ""} +catch {rename ncmd1 ""} +catch {rename ncmd2 ""} test namespace-old-9.8 {only exported commands are imported} { namespace import test_ns_import::cmd* set x [lsort [info commands cmd*]] @@ -725,20 +725,13 @@ test namespace-old-10.8 {scoped commands execute in namespace context} { foreach cmd [info commands test_ns_*] { rename $cmd "" } -catch {rename cmd {}} -catch {rename cmd1 {}} -catch {rename cmd2 {}} -catch {rename ncmd {}} -catch {rename ncmd1 {}} -catch {rename ncmd2 {}} -catch {unset cref} -catch {unset trigger} -catch {unset trigger2} -catch {unset sval} -catch {unset msg} -catch {unset x} -catch {unset test_ns_var_global} -catch {unset cmd} +catch {rename cmd ""} +catch {rename cmd1 ""} +catch {rename cmd2 ""} +catch {rename ncmd ""} +catch {rename ncmd1 ""} +catch {rename ncmd2 ""} +unset -nocomplain cref trigger trigger2 sval msg x test_ns_var_global cmd eval namespace delete [namespace children :: test_ns_*] # cleanup diff --git a/tests/namespace.test b/tests/namespace.test index 1d46bf0..d51a179 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -37,7 +37,7 @@ test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd namespace children :: test_ns_* } {} -catch {unset l} +unset -nocomplain l test namespace-2.1 {Tcl_GetCurrentNamespace} { list [namespace current] [namespace eval {} {namespace current}] \ [namespace eval {} {namespace current}] @@ -192,8 +192,7 @@ test namespace-7.7 {Bug 1655305} -setup { slave invokehidden infocommands } -cleanup { interp delete slave -} -result {} - +} -result "" test namespace-8.1 {TclTeardownNamespace, delete global namespace} { catch {interp delete test_interp} @@ -623,7 +622,7 @@ test namespace-14.9 {TclGetNamespaceForQualName, extra ::s are significant for v lappend l [set test_ns_1::test_ns_2::] } {1 {can't read "test_ns_1::test_ns_2::": no such variable} 2525} test namespace-14.10 {TclGetNamespaceForQualName, extra ::s are significant for vars} { - catch {unset test_ns_1::test_ns_2::} + unset -nocomplain test_ns_1::test_ns_2:: set l {} lappend l [catch {set test_ns_1::test_ns_2::} msg] $msg set test_ns_1::test_ns_2:: 314159 @@ -747,7 +746,7 @@ test namespace-16.11 {Tcl_FindCommand, relative name not found} { } } {1 {invalid command name "cmd3"}} -catch {unset x} +unset -nocomplain x test namespace-17.1 {Tcl_FindNamespaceVar, absolute name found} { catch {namespace delete {*}[namespace children :: test_ns_*]} set x 314159 @@ -813,18 +812,15 @@ test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} { set ::test_ns_1::a 0 } test_ns - rename test_ns {} + rename test_ns "" namespace eval test_ns_1 unset a set a 0 namespace eval test_ns_1 set a 1 namespace delete test_ns_1 return $a } 1 -catch {unset a} -catch {unset x} - -catch {unset l} -catch {rename foo {}} +unset -nocomplain a x l +catch {rename foo ""} test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} { catch {namespace delete {*}[namespace children :: test_ns_*]} proc foo {} {return "global foo"} @@ -861,8 +857,8 @@ test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shado } lappend l [test_ns_1::trigger] } {{foo in ::test_ns_2} {foo in ::test_ns_1::test_ns_2}} -catch {unset l} -catch {rename foo {}} +unset -nocomplain l +catch {rename foo ""} test namespace-19.1 {GetNamespaceFromObj, global name found} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -1017,7 +1013,7 @@ test namespace-25.1 {NamespaceEvalCmd, bad args} { test namespace-25.2 {NamespaceEvalCmd, bad args} -body { namespace test_ns_1 } -returnCodes error -match glob -result {unknown or ambiguous subcommand "test_ns_1": must be *} -catch {unset v} +unset -nocomplain v test namespace-25.3 {NamespaceEvalCmd, new namespace} { set v 123 namespace eval test_ns_1 { @@ -1058,7 +1054,7 @@ test namespace-25.8 {NamespaceEvalCmd, error in eval'd script} { (in namespace eval "::test_ns_1" script line 1) invoked from within "namespace eval test_ns_1 error foo bar baz"}} -catch {unset v} +unset -nocomplain v test namespace-25.9 {NamespaceEvalCmd, 545325} { namespace eval test_ns_1 info level 0 } {namespace eval test_ns_1 info level 0} @@ -1193,7 +1189,6 @@ test namespace-29.6 {NamespaceInscopeCmd, 1400572} { namespace inscope test_ns_1 {info level 0} } {namespace inscope test_ns_1 {info level 0}} - test namespace-30.1 {NamespaceOriginCmd, bad args} { catch {namespace delete {*}[namespace children :: test_ns_*]} list [catch {namespace origin} msg] $msg @@ -1374,16 +1369,14 @@ test namespace-35.2 {FreeNsNameInternalRep, resulting ref count == 0} { [catch {test_ns_1::q} msg] $msg } {::test_ns_1 {} 1 {invalid command name "test_ns_1::q"}} -catch {unset x} -catch {unset y} +unset -nocomplain x y test namespace-36.1 {DupNsNameInternalRep} { catch {namespace delete {*}[namespace children :: test_ns_*]} namespace eval test_ns_1 {} set x "::test_ns_1" list [namespace parent $x] [set y $x] [namespace parent $y] } {:: ::test_ns_1 ::} -catch {unset x} -catch {unset y} +unset -nocomplain x y test namespace-37.1 {SetNsNameFromAny, ns name found} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -2934,10 +2927,8 @@ test namespace-54.1 {leak on namespace deletion} -constraints {memory} \ } -result 0 # cleanup -catch {rename cmd1 {}} -catch {unset l} -catch {unset msg} -catch {unset trigger} +catch {rename cmd1 ""} +unset -nocomplain l msg trigger namespace delete {*}[namespace children :: test_ns_*] ::tcltest::cleanupTests return diff --git a/tests/notify.test b/tests/notify.test index d2b9123..7252b98 100755 --- a/tests/notify.test +++ b/tests/notify.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -185,11 +185,10 @@ test notify-2.5 {remove last element} \ } \ -result {one} - test notify-2.6 {remove and replace last element} \ -constraints {testevent} \ -body { - set delivered {} + set delivered "" after 10 set done 1 testevent queue one tail {lappend delivered one; expr 1} testevent queue two tail {lappend delivered two; expr 1} diff --git a/tests/nre.test b/tests/nre.test index b5eb032..85ac8d8 100644 --- a/tests/nre.test +++ b/tests/nre.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -37,7 +37,7 @@ if {[testConstraint testnrelevels]} { set depth [testnrelevels] set res {} foreach t $depth l $last { - lappend res [expr {$t-$l}] + lappend res [expr {$t - $l}] } set last $depth return $res @@ -55,7 +55,7 @@ if {[testConstraint testnrelevels]} { return [list [lrange $x 0 3] $abs] } } - proc makebody txt { + proc makebody {txt} { variable body0 return "$body0; $txt" } @@ -286,10 +286,9 @@ test nre-7.8 {bug #2910748: switch out of stale BC is not nre-aware} -setup { # yield" error list [bar] [bar] [bar] } -cleanup { - rename bar {} - rename foo {} + rename bar "" + rename foo "" } -result {1 2 3} - test nre-8.1 {nre and {*}} -body { # force an expansion that grows the evaluation stack, check that nre # adapts the TEBCdataPtr. This crashes on failure. @@ -300,8 +299,8 @@ test nre-8.1 {nre and {*}} -body { proc outer {} inner lrange [outer] 0 2 } -cleanup { - rename inner {} - rename outer {} + rename inner "" + rename outer "" } -result {1 1 1} test nre-8.2 {nre and {*}, [Bug 2415422]} -body { # force an expansion that grows the evaluation stack, check that nre @@ -315,8 +314,8 @@ test nre-8.2 {nre and {*}, [Bug 2415422]} -body { } crash } -cleanup { - rename nop {} - rename crash {} + rename nop "" + rename crash "" } # diff --git a/tests/obj.test b/tests/obj.test index 71a39b4..59bbb24 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -20,8 +20,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} { catch [list package require -exact Tcltest [info patchlevel]] testConstraint testobj [llength [info commands testobj]] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}] +testConstraint longIs32bit [expr { ( int (0x80000000) ) < 0}] +testConstraint wideBiggerThanInt [expr { ( wide (0x80000000) ) != ( int (0x80000000) )}] test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj { set r 1 @@ -551,7 +551,6 @@ test obj-30.1 {Ref counting and object deletion, simple types} testobj { lappend result [testobj refcount 2] } {{} 1024 1024 int 4 4 0 int 3 2} - test obj-31.1 {regenerate string rep of "end"} testobj { testobj freeallvars teststringobj set 1 end diff --git a/tests/oo.test b/tests/oo.test index 5d34077..9678425 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -104,10 +104,10 @@ test oo-0.9 {various types of presence of the TclOO package} { } [list TclOO $::oo::version $::oo::version] test oo-1.1 {basic test of OO functionality: no classes} { - set result {} + set result [list] lappend result [oo::object create foo] lappend result [oo::objdefine foo { - method bar args { + method bar {args} { global result lappend result {*}$args return [llength $args] @@ -3330,7 +3330,7 @@ test oo-34.1 {TIP 380: slots - presence} -setup { test oo-34.2 {TIP 380: slots - presence} { lsort [info class instances oo::Slot] } {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} -proc getMethods obj { +proc getMethods {obj} { list [lsort [info object methods $obj -all]] \ [lsort [info object methods $obj -private]] } diff --git a/tests/opt.test b/tests/opt.test index 2732d40..8ee8643 100644 --- a/tests/opt.test +++ b/tests/opt.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -28,7 +28,7 @@ set n $::tcl::OptDescN test opt-1.1 {OptKeyRegister / check that auto allocation is skipping existing keys} { list [::tcl::OptKeyRegister {} $n] [::tcl::OptKeyRegister {} [expr $n+1]] [::tcl::OptKeyRegister {}] -} "$n [expr $n+1] [expr $n+2]" +} "$n [expr {$n + 1}] [expr {$n + 2}]" test opt-2.1 {OptKeyDelete} { list [::tcl::OptKeyRegister {} testkey] \ @@ -131,21 +131,21 @@ test opt-8.10 {List utilities} { set l } {{b c 7 e} f} test opt-8.11 {List utilities} { - catch {unset x} + unset -nocomplain x set l {a {b c 7 e} f} list [::tcl::Lassign $l u v w x] \ $u $v $w [info exists x] } {3 a {b c 7 e} f 0} test opt-9.1 {Misc utilities} { - catch {unset v} + unset -nocomplain v ::tcl::SetMax v 3 ::tcl::SetMax v 7 ::tcl::SetMax v 6 set v } 7 test opt-9.2 {Misc utilities} { - catch {unset v} + unset -nocomplain v ::tcl::SetMin v 3 ::tcl::SetMin v -7 ::tcl::SetMin v 1 diff --git a/tests/package.test b/tests/package.test index da778f1..7f5af26 100644 --- a/tests/package.test +++ b/tests/package.test @@ -1260,12 +1260,12 @@ test package-15.4 {set stable, rejected} { prefer latest stable } {stable latest latest} -rename prefer {} +rename prefer "" set auto_path $oldPath package unknown $oldPkgUnknown -cleanupTests +cleanupTests } # cleanup diff --git a/tests/pid.test b/tests/pid.test index d21dbaa..7e1578f 100644 --- a/tests/pid.test +++ b/tests/pid.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/proc-old.test b/tests/proc-old.test index e45cf5c..4246f91 100644 --- a/tests/proc-old.test +++ b/tests/proc-old.test @@ -14,7 +14,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -22,10 +22,13 @@ if {[lsearch [namespace children] ::tcltest] == -1} { catch {rename t1 ""} catch {rename foo ""} -proc tproc {} {return a; return b} +proc tproc {} { + return a + return b +} test proc-old-1.1 {simple procedure call and return} {tproc} a -proc tproc x { - set x [expr $x+1] +proc tproc {x} { + set x [expr {$x + 1}] return $x } test proc-old-1.2 {simple procedure call and return} {tproc 2} 3 @@ -36,8 +39,14 @@ test proc-old-1.4 {simple procedure call and return} { proc tproc {} {return} tproc } {} -proc tproc1 {a} {incr a; return $a} -proc tproc2 {a b} {incr a; return $a} +proc tproc1 {a} { + incr a + return $a +} +proc tproc2 {a b} { + incr a + return $a +} test proc-old-1.5 {simple procedure call and return (2 procs with same body but different parameters)} { list [tproc1 123] [tproc2 456 789] } {124 457} @@ -80,7 +89,7 @@ test proc-old-2.4 {local and global variables} { set y 189 list [tproc 6] $y } {195 189} -catch {unset _undefined_} +unset -nocomplain _undefined_ test proc-old-2.5 {local and global variables} { proc tproc x { global _undefined_ @@ -97,37 +106,37 @@ test proc-old-2.6 {local and global variables} { proc do {cmd} {eval $cmd} test proc-old-3.1 {local and global arrays} { - catch {unset a} + unset -nocomplain a set a(0) 22 list [catch {do {global a; set a(0)}} msg] $msg } {0 22} test proc-old-3.2 {local and global arrays} { - catch {unset a} + unset -nocomplain a set a(x) 22 list [catch {do {global a; set a(x) newValue}} msg] $msg $a(x) } {0 newValue newValue} test proc-old-3.3 {local and global arrays} { - catch {unset a} + unset -nocomplain a set a(x) 22 set a(y) 33 list [catch {do {global a; unset a(y)}; array names a} msg] $msg } {0 x} test proc-old-3.4 {local and global arrays} { - catch {unset a} + unset -nocomplain a set a(x) 22 set a(y) 33 list [catch {do {global a; unset a; info exists a}} msg] $msg \ [info exists a] } {0 0 0} test proc-old-3.5 {local and global arrays} { - catch {unset a} + unset -nocomplain a set a(x) 22 set a(y) 33 list [catch {do {global a; unset a(y); array names a}} msg] $msg } {0 x} -catch {unset a} +unset -nocomplain a test proc-old-3.6 {local and global arrays} { - catch {unset a} + unset -nocomplain a set a(x) 22 set a(y) 33 do {global a; do {global a; unset a}; set a(z) 22} @@ -135,7 +144,7 @@ test proc-old-3.6 {local and global arrays} { } {0 z} test proc-old-3.7 {local and global arrays} { proc t1 {args} {global info; set info 1} - catch {unset a} + unset -nocomplain a set info {} do {global a; trace var a(1) w t1} set a(1) 44 @@ -143,7 +152,7 @@ test proc-old-3.7 {local and global arrays} { } 1 test proc-old-3.8 {local and global arrays} { proc t1 {args} {global info; set info 1} - catch {unset a} + unset -nocomplain a trace var a(1) w t1 set info {} do {global a; trace vdelete a(1) w t1} @@ -152,11 +161,11 @@ test proc-old-3.8 {local and global arrays} { } {} test proc-old-3.9 {local and global arrays} { proc t1 {args} {global info; set info 1} - catch {unset a} + unset -nocomplain a trace var a(1) w t1 do {global a; trace vinfo a(1)} } {{w t1}} -catch {unset a} +unset -nocomplain a test proc-old-30.1 {arguments and defaults} { proc tproc {x y z} { @@ -377,13 +386,13 @@ test proc-old-6.1 {procedure that redefines itself} { } 45 test proc-old-6.2 {procedure that deletes itself} { proc tproc {} { - rename tproc {} + rename tproc "" return 45 } tproc } 45 -proc tproc code { +proc tproc {code} { return -code $code abc } test proc-old-7.1 {return with special completion code} { @@ -483,7 +492,7 @@ test proc-old-7.15 {return with special completion code} { test proc-old-8.1 {unset and undefined local arrays} { proc t1 {} { foreach v {xxx, yyy} { - catch {unset $v} + unset -nocomplain $v } set yyy(foo) bar } diff --git a/tests/proc.test b/tests/proc.test index e06720e..4646058 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -24,7 +24,7 @@ testConstraint memory [llength [info commands memory]] catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} catch {rename {} ""} -catch {unset msg} +unset -nocomplain msg test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -196,7 +196,7 @@ catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename p ""} catch {rename {} ""} catch {rename {a b c} {}} -catch {unset msg} +unset -nocomplain msg catch {rename p ""} catch {rename t ""} diff --git a/tests/pwd.test b/tests/pwd.test index 175c852..d48c2ad 100644 --- a/tests/pwd.test +++ b/tests/pwd.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/reg.test b/tests/reg.test index a0ea850..aa91db5 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -9,7 +9,7 @@ # # Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 } @@ -229,12 +229,12 @@ namespace eval RETest { } lappend names $name append refs " \$$name" - set $name "" + set [set name] "" } - if {[string match *o* $flags]} { ;# REG_NOSUB kludge + if {[string match "*o*" $flags]} { ;# REG_NOSUB kludge set nsub 0 ;# unsigned value cannot be -1 } - if {[string match *t* $flags]} { ;# REG_EXPECT + if {[string match "*t*" $flags]} { ;# REG_EXPECT incr nsub -1 ;# the extra does not count } set erun "list \[[concat $ecmd $names]\] $refs" @@ -340,13 +340,11 @@ namespace import RETest::* list [catch {regexp (*) ign} msg] $msg } {1 {couldn't compile regular expression pattern: quantifier operand invalid}} - doing 1 "basic sanity checks" expectMatch 1.1 & abc abc abc expectNomatch 1.2 & abc def expectMatch 1.3 & abc xyabxabce abc - doing 2 "invalid option combinations" expectError 2.1 qe a INVARG expectError 2.2 qa a INVARG @@ -354,7 +352,6 @@ expectError 2.3 qx a INVARG expectError 2.4 qn a INVARG expectError 2.5 ba a INVARG - doing 3 "basic syntax" expectIndices 3.1 &NS "" a {0 -1} expectMatch 3.2 NS a| a a @@ -363,7 +360,6 @@ expectMatch 3.4 - a|b b b expectMatch 3.5 NS a||b b b expectMatch 3.6 & ab ab ab - doing 4 "parentheses" expectMatch 4.1 - (a)e ae ae a expectMatch 4.2 o (a)e ae @@ -384,7 +380,6 @@ expectMatch 4.14 SP a(?:)b ab ab expectIndices 4.15 S a(|b)c ac {0 1} {1 0} expectMatch 4.16 S a(b|)c abc abc b - doing 5 "simple one-char matching" # general case of brackets done later expectMatch 5.1 & a.b axb axb @@ -396,7 +391,6 @@ expectNomatch 5.6 & {a[^bc]d} abd expectMatch 5.7 & {a[^bc]d} aed aed expectNomatch 5.8 &p "a\[^bc]d" "a\nd" - doing 6 "context-dependent syntax" # plus odds and ends expectError 6.1 - * BADRPT @@ -420,7 +414,6 @@ expectMatch 6.18 n "x\$\n" "x\n" "x\n" expectError 6.19 - + BADRPT expectError 6.20 - ? BADRPT - doing 7 "simple quantifiers" expectMatch 7.1 &N a* aa aa expectIndices 7.2 &N a* b {0 -1} @@ -438,7 +431,6 @@ expectError 7.13 - a?* BADRPT expectError 7.14 - a+* BADRPT expectError 7.15 - a*+ BADRPT - doing 8 "braces" expectMatch 8.1 NQ "a{0,1}" "" "" expectMatch 8.2 NQ "a{0,1}" ac a @@ -468,7 +460,6 @@ expectMatch 8.25 Q "a{2,3}b" aaaab aaab expectNomatch 8.26 Q "a{2,}b" ab expectMatch 8.27 Q "a{2,}b" aaaab aaaab - doing 9 "brackets" expectMatch 9.1 & {a[bc]} ac ac expectMatch 9.2 & {a[-]} a- a- @@ -516,7 +507,6 @@ expectMatch 9.43 & {a[[b]c} "a\[c" "a\[c" expectMatch 9.44 EMP* {a[\u00fe-\u0507][\u00ff-\u0300]b} \ "a\u0102\u02ffb" "a\u0102\u02ffb" - doing 10 "anchors and newlines" expectMatch 10.1 & ^a a a expectNomatch 10.2 &^ ^a a @@ -551,7 +541,6 @@ expectError 10.30 - {$*} BADRPT expectError 10.31 - {\A*} BADRPT expectError 10.32 - {\Z*} BADRPT - doing 11 "boundary constraints" expectMatch 11.1 &LP {[[:<:]]a} a a expectMatch 11.2 &LP {[[:<:]]a} -a a @@ -586,7 +575,6 @@ expectNomatch 11.30 LP {a\M} ab expectNomatch 11.31 ILP {\Ma} a expectNomatch 11.32 ILP {a\m} a - doing 12 "character classes" expectMatch 12.1 LP {a\db} a0b a0b expectNomatch 12.2 LP {a\db} axb @@ -607,7 +595,6 @@ expectMatch 12.16 LPE {a[\d]b} a1b a1b expectMatch 12.17 LPE "a\[\\s]b" "a b" "a b" expectMatch 12.18 LPE {a[\w]b} axb axb - doing 13 "escapes" expectError 13.1 & "a\\" EESCAPE expectMatch 13.2 - {a\<b} a<b a<b @@ -644,7 +631,6 @@ expectMatch 13.32 P {a\U000012345x} "a\u12345x" "a\u12345x" expectMatch 13.33 P "a\\U1000000x" "a\ufffd0x" "a\ufffd0x" expectMatch 13.34 P {a\U1000000x} "a\ufffd0x" "a\ufffd0x" - doing 14 "back references" # ugh expectMatch 14.1 RP {a(b*)c\1} abbcbb abbcbb bb @@ -671,7 +657,6 @@ expectMatch 14.21 RP {^([bc])\1*$} bbb bbb b expectMatch 14.22 RP {^([bc])\1*$} ccc ccc c knownBug expectNomatch 14.23 R {^([bc])\1*$} bcb - doing 15 "octal escapes vs back references" # initial zero is always octal expectMatch 15.1 MP "a\\010b" "a\bb" "a\bb" @@ -694,7 +679,6 @@ expectError 15.11 b {a\12b} ESUBREG expectMatch 15.12 eAS {a\12b} a12b a12b expectMatch 15.13 MP {a\701b} a\u00381b a\u00381b - doing 16 "expanded syntax" expectMatch 16.1 xP "a b c" "abc" "abc" expectMatch 16.2 xP "a b #oops\nc\td" "abcd" "abcd" @@ -706,15 +690,12 @@ expectMatch 16.7 xP "a b\[c#d]e" "abde" "abde" expectMatch 16.8 xSPB "ab{ d" "ab\{d" "ab\{d" expectMatch 16.9 xPQ "ab{ 1 , 2 }c" "abc" "abc" - doing 17 "misc syntax" expectMatch 17.1 P a(?#comment)b ab ab - doing 18 "unmatchable REs" expectNomatch 18.1 I a^b ab - doing 19 "case independence" expectMatch 19.1 &i ab Ab Ab expectMatch 19.2 &i {a[bc]} aC aC @@ -722,7 +703,6 @@ expectNomatch 19.3 &i {a[^bc]} aB expectMatch 19.4 &iM {a[b-d]} aC aC expectNomatch 19.5 &iM {a[^b-d]} aC - doing 20 "directors and embedded options" expectError 20.1 & ***? BADPAT expectMatch 20.2 q ***? ***? ***? @@ -760,7 +740,6 @@ expectMatch 20.33 xP "(?q)a b" "a b" "a b" expectMatch 20.34 P "(?qx)a b" "a b" "a b" expectMatch 20.35 P (?qi)ab Ab Ab - doing 21 "capturing" expectMatch 21.1 - a(b)c abc abc b expectMatch 21.2 P a(?:b)c xabc abc @@ -797,7 +776,6 @@ expectMatch 21.32 - a((b|c)d+)+ abacdbd acdbd bd b expectMatch 21.33 N (.*).* abc abc abc expectMatch 21.34 N (a*)* bc "" "" - doing 22 "multicharacter collating elements" # again ugh expectMatch 22.1 &+L {a[c]e} ace ace @@ -823,7 +801,6 @@ expectMatch 22.20 &+L {a[^b]} ace ac expectMatch 22.21 &+L {a[^b]} ach ach expectNomatch 22.22 &+L {a[^b]} abe - doing 23 "lookahead constraints" expectMatch 23.1 HP a(?=b)b* ab ab expectNomatch 23.2 HP a(?=b)b* a @@ -834,7 +811,6 @@ expectMatch 23.6 HP a(?!b)b* a a expectMatch 23.7 HP (?=b)b b b expectNomatch 23.8 HP (?=b)b a - doing 24 "non-greedy quantifiers" expectMatch 24.1 PT ab+? abb ab expectMatch 24.2 PT ab+?c abbc abbc @@ -849,7 +825,6 @@ expectMatch 24.10 PT 3z*? 123zzzz456 3 expectMatch 24.11 - z*4 123zzzz456 zzzz4 expectMatch 24.12 PT z*?4 123zzzz456 zzzz4 - doing 25 "mixed quantifiers" # this is very incomplete as yet # should include | @@ -857,7 +832,6 @@ expectMatch 25.1 PNT {^(.*?)(a*)$} "xyza" xyza xyz a expectMatch 25.2 PNT {^(.*?)(a*)$} "xyzaa" xyzaa xyz aa expectMatch 25.3 PNT {^(.*?)(a*)$} "xyz" xyz xyz "" - doing 26 "tricky cases" # attempts to trick the matcher into accepting a short match expectMatch 26.1 - (week|wee)(night|knights) \ @@ -865,7 +839,6 @@ expectMatch 26.1 - (week|wee)(night|knights) \ expectMatch 26.2 RP {a(bc*).*\1} abccbccb abccbccb b expectMatch 26.3 - {a(b.[bc]*)+} abcbd abcbd bd - doing 27 "implementation misc." # duplicate arcs are suppressed expectMatch 27.1 P a(?:b|b)c abc abc @@ -874,7 +847,6 @@ expectMatch 27.2 & {[ab][ab][ab]} aba aba expectMatch 27.3 & {[ab][ab][ab][ab][ab][ab][ab]} \ "abababa" abababa - doing 28 "boundary busters etc." # color-descriptor allocation changes at 10 expectMatch 28.1 & abcdefghijkl "abcdefghijkl" abcdefghijkl @@ -902,7 +874,6 @@ expectIndices 28.11 %LP {\w+(abcdefgh)?} xyzabcdefg {0 9} {-1 -1} expectIndices 28.12 %LP {\w+(abcdefghijklmnopqrst)?} \ "xyzabcdefghijklmnopqrs" {0 21} {-1 -1} - doing 29 "incomplete matches" expectPartial 29.1 t def abc {3 2} "" expectPartial 29.2 t bcd abc {1 2} "" @@ -923,7 +894,6 @@ expectIndices 29.15 tPT abc+? xyabcdd {2 4} {7 6} expectIndices 29.16 t abcd|bc xyabc {3 4} {2 4} expectPartial 29.17 tn .*k "xx\nyyy" {3 5} "" - doing 30 "misc. oddities and old bugs" expectError 30.1 & *** BADRPT expectMatch 30.2 N a?b* abb abb @@ -939,7 +909,6 @@ expectNomatch 30.8 s abc xabcd expectMatch 30.9 HLP {(?n)^(?![t#])\S+} \ "tk\n\n#\n#\nit0" it0 - # Now for tests *not* written by Henry Spencer namespace import -force ::tcltest::test diff --git a/tests/regexp.test b/tests/regexp.test index 7cafd1b..97628b1 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -895,7 +895,7 @@ test regexp-23.11 {regexp -all and -line} { } {{1 1} {2 2} {4 4}} test regexp-24.1 {regsub -all and -line} { - foreach {v1 v2 v3} {{} {} {}} {} + lassign "" v1 v2 v3 set string "" list \ [regsub -line -all {^} $string {<&>} v1] $v1 \ @@ -903,7 +903,7 @@ test regexp-24.1 {regsub -all and -line} { [regsub -line -all {$} $string {<&>} v3] $v3 } {1 <> 1 <> 1 <>} test regexp-24.2 {regsub -all and -line} { - foreach {v1 v2 v3} {{} {} {}} {} + lassign "" v1 v2 v3 set string "\n" list \ [regsub -line -all {^} $string {<&>} v1] $v1 \ @@ -911,7 +911,7 @@ test regexp-24.2 {regsub -all and -line} { [regsub -line -all {$} $string {<&>} v3] $v3 } [list 2 "<>\n<>" 2 "<>\n<>" 2 "<>\n<>"] test regexp-24.3 {regsub -all and -line} { - foreach {v1 v2 v3} {{} {} {}} {} + lassign "" v1 v2 v3 set string "\n\n" list \ [regsub -line -all {^} $string {<&>} v1] $v1 \ @@ -919,7 +919,7 @@ test regexp-24.3 {regsub -all and -line} { [regsub -line -all {$} $string {<&>} v3] $v3 } [list 3 "<>\n<>\n<>" 3 "<>\n<>\n<>" 3 "<>\n<>\n<>"] test regexp-24.4 {regsub -all and -line} { - foreach {v1 v2 v3} {{} {} {}} {} + lassign "" v1 v2 v3 set string "a" list \ [regsub -line -all {^} $string {<&>} v1] $v1 \ @@ -927,7 +927,7 @@ test regexp-24.4 {regsub -all and -line} { [regsub -line -all {$} $string {<&>} v3] $v3 } [list 1 "<>a" 1 "<a>" 1 "a<>"] test regexp-24.5 {regsub -all and -line} { - foreach {v1 v2 v3} {{} {} {}} {} + lassign "" v1 v2 v3 set string "a\n" list \ [regsub -line -all {^} $string {<&>} v1] $v1 \ @@ -935,7 +935,7 @@ test regexp-24.5 {regsub -all and -line} { [regsub -line -all {$} $string {<&>} v3] $v3 } [list 2 "<>a\n<>" 2 "<a>\n<>" 2 "a<>\n<>"] test regexp-24.6 {regsub -all and -line} { - foreach {v1 v2 v3} {{} {} {}} {} + lassign "" v1 v2 v3 set string "\na" list \ [regsub -line -all {^} $string {<&>} v1] $v1 \ @@ -943,7 +943,7 @@ test regexp-24.6 {regsub -all and -line} { [regsub -line -all {$} $string {<&>} v3] $v3 } [list 2 "<>\n<>a" 2 "<>\n<a>" 2 "<>\na<>"] test regexp-24.7 {regsub -all and -line} { - foreach {v1 v2 v3} {{} {} {}} {} + lassign "" v1 v2 v3 set string "ab\n" list \ [regsub -line -all {^} $string {<&>} v1] $v1 \ @@ -951,7 +951,7 @@ test regexp-24.7 {regsub -all and -line} { [regsub -line -all {$} $string {<&>} v3] $v3 } [list 2 "<>ab\n<>" 2 "<ab>\n<>" 2 "ab<>\n<>"] test regexp-24.8 {regsub -all and -line} { - foreach {v1 v2 v3} {{} {} {}} {} + lassign "" v1 v2 v3 set string "a\nb" list \ [regsub -line -all {^} $string {<&>} v1] $v1 \ @@ -959,7 +959,7 @@ test regexp-24.8 {regsub -all and -line} { [regsub -line -all {$} $string {<&>} v3] $v3 } [list 2 "<>a\n<>b" 2 "<a>\n<b>" 2 "a<>\nb<>"] test regexp-24.9 {regsub -all and -line} { - foreach {v1 v2 v3} {{} {} {}} {} + lassign "" v1 v2 v3 set string "a\nb\n" list \ [regsub -line -all {^} $string {<&>} v1] $v1 \ @@ -967,7 +967,7 @@ test regexp-24.9 {regsub -all and -line} { [regsub -line -all {$} $string {<&>} v3] $v3 } [list 3 "<>a\n<>b\n<>" 3 "<a>\n<b>\n<>" 3 "a<>\nb<>\n<>"] test regexp-24.10 {regsub -all and -line} { - foreach {v1 v2 v3} {{} {} {}} {} + lassign "" v1 v2 v3 set string "a\nb\nc" list \ [regsub -line -all {^} $string {<&>} v1] $v1 \ diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 94fb90e..d73966a 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/registry.test b/tests/registry.test index 77588e3..cddc7c9 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -10,7 +10,7 @@ # Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved. # Copyright (c) 1998-1999 by Scriptics Corporation. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/remote.tcl b/tests/remote.tcl index 097e41f..c377bf5 100644 --- a/tests/remote.tcl +++ b/tests/remote.tcl @@ -12,7 +12,7 @@ # Initialize message delimitor # Initialize command array -catch {unset command} +unset -nocomplain command set command(0) "" set callerSocket "" @@ -22,7 +22,7 @@ if {![info exists VERBOSE]} { } proc __doCommands__ {l s} { - global callerSocket VERBOSE + global callerSocket VERBOSE errorInfo if {$VERBOSE} { puts "--- Server executing the following for socket $s:" @@ -30,22 +30,22 @@ proc __doCommands__ {l s} { puts "---" } set callerSocket $s - set ::errorInfo "" + set errorInfo "" set code [catch {uplevel "#0" $l} msg] - return [list $code $::errorInfo $msg] + return [list $code $errorInfo $msg] } proc __readAndExecute__ {s} { global command VERBOSE set l [gets $s] - if {[string compare $l "--Marker--Marker--Marker--"] == 0} { + if {$l eq "--Marker--Marker--Marker--"} { puts $s [__doCommands__ $command($s) $s] puts $s "--Marker--Marker--Marker--" set command($s) "" return } - if {[string compare $l ""] == 0} { + if {$l eq ""} { if {[eof $s]} { if {$VERBOSE} { puts "Server closing $s, eof from client" @@ -72,13 +72,13 @@ proc __accept__ {s a p} { puts "Server accepts new connection from $a:$p on $s" } set command($s) "" - fconfigure $s -buffering line -translation crlf - fileevent $s readable [list __readAndExecute__ $s] + chan configure $s -buffering line -translation crlf + chan event $s readable [list __readAndExecute__ $s] } set serverIsSilent 0 for {set i 0} {$i < $argc} {incr i} { - if {[string compare -serverIsSilent [lindex $argv $i]] == 0} { + if {"-serverIsSilent" eq [lindex $argv $i]} { set serverIsSilent 1 break } @@ -90,9 +90,9 @@ if {![info exists serverPort]} { } if {![info exists serverPort]} { for {set i 0} {$i < $argc} {incr i} { - if {[string compare -port [lindex $argv $i]] == 0} { - if {$i < [expr $argc - 1]} { - set serverPort [lindex $argv [expr $i + 1]] + if {"-port" eq [lindex $argv $i]} { + if {$i < ($argc - 1)} { + set serverPort [lindex $argv [expr {$i + 1}]] } break } @@ -109,9 +109,9 @@ if {![info exists serverAddress]} { } if {![info exists serverAddress]} { for {set i 0} {$i < $argc} {incr i} { - if {[string compare -address [lindex $argv $i]] == 0} { - if {$i < [expr $argc - 1]} { - set serverAddress [lindex $argv [expr $i + 1]] + if {"-address" eq [lindex $argv $i]} { + if {$i < ($argc - 1)} { + set serverAddress [lindex $argv [expr {$i + 1}]] } break } @@ -146,8 +146,8 @@ if {$serverIsSilent == 0} { flush stdout } -proc getPort sock { - lindex [fconfigure $sock -sockname] 2 +proc getPort {sock} { + lindex [chan configure $sock -sockname] 2 } if {[catch {set serverSocket \ diff --git a/tests/rename.test b/tests/rename.test index 1fa0441..7246f26 100644 --- a/tests/rename.test +++ b/tests/rename.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/safe.test b/tests/safe.test index 4a2792e..a330662 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -12,7 +12,7 @@ package require Tcl 8.5 -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/scan.test b/tests/scan.test index 97ad5eb..b40a246 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -11,13 +11,13 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } testConstraint wideIs64bit \ - [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] + [expr {( ( wide (0x80000000) ) > 0) && ( ( wide (0x8000000000000000) ) < 0)}] test scan-1.1 {BuildCharSet, CharInSet} { list [scan foo {%[^o]} x] $x @@ -44,7 +44,7 @@ test scan-1.8 {BuildCharSet, CharInSet} { list [scan def-abc {%[^c-a]} x] $x } {1 def-} test scan-1.9 {BuildCharSet, CharInSet no match} { - catch {unset x} + unset -nocomplain x list [scan {= f} {= %[TF]} x] [info exists x] } {0 0} @@ -243,7 +243,7 @@ test scan-4.40.1 {Tcl_ScanObjCmd, base-16 integer scanning} { list [scan {0xF 0x00A0B 0X0XF} {%x %x %x} x y z] $x $y $z } {3 15 2571 0} test scan-4.40.2 {Tcl_ScanObjCmd, base-16 integer scanning} { - catch {unset x} + unset -nocomplain x list [scan {xF} {%x} x] [info exists x] } {0 0} test scan-4.40.3 {Tcl_ScanObjCmd, base-2 integer scanning} { @@ -321,9 +321,10 @@ test scan-4.59 {Tcl_ScanObjCmd, float scanning} { } {1 6} test scan-4.60 {Tcl_ScanObjCmd, set errors} { - set x {} - set y {} - catch {unset z}; array set z {} + set x "" + set y "" + unset -nocomplain z + array set z {} set result [list [catch {scan {abc def ghi} {%s%s%s} x z y} msg] \ $msg $x $y] unset z @@ -331,8 +332,10 @@ test scan-4.60 {Tcl_ScanObjCmd, set errors} { } {1 {can't set "z": variable is array} abc ghi} test scan-4.61 {Tcl_ScanObjCmd, set errors} { set x {} - catch {unset y}; array set y {} - catch {unset z}; array set z {} + unset -nocomplain y + array set y {} + unset -nocomplain z + array set z {} set result [list [catch {scan {abc def ghi} {%s%s%s} x z y} msg] \ $msg $x] unset y @@ -346,19 +349,19 @@ proc int_range {} { for { set MIN_INT 1 } { int($MIN_INT) > 0 } {} { set MIN_INT [expr { $MIN_INT << 1 }] } - set MIN_INT [expr {int($MIN_INT)}] + set MIN_INT [expr { int ($MIN_INT)}] set MAX_INT [expr { ~ $MIN_INT }] return [list $MIN_INT $MAX_INT] } test scan-4.62 {scanning of large and negative octal integers} { - foreach { MIN_INT MAX_INT } [int_range] {} + lassign [int_range] MIN_INT MAX_INT set scanstring [format {%o %o %o} -1 $MIN_INT $MAX_INT] list [scan $scanstring {%o %o %o} a b c] \ [expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }] } {3 1 1 1} test scan-4.63 {scanning of large and negative hex integers} { - foreach { MIN_INT MAX_INT } [int_range] {} + lassign [int_range] MIN_INT MAX_INT set scanstring [format {%x %x %x} -1 $MIN_INT $MAX_INT] list [scan $scanstring {%x %x %x} a b c] \ [expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }] @@ -542,31 +545,31 @@ test scan-8.11 {error conditions} { list [scan "1 2" "%d %d %d %d" a b c d] $a $b $c $d } {2 1 2 {} {}} test scan-8.12 {error conditions} { - catch {unset a} + unset -nocomplain a set a(0) 44 list [catch {scan 44 %d a} msg] $msg } {1 {can't set "a": variable is array}} test scan-8.13 {error conditions} { - catch {unset a} + unset -nocomplain a set a(0) 44 list [catch {scan 44 %c a} msg] $msg } {1 {can't set "a": variable is array}} test scan-8.14 {error conditions} { - catch {unset a} + unset -nocomplain a set a(0) 44 list [catch {scan 44 %s a} msg] $msg } {1 {can't set "a": variable is array}} test scan-8.15 {error conditions} { - catch {unset a} + unset -nocomplain a set a(0) 44 list [catch {scan 44 %f a} msg] $msg } {1 {can't set "a": variable is array}} test scan-8.16 {error conditions} { - catch {unset a} + unset -nocomplain a set a(0) 44 list [catch {scan 44 %f a} msg] $msg } {1 {can't set "a": variable is array}} -catch {unset a} +unset -nocomplain a test scan-8.17 {error conditions} { list [catch {scan 44 %2c a} msg] $msg } {1 {field width may not be specified in %c conversion}} @@ -608,7 +611,7 @@ test scan-10.4 {miscellaneous tests} { list [catch {scan ab%c14 ab%%c%d a} msg] $msg $a } {0 1 14} test scan-10.5 {miscellaneous tests} { - catch {unset arr} + unset -nocomplain arr set arr(2) {} list [catch {scan ab%c14 ab%%c%d arr(2)} msg] $msg $arr(2) } {0 1 14} diff --git a/tests/security.test b/tests/security.test index eeabc9c..e9e0f1d 100644 --- a/tests/security.test +++ b/tests/security.test @@ -30,7 +30,6 @@ proc CB {} { return $ret } - test security-1.1 {tcl_endOfPreviousWord} { catch {tcl_startOfPreviousWord x {[BUG]}} CB diff --git a/tests/set-old.test b/tests/set-old.test index 52dc0ff..7d8fc91 100644 --- a/tests/set-old.test +++ b/tests/set-old.test @@ -13,16 +13,16 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } -proc ignore args {} +proc ignore {args} {} # Simple variable operations. -catch {unset a} +unset -nocomplain a test set-old-1.1 {basic variable setting and unsetting} { set a 22 } 22 @@ -42,7 +42,7 @@ test set-old-1.4 {basic variable setting and unsetting} { # Basic array operations. -catch {unset a} +unset -nocomplain a set a(xyz) 2 set a(44) 3 set {a(a long name)} test @@ -75,11 +75,11 @@ test set-old-2.9 {basic array operations} { lsort [array names a] } {{a long name} xyz} test set-old-2.10 {basic array operations} { - catch {unset b} + unset -nocomplain b list [catch {set b(123)} msg] $msg } {1 {can't read "b(123)": no such variable}} test set-old-2.11 {basic array operations} { - catch {unset b} + unset -nocomplain b set b 44 list [catch {set b(123)} msg] $msg } {1 {can't read "b(123)": variable isn't array}} @@ -101,11 +101,11 @@ test set-old-3.2 {set command} { list [catch {set x y z} msg] $msg } {1 {wrong # args: should be "set varName ?newValue?"}} test set-old-3.3 {set command} { - catch {unset a} + unset -nocomplain a list [catch {set a} msg] $msg } {1 {can't read "a": no such variable}} test set-old-3.4 {set command} { - catch {unset a} + unset -nocomplain a set a(14) 83 list [catch {set a 22} msg] $msg } {1 {can't set "a": variable is array}} @@ -113,32 +113,32 @@ test set-old-3.4 {set command} { # Test the corner-cases of parsing array names, using set and unset. test set-old-4.1 {parsing array names} { - catch {unset a} + unset -nocomplain a set a(()) 44 list [catch {array names a} msg] $msg } {0 ()} test set-old-4.2 {parsing array names} { - catch {unset a a(abcd} + unset -nocomplain a a(abcd set a(abcd 33 info exists a(abcd } 1 test set-old-4.3 {parsing array names} { - catch {unset a a(abcd} + unset -nocomplain a a(abcd set a(abcd 33 list [catch {array names a} msg] $msg } {0 {}} test set-old-4.4 {parsing array names} { - catch {unset a abcd)} + unset -nocomplain a abcd) set abcd) 33 info exists abcd) } 1 test set-old-4.5 {parsing array names} { set a(bcd yyy - catch {unset a} + unset -nocomplain a list [catch {set a(bcd} msg] $msg } {0 yyy} test set-old-4.6 {parsing array names} { - catch {unset a} + unset -nocomplain a set a 44 list [catch {set a(bcd test} msg] $msg } {0 test} @@ -146,21 +146,21 @@ test set-old-4.6 {parsing array names} { # Errors in reading variables test set-old-5.1 {errors in reading variables} { - catch {unset a} + unset -nocomplain a list [catch {set a} msg] $msg } {1 {can't read "a": no such variable}} test set-old-5.2 {errors in reading variables} { - catch {unset a} + unset -nocomplain a set a 44 list [catch {set a(18)} msg] $msg } {1 {can't read "a(18)": variable isn't array}} test set-old-5.3 {errors in reading variables} { - catch {unset a} + unset -nocomplain a set a(6) 44 list [catch {set a(18)} msg] $msg } {1 {can't read "a(18)": no such element in array}} test set-old-5.4 {errors in reading variables} { - catch {unset a} + unset -nocomplain a set a(6) 44 list [catch {set a} msg] $msg } {1 {can't read "a": variable is array}} @@ -168,22 +168,22 @@ test set-old-5.4 {errors in reading variables} { # Errors and other special cases in writing variables test set-old-6.1 {creating array during write} { - catch {unset a} + unset -nocomplain a trace var a rwu ignore list [catch {set a(14) 186} msg] $msg [array names a] } {0 186 14} test set-old-6.2 {errors in writing variables} { - catch {unset a} + unset -nocomplain a set a xxx list [catch {set a(14) 186} msg] $msg } {1 {can't set "a(14)": variable isn't array}} test set-old-6.3 {errors in writing variables} { - catch {unset a} + unset -nocomplain a set a(100) yyy list [catch {set a 2} msg] $msg } {1 {can't set "a": variable is array}} test set-old-6.4 {expanding variable size} { - catch {unset a} + unset -nocomplain a list [set a short] [set a "longer name"] [set a "even longer name"] \ [set a "a much much truly longer name"] } {short {longer name} {even longer name} {a much much truly longer name}} @@ -191,7 +191,7 @@ test set-old-6.4 {expanding variable size} { # Unset command, Tcl_UnsetVar procedures test set-old-7.1 {unset command} { - catch {unset a}; catch {unset b}; catch {unset c}; catch {unset d} + unset -nocomplain a b c d set a 44 set b 55 set c 66 @@ -206,21 +206,21 @@ test set-old-7.2 {unset command} { # Used to return: #{1 {wrong # args: should be "unset ?-nocomplain? ?--? ?varName ...?"}} test set-old-7.3 {unset command} { - catch {unset a} + unset -nocomplain a list [catch {unset a} msg] $msg } {1 {can't unset "a": no such variable}} test set-old-7.4 {unset command} { - catch {unset a} + unset -nocomplain a set a 44 list [catch {unset a(14)} msg] $msg } {1 {can't unset "a(14)": variable isn't array}} test set-old-7.5 {unset command} { - catch {unset a} + unset -nocomplain a set a(0) xx list [catch {unset a(14)} msg] $msg } {1 {can't unset "a(14)": no such element in array}} test set-old-7.6 {unset command} { - catch {unset a}; catch {unset b}; catch {unset c} + unset -nocomplain a b c set a foo set c gorp list [catch {unset a a a(14)} msg] $msg [info exists c] @@ -255,19 +255,19 @@ test set-old-7.9 {unsetting globals from within procedures} { concat [p1] [list [catch {set y} msg] $msg] } {0 55 0 55} test set-old-7.10 {unset command} { - catch {unset a} + unset -nocomplain a set a(14) 22 unset a(14) list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2 } {1 {can't read "a(14)": no such element in array} 0 {}} test set-old-7.11 {unset command} { - catch {unset a} + unset -nocomplain a set a(14) 22 unset a list [catch {set a(14)} msg] $msg [catch {array names a} msg2] $msg2 } {1 {can't read "a(14)": no such variable} 0 {}} test set-old-7.12 {unset command, -nocomplain} { - catch {unset a} + unset -nocomplain a list [info exists a] [catch {unset -nocomplain a}] [info exists a] } {0 0 0} test set-old-7.13 {unset command, -nocomplain} { @@ -315,11 +315,11 @@ test set-old-8.2 {array command} { list [catch {array a} msg] $msg } {1 {wrong # args: should be "array anymore arrayName searchId"}} test set-old-8.3 {array command} { - catch {unset a} + unset -nocomplain a list [catch {array anymore a b} msg] $msg } {1 {"a" isn't an array}} test set-old-8.4 {array command} { - catch {unset a} + unset -nocomplain a set a 44 list [catch {array anymore a b} msg] $msg } {1 {"a" isn't an array}} @@ -332,12 +332,12 @@ test set-old-8.5 {array command} { foo } {1 {"x" isn't an array}} test set-old-8.6 {array command} { - catch {unset a} + unset -nocomplain a set a(22) 3 list [catch {array gorp a} msg] $msg } {1 {unknown or ambiguous subcommand "gorp": must be anymore, donesearch, exists, get, names, nextelement, set, size, startsearch, statistics, or unset}} test set-old-8.7 {array command, anymore option} { - catch {unset a} + unset -nocomplain a list [catch {array anymore a x} msg] $msg } {1 {"a" isn't an array}} test set-old-8.8 {array command, anymore option, array doesn't exist yet but has compiler-allocated procedure slot} { @@ -350,7 +350,7 @@ test set-old-8.8 {array command, anymore option, array doesn't exist yet but has list [catch {foo 1} msg] $msg } {1 {"a" isn't an array}} test set-old-8.9 {array command, donesearch option} { - catch {unset a} + unset -nocomplain a list [catch {array donesearch a x} msg] $msg } {1 {"a" isn't an array}} test set-old-8.10 {array command, donesearch option, array doesn't exist yet but has compiler-allocated procedure slot} { @@ -366,11 +366,11 @@ test set-old-8.11 {array command, exists option} { list [catch {array exists a b} msg] $msg } {1 {wrong # args: should be "array exists arrayName"}} test set-old-8.12 {array command, exists option} { - catch {unset a} + unset -nocomplain a array exists a } {0} test set-old-8.13 {array command, exists option} { - catch {unset a} + unset -nocomplain a set a(0) 1 array exists a } {1} @@ -390,23 +390,23 @@ test set-old-8.16 {array command, get option} { list [catch {array get a b c} msg] $msg } {1 {wrong # args: should be "array get arrayName ?pattern?"}} test set-old-8.17 {array command, get option} { - catch {unset a} + unset -nocomplain a array get a } {} test set-old-8.18 {array command, get option} { - catch {unset a} + unset -nocomplain a set a(22) 3 - set {a(long name)} {} + set {a(long name)} "" lsort [array get a] } {{} 22 3 {long name}} test set-old-8.19 {array command, get option (unset variable)} { - catch {unset a} + unset -nocomplain a set a(x) 3 trace var a(y) w ignore array get a } {x 3} test set-old-8.20 {array command, get option, with pattern} { - catch {unset a} + unset -nocomplain a set a(x1) 3 set a(x2) 4 set a(x3) 5 @@ -424,34 +424,34 @@ test set-old-8.21 {array command, get option, array doesn't exist yet but has co list [catch {foo 1} msg] $msg } {0 {}} test set-old-8.22 {array command, names option} { - catch {unset a} + unset -nocomplain a set a(22) 3 list [catch {array names a 4 5} msg] $msg } {1 {bad option "4": must be -exact, -glob, or -regexp}} test set-old-8.23 {array command, names option} { - catch {unset a} + unset -nocomplain a array names a } {} test set-old-8.24 {array command, names option} { - catch {unset a} + unset -nocomplain a set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx list [catch {lsort [array names a]} msg] $msg } {0 {22 Textual_name {name with spaces}}} test set-old-8.25 {array command, names option} { - catch {unset a} + unset -nocomplain a set a(22) 3; set a(33) 44; trace var a(xxx) w ignore list [catch {lsort [array names a]} msg] $msg } {0 {22 33}} test set-old-8.26 {array command, names option} { - catch {unset a} + unset -nocomplain a set a(22) 3; set a(33) 44; trace var a(xxx) w ignore set a(xxx) value list [catch {lsort [array names a]} msg] $msg } {0 {22 33 xxx}} test set-old-8.27 {array command, names option} { - catch {unset a} + unset -nocomplain a set a(axy) 3 set a(bxy) 44 set a(no) yes @@ -471,7 +471,7 @@ test set-old-8.29 {array command, nextelement option} { list [catch {array nextelement a} msg] $msg } {1 {wrong # args: should be "array nextelement arrayName searchId"}} test set-old-8.30 {array command, nextelement option} { - catch {unset a} + unset -nocomplain a list [catch {array nextelement a b} msg] $msg } {1 {"a" isn't an array}} test set-old-8.31 {array command, nextelement option, array doesn't exist yet but has compiler-allocated procedure slot} { @@ -493,12 +493,12 @@ test set-old-8.34 {array command, set option} { list [catch {array set a "a \{ c"} msg] $msg } {1 {unmatched open brace in list}} test set-old-8.35 {array command, set option} { - catch {unset a} + unset -nocomplain a set a 44 list [catch {array set a {a b c d}} msg] $msg } {1 {can't set "a(a)": variable isn't array}} test set-old-8.36 {array command, set option} { - catch {unset a} + unset -nocomplain a set a(xx) yy array set a {b c d e} lsort [array get a] @@ -513,28 +513,28 @@ test set-old-8.37 {array command, set option, array doesn't exist yet but has co list [catch {foo 1} msg] $msg } {0 {}} test set-old-8.38 {array command, set option} { - catch {unset aVaRnAmE} + unset -nocomplain aVaRnAmE array set aVaRnAmE {} list [info exists aVaRnAmE] [catch {set aVaRnAmE} msg] $msg } {1 1 {can't read "aVaRnAmE": variable is array}} test set-old-8.38.1 {array command, set scalar} { - catch {unset aVaRnAmE} + unset -nocomplain aVaRnAmE set aVaRnAmE 1 list [catch {array set aVaRnAmE {}} msg] $msg } {1 {can't array set "aVaRnAmE": variable isn't array}} test set-old-8.38.2 {array command, set alias} { - catch {unset aVaRnAmE} + unset -nocomplain aVaRnAmE upvar 0 aVaRnAmE anAliAs array set anAliAs {} list [array exists aVaRnAmE] [catch {set anAliAs} msg] $msg } {1 1 {can't read "anAliAs": variable is array}} test set-old-8.38.3 {array command, set element alias} { - catch {unset aVaRnAmE} + unset -nocomplain aVaRnAmE list [catch {upvar 0 aVaRnAmE(elem) elemAliAs}] \ [catch {array set elemAliAs {}} msg] $msg } {0 1 {can't array set "elemAliAs": variable isn't array}} test set-old-8.38.4 {array command, empty set with populated array} { - catch {unset aVaRnAmE} + unset -nocomplain aVaRnAmE array set aVaRnAmE [list e1 v1 e2 v2] array set aVaRnAmE {} array set aVaRnAmE [list e3 v3] @@ -550,29 +550,29 @@ test set-old-8.38.7 {array command, set with non-existent namespace} { list [catch {array set bogusnamespace::var(0) {a b}} msg] $msg } {1 {can't set "bogusnamespace::var(0)": parent namespace doesn't exist}} test set-old-8.39 {array command, size option} { - catch {unset a} + unset -nocomplain a array size a } {0} test set-old-8.40 {array command, size option} { list [catch {array size a 4} msg] $msg } {1 {wrong # args: should be "array size arrayName"}} test set-old-8.41 {array command, size option} { - catch {unset a} + unset -nocomplain a array size a } {0} test set-old-8.42 {array command, size option} { - catch {unset a} + unset -nocomplain a set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx list [catch {array size a} msg] $msg } {0 3} test set-old-8.43 {array command, size option} { - catch {unset a} + unset -nocomplain a set a(22) 3; set a(xx) 44; set a(y) xxx unset a(22) a(y) a(xx) list [catch {array size a} msg] $msg } {0 0} test set-old-8.44 {array command, size option} { - catch {unset a} + unset -nocomplain a set a(22) 3; trace var a(33) rwu ignore list [catch {array size a} msg] $msg @@ -590,7 +590,7 @@ test set-old-8.46 {array command, startsearch option} { list [catch {array startsearch a b} msg] $msg } {1 {wrong # args: should be "array startsearch arrayName"}} test set-old-8.47 {array command, startsearch option} { - catch {unset a} + unset -nocomplain a list [catch {array startsearch a} msg] $msg } {1 {"a" isn't an array}} test set-old-8.48 {array command, startsearch option, array doesn't exist yet but has compiler-allocated procedure slot} { @@ -604,7 +604,7 @@ test set-old-8.48 {array command, startsearch option, array doesn't exist yet bu list [catch {p 1} msg] $msg } {1 {"a" isn't an array}} test set-old-8.49 {array command, statistics option} { - catch {unset a} + unset -nocomplain a set a(abc) 1 set a(def) 2 set a(ghi) 3 @@ -629,64 +629,64 @@ number of buckets with 9 entries: 0 number of buckets with 10 or more entries: 0 average search distance for entry: 1.7" test set-old-8.50 {array command, array names -exact on glob pattern} { - catch {unset a} + unset -nocomplain a set a(1*2) 1 list [catch {array names a -exact 1*2} msg] $msg } {0 1*2} test set-old-8.51 {array command, array names -glob on glob pattern} { - catch {unset a} + unset -nocomplain a set a(1*2) 1 set a(12) 1 set a(11) 1 list [catch {lsort [array names a -glob 1*2]} msg] $msg } {0 {1*2 12}} test set-old-8.52 {array command, array names -regexp on regexp pattern} { - catch {unset a} + unset -nocomplain a set a(1*2) 1 set a(12) 1 set a(11) 1 list [catch {lsort [array names a -regexp ^1]} msg] $msg } {0 {1*2 11 12}} test set-old-8.53 {array command, array names -regexp} { - catch {unset a} + unset -nocomplain a set a(-glob) 1 set a(-regexp) 1 set a(-exact) 1 list [catch {array names a -regexp} msg] $msg } {0 -regexp} test set-old-8.54 {array command, array names -exact} { - catch {unset a} + unset -nocomplain a set a(-glob) 1 set a(-regexp) 1 set a(-exact) 1 list [catch {array names a -exact} msg] $msg } {0 -exact} test set-old-8.55 {array command, array names -glob} { - catch {unset a} + unset -nocomplain a set a(-glob) 1 set a(-regexp) 1 set a(-exact) 1 list [catch {array names a -glob} msg] $msg } {0 -glob} test set-old-8.56 {array command, array statistics on a non-array} { - catch {unset a} + unset -nocomplain a list [catch {array statistics a} msg] $msg } [list 1 "\"a\" isn't an array"] test set-old-8.57 {array command, array get with trivial pattern} { - catch {unset a} + unset -nocomplain a set a(x) 1 set a(y) 2 array get a x } {x 1} test set-old-9.1 {ids for array enumeration} { - catch {unset a} + unset -nocomplain a set a(a) 1 list [array star a] [array star a] [array done a s-1-a; array star a] \ [array done a s-2-a; array d a s-3-a; array start a] } {s-1-a s-2-a s-3-a s-1-a} test set-old-9.2 {array enumeration} { - catch {unset a} + unset -nocomplain a set a(a) 1 set a(b) 1 set a(c) 1 @@ -695,7 +695,7 @@ test set-old-9.2 {array enumeration} { [array next a $x] [array next a $x]] } {{} {} a b c} test set-old-9.3 {array enumeration} { - catch {unset a} + unset -nocomplain a set a(a) 1 set a(b) 1 set a(c) 1 @@ -709,7 +709,7 @@ test set-old-9.3 {array enumeration} { [array next a $x]] } {{} {} {} a a a b b b c c c} test set-old-9.4 {array enumeration: stopping searches} { - catch {unset a} + unset -nocomplain a set a(a) 1 set a(b) 1 set a(c) 1 @@ -721,14 +721,14 @@ test set-old-9.4 {array enumeration: stopping searches} { [array done a $x; array next a $y] [array next a $y]] } {a a b b c c} test set-old-9.5 {array enumeration: stopping searches} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] array done a $x list [catch {array next a $x} msg] $msg } {1 {couldn't find search "s-1-a"}} test set-old-9.6 {array enumeration: searches automatically stopped} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] set y [array startsearch a] @@ -737,7 +737,7 @@ test set-old-9.6 {array enumeration: searches automatically stopped} { [catch {array next a $y} msg2] $msg2 } {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} test set-old-9.7 {array enumeration: searches automatically stopped} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] set y [array startsearch a] @@ -746,26 +746,26 @@ test set-old-9.7 {array enumeration: searches automatically stopped} { [catch {array next a $y} msg2] $msg2 } {0 a 0 a} test set-old-9.8 {array enumeration: searches automatically stopped} { - catch {unset a} + unset -nocomplain a set a(a) 1 set a(c) 2 set x [array startsearch a] set y [array startsearch a] - catch {unset a(c)} + unset -nocomplain a(c) list [catch {array next a $x} msg] $msg \ [catch {array next a $y} msg2] $msg2 } {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} test set-old-9.9 {array enumeration: searches automatically stopped} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] set y [array startsearch a] - catch {unset a(c)} + unset -nocomplain a(c) list [catch {array next a $x} msg] $msg \ [catch {array next a $y} msg2] $msg2 } {0 a 0 a} test set-old-9.10 {array enumeration: searches automatically stopped} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] set y [array startsearch a] @@ -774,7 +774,7 @@ test set-old-9.10 {array enumeration: searches automatically stopped} { [catch {array next a $y} msg2] $msg2 } {1 {couldn't find search "s-1-a"} 1 {couldn't find search "s-2-a"}} test set-old-9.11 {array enumeration: searches automatically stopped} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] set y [array startsearch a] @@ -783,7 +783,7 @@ test set-old-9.11 {array enumeration: searches automatically stopped} { [catch {array next a $y} msg2] $msg2 } {0 a 0 a} test set-old-9.12 {array enumeration with traced undefined elements} { - catch {unset a} + unset -nocomplain a set a(a) 1 trace var a(b) r {} set x [array startsearch a] @@ -797,53 +797,53 @@ test set-old-10.2 {array enumeration errors} { list [catch {array start a b} msg] $msg } {1 {wrong # args: should be "array startsearch arrayName"}} test set-old-10.3 {array enumeration errors} { - catch {unset a} + unset -nocomplain a list [catch {array start a} msg] $msg } {1 {"a" isn't an array}} test set-old-10.4 {array enumeration errors} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] list [catch {array next a} msg] $msg } {1 {wrong # args: should be "array nextelement arrayName searchId"}} test set-old-10.5 {array enumeration errors} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] list [catch {array next a b c} msg] $msg } {1 {wrong # args: should be "array nextelement arrayName searchId"}} test set-old-10.6 {array enumeration errors} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] list [catch {array next a a-1-a} msg] $msg } {1 {illegal search identifier "a-1-a"}} test set-old-10.7 {array enumeration errors} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] list [catch {array next a sx1-a} msg] $msg } {1 {illegal search identifier "sx1-a"}} test set-old-10.8 {array enumeration errors} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] list [catch {array next a s--a} msg] $msg } {1 {illegal search identifier "s--a"}} test set-old-10.9 {array enumeration errors} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] list [catch {array next a s-1-b} msg] $msg } {1 {search identifier "s-1-b" isn't for variable "a"}} test set-old-10.10 {array enumeration errors} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] list [catch {array next a s-1ba} msg] $msg } {1 {illegal search identifier "s-1ba"}} test set-old-10.11 {array enumeration errors} { - catch {unset a} + unset -nocomplain a set a(a) 1 set x [array startsearch a] list [catch {array next a s-2-a} msg] $msg @@ -864,7 +864,7 @@ test set-old-10.16 {array enumeration errors} { list [catch {array any a b c} msg] $msg } {1 {wrong # args: should be "array anymore arrayName searchId"}} test set-old-10.17 {array enumeration errors} { - catch {unset a} + unset -nocomplain a set a(0) 44 list [catch {array any a bogus} msg] $msg } {1 {illegal search identifier "bogus"}} @@ -872,7 +872,7 @@ test set-old-10.17 {array enumeration errors} { # Array enumeration with "anymore" option test set-old-11.1 {array anymore option} { - catch {unset a} + unset -nocomplain a set a(a) 1 set a(b) 2 set a(c) 3 @@ -883,7 +883,7 @@ test set-old-11.1 {array anymore option} { [array anymore a s-1-a] [array next a s-1-a]] } {{} 0 1 1 1 a b c} test set-old-11.2 {array anymore option} { - catch {unset a} + unset -nocomplain a set a(a) 1 set a(b) 2 set a(c) 3 @@ -913,11 +913,8 @@ test set-old-12.2 {cleanup on procedure return} { # Must delete variables when done, since these arrays get used as # scalars by other tests. -catch {unset a} -catch {unset b} -catch {unset c} -catch {unset aVaRnAmE} -catch {rename foo {}} +unset -nocomplain a b c aVaRnAmE +catch {rename foo ""} # cleanup ::tcltest::cleanupTests diff --git a/tests/set.test b/tests/set.test index 1d88553..ee38f38c 100644 --- a/tests/set.test +++ b/tests/set.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -20,8 +20,7 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testset2 [llength [info commands testset2]] -catch {unset x} -catch {unset i} +unset -nocomplain x i test set-1.1 {TclCompileSetCmd: missing variable name} { list [catch {set} msg] $msg @@ -40,12 +39,12 @@ test set-1.4 {TclCompileSetCmd: simple variable name in quotes} { list [set "i"] $i } {17 17} test set-1.5 {TclCompileSetCmd: simple variable name in braces} { - catch {unset {a simple var}} + unset -nocomplain {a simple var} set {a simple var} 27 list [set {a simple var}] ${a simple var} } {27 27} test set-1.6 {TclCompileSetCmd: simple array variable name} { - catch {unset a} + unset -nocomplain a set a(foo) 37 list [set a(foo)] $a(foo) } {37 37} @@ -150,19 +149,19 @@ test set-1.14 {TclCompileSetCmd: simple local name, >255 locals} { 260locals } {1234} test set-1.15 {TclCompileSetCmd: variable is array} { - catch {unset a} + unset -nocomplain a set x 27 set x [set a(foo) 11] - catch {unset a} + unset -nocomplain a set x } 11 test set-1.16 {TclCompileSetCmd: variable is array, elem substitutions} { - catch {unset a} + unset -nocomplain a set i 5 set x 789 set a(foo5) 27 set x [set a(foo$i)] - catch {unset a} + unset -nocomplain a set x } 27 @@ -205,7 +204,7 @@ test set-1.24 {TclCompileSetCmd: too many arguments} { test set-1.25 {TclCompileSetCmd: var is array, braced (no subs)} { # This was a known error in 8.1a* - 8.2.1 - catch {unset array} + unset -nocomplain array set {array($foo)} 5 } 5 test set-1.26 {TclCompileSetCmd: various array constructs} { @@ -242,12 +241,12 @@ test set-2.1 {set command: runtime error, bad variable name} { while executing "set {"foo}"}} test set-2.2 {set command: runtime error, not array variable} { - catch {unset b} + unset -nocomplain b set b 44 list [catch {set b(123)} msg] $msg } {1 {can't read "b(123)": variable isn't array}} test set-2.3 {set command: runtime error, errors in reading variables} { - catch {unset a} + unset -nocomplain a set a(6) 44 list [catch {set a(18)} msg] $msg } {1 {can't read "a(18)": no such element in array}} @@ -269,10 +268,7 @@ test set-2.6 {set command: runtime error, basic array operations} { # Test the uncompiled version of set -catch {unset a} -catch {unset b} -catch {unset i} -catch {unset x} +unset -nocomplain a b i x test set-3.1 {uncompiled set command: missing variable name} { set z set @@ -296,13 +292,13 @@ test set-3.4 {uncompiled set command: simple variable name in quotes} { } {17 17} test set-3.5 {uncompiled set command: simple variable name in braces} { set z set - catch {unset {a simple var}} + unset -nocomplain {a simple var} $z {a simple var} 27 list [$z {a simple var}] ${a simple var} } {27 27} test set-3.6 {uncompiled set command: simple array variable name} { set z set - catch {unset a} + unset -nocomplain a $z a(foo) 37 list [$z a(foo)] $a(foo) } {37 37} @@ -417,20 +413,20 @@ test set-3.14 {uncompiled set command: simple local name, >255 locals} { } {1234} test set-3.15 {uncompiled set command: variable is array} { set z set - catch {unset a} + unset -nocomplain a $z x 27 $z x [$z a(foo) 11] - catch {unset a} + unset -nocomplain a $z x } 11 test set-3.16 {uncompiled set command: variable is array, elem substitutions} { set z set - catch {unset a} + unset -nocomplain a $z i 5 $z x 789 $z a(foo5) 27 $z x [$z a(foo$i)] - catch {unset a} + unset -nocomplain a $z x } 27 @@ -488,13 +484,13 @@ test set-4.1 {uncompiled set command: runtime error, bad variable name} { "$z {"foo}"}} test set-4.2 {uncompiled set command: runtime error, not array variable} { set z set - catch {unset b} + unset -nocomplain b $z b 44 list [catch {$z b(123)} msg] $msg } {1 {can't read "b(123)": variable isn't array}} test set-4.3 {uncompiled set command: runtime error, errors in reading variables} { set z set - catch {unset a} + unset -nocomplain a $z a(6) 44 list [catch {$z a(18)} msg] $msg } {1 {can't read "a(18)": no such element in array}} @@ -525,10 +521,6 @@ test set-5.1 {error on malformed array name} testset2 { } {{can't read "z(a)(b)": variable isn't array} {can't read "z(b)(a)": variable isn't array}} # cleanup -catch {unset a} -catch {unset b} -catch {unset i} -catch {unset x} -catch {unset z} +unset -nocomplain a b i x z ::tcltest::cleanupTests return diff --git a/tests/socket.test b/tests/socket.test index 5542c09..a3b9356 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -69,7 +69,7 @@ testConstraint exec [llength [info commands exec]] # Produce a random port number in the Dynamic/Private range # from 49152 through 65535. -proc randport {} { expr {int(rand()*16383+49152)} } +proc randport {} { expr { int ( ( ( rand () ) * 16383) + 49152)} } # Test the latency of tcp connections over the loopback interface. Some OSes # (e.g. NetBSD) seem to use the Nagle algorithm and delayed ACKs, so it takes @@ -77,16 +77,20 @@ proc randport {} { expr {int(rand()*16383+49152)} } # here, so that OSes that don't have this problem can run the tests at full # speed. set server [socket -server {apply {{s a p} {set ::s1 $s}}} 0] -set s2 [socket localhost [lindex [fconfigure $server -sockname] 2]] -vwait s1; close $server -fconfigure $s1 -buffering line -fconfigure $s2 -buffering line +set s2 [socket localhost [lindex [chan configure $server -sockname] 2]] +vwait s1 +close $server +chan configure $s1 -buffering line +chan configure $s2 -buffering line set t1 [clock milliseconds] -puts $s2 test1; gets $s1 -puts $s2 test2; gets $s1 -close $s1; close $s2 +puts $s2 test1 +gets $s1 +puts $s2 test2 +gets $s1 +close $s1 +close $s2 set t2 [clock milliseconds] -set latency [expr {($t2-$t1)*2}]; # doubled as a safety margin +set latency [expr {($t2 - $t1) * 2}]; # doubled as a safety margin unset t1 t2 s1 s2 server # If remoteServerIP or remoteServerPort are not set, check in the environment @@ -108,11 +112,11 @@ if {![info exists remoteServerPort]} { } } -if 0 { +if {0} { # activate this to time the tests proc test {args} { set name [lindex $args 0] - puts "[lindex [time {uplevel [linsert $args 0 tcltest::test]}] 0] @@@ $name" + puts "[lindex [time {uplevel 1 [linsert $args 0 tcltest::test]}] 0] @@@ $name" } } @@ -127,12 +131,11 @@ foreach {af localhost} { testConstraint supported_any [expr {[testConstraint supported_inet] || [testConstraint supported_inet6]}] set sock [socket -server foo -myaddr localhost 0] -set sockname [fconfigure $sock -sockname] +set sockname [chan configure $sock -sockname] close $sock testConstraint localhost_v4 [expr {"127.0.0.1" in $sockname}] testConstraint localhost_v6 [expr {"::1" in $sockname}] - foreach {af localhost} { any 127.0.0.1 inet 127.0.0.1 @@ -161,11 +164,11 @@ if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} { set remoteProcChan "" set commandSocket "" if {$doTestsWithRemoteServer} { - catch {close $commandSocket} + catch {chan close $commandSocket} if {![catch { set commandSocket [socket $remoteServerIP $remoteServerPort] - }]} then { - fconfigure $commandSocket -translation crlf -buffering line + }]} { + chan configure $commandSocket -translation crlf -buffering line } elseif {![testConstraint exec]} { set noRemoteTestReason "can't exec" set doTestsWithRemoteServer 0 @@ -179,12 +182,12 @@ if {$doTestsWithRemoteServer} { set remoteProcChan [open "|[list \ [interpreter] $remoteFile -serverIsSilent \ -port $remoteServerPort -address $remoteServerIP]" w+] - } msg]} then { + } msg]} { gets $remoteProcChan if {[catch { set commandSocket [socket $remoteServerIP $remoteServerPort] - } msg] == 0} then { - fconfigure $commandSocket -translation crlf -buffering line + } msg] == 0} { + chan configure $commandSocket -translation crlf -buffering line } else { set noRemoteTestReason $msg set doTestsWithRemoteServer 0 @@ -224,9 +227,10 @@ if {[testConstraint doTestsWithRemoteServer]} { error "remote server disappeared: $msg" } + set result "" while {1} { - set line [gets $commandSocket] - if {[eof $commandSocket]} { + set line [chan gets $commandSocket] + if {[chan eof $commandSocket]} { error "remote server disappaered" } if {$line eq "--Marker--Marker--Marker--"} { @@ -238,8 +242,8 @@ if {[testConstraint doTestsWithRemoteServer]} { } } -proc getPort sock { - lindex [fconfigure $sock -sockname] 2 +proc getPort {sock} { + lindex [chan configure $sock -sockname] 2 } @@ -302,7 +306,7 @@ test socket_$af-2.1 {tcp connection} -constraints [list socket supported_$af std close $file } puts ready - puts [lindex [fconfigure $f -sockname] 2] + puts [lindex [chan configure $f -sockname] 2] vwait x after cancel $timer close $f @@ -335,7 +339,7 @@ test socket_$af-2.2 {tcp connection with client port specified} -setup { set x done } puts ready - puts [lindex [fconfigure $f -sockname] 2] + puts [lindex [chan configure $f -sockname] 2] vwait x after cancel $timer close $f @@ -368,7 +372,7 @@ test socket_$af-2.3 {tcp connection with client interface specified} -setup { close $file set x done } - puts [lindex [fconfigure $f -sockname] 2] + puts [lindex [chan configure $f -sockname] 2] puts ready vwait x after cancel $timer @@ -403,7 +407,7 @@ test socket_$af-2.4 {tcp connection with server interface specified} -setup { set x done } puts ready - puts [lindex [fconfigure $f -sockname] 2] + puts [lindex [chan configure $f -sockname] 2] vwait x after cancel $timer close $f @@ -436,7 +440,7 @@ test socket_$af-2.5 {tcp connection with redundant server port} -setup { set x done } puts ready - puts [lindex [fconfigure $f -sockname] 2] + puts [lindex [chan configure $f -sockname] 2] vwait x after cancel $timer close $f @@ -473,8 +477,8 @@ test socket_$af-2.7 {echo server, one line} -constraints [list socket supported_ set timer [after 10000 "set x timeout"] set f [socket -server accept 0] proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -translation lf -buffering line + chan event $s readable [list echo $s] + chan configure $s -translation lf -buffering line } proc echo {s} { set l [gets $s] @@ -487,7 +491,7 @@ test socket_$af-2.7 {echo server, one line} -constraints [list socket supported_ } } puts ready - puts [lindex [fconfigure $f -sockname] 2] + puts [lindex [chan configure $f -sockname] 2] vwait x after cancel $timer close $f @@ -499,7 +503,7 @@ test socket_$af-2.7 {echo server, one line} -constraints [list socket supported_ gets $f listen } -body { set s [socket $localhost $listen] - fconfigure $s -buffering line -translation lf + chan configure $s -buffering line -translation lf puts $s "hello abcdefghijklmnop" set x [gets $s] close $s @@ -512,8 +516,8 @@ test socket_$af-2.8 {echo server, loop 50 times, single connection} -setup { set path(script) [makeFile { set f [socket -server accept 0] proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -buffering line + chan event $s readable [list echo $s] + chan configure $s -buffering line } proc echo {s} { global i @@ -529,7 +533,7 @@ test socket_$af-2.8 {echo server, loop 50 times, single connection} -setup { } set i 0 puts ready - puts [lindex [fconfigure $f -sockname] 2] + puts [lindex [chan configure $f -sockname] 2] set timer [after 20000 "set x done"] vwait x after cancel $timer @@ -541,7 +545,7 @@ test socket_$af-2.8 {echo server, loop 50 times, single connection} -setup { gets $f listen } -constraints [list socket supported_$af stdio] -body { set s [socket $localhost $listen] - fconfigure $s -buffering line + chan configure $s -buffering line catch { for {set x 0} {$x < 50} {incr x} { puts $s "hello abcdefghijklmnop" @@ -561,7 +565,7 @@ test socket_$af-2.9 {socket conflict} -constraints [list socket supported_$af st file delete $path(script) set f [open $path(script) w] puts $f [list set ::tcl::unsupported::socketAF $::tcl::unsupported::socketAF] - puts $f "socket -server accept [lindex [fconfigure $s -sockname] 2]" + puts $f "socket -server accept [lindex [chan configure $s -sockname] 2]" close $f set f [open "|[list [interpreter] $path(script)]" r] gets $f @@ -578,8 +582,8 @@ test socket_$af-2.10 {close on accept, accepted socket lives} -setup { proc accept {s a p} { global ss close $ss - fileevent $s readable "readit $s" - fconfigure $s -trans lf + chan event $s readable "readit $s" + chan configure $s -trans lf } proc readit {s} { global done @@ -587,7 +591,7 @@ test socket_$af-2.10 {close on accept, accepted socket lives} -setup { close $s set done 1 } - set cs [socket $localhost [lindex [fconfigure $ss -sockname] 2]] + set cs [socket $localhost [lindex [chan configure $ss -sockname] 2]] puts $cs hello close $cs vwait done @@ -603,24 +607,24 @@ test socket_$af-2.11 {detecting new data} -constraints [list socket supported_$a set s [socket -server accept 0] set sock "" } -body { - set s2 [socket $localhost [lindex [fconfigure $s -sockname] 2]] + set s2 [socket $localhost [lindex [chan configure $s -sockname] 2]] vwait sock puts $s2 one flush $s2 after idle {set x 1} vwait x - fconfigure $sock -blocking 0 + chan configure $sock -blocking 0 set result a:[gets $sock] lappend result b:[gets $sock] - fconfigure $sock -blocking 1 + chan configure $sock -blocking 1 puts $s2 two flush $s2 after $latency {set x 1}; # NetBSD fails here if we do [after idle] vwait x - fconfigure $sock -blocking 0 + chan configure $sock -blocking 0 lappend result c:[gets $sock] } -cleanup { - fconfigure $sock -blocking 1 + chan configure $sock -blocking 1 close $s2 close $s close $sock @@ -633,7 +637,7 @@ test socket_$af-3.1 {socket conflict} -constraints [list socket supported_$af st puts $f { set f [socket -server accept -myaddr $localhost 0] puts ready - puts [lindex [fconfigure $f -sockname] 2] + puts [lindex [chan configure $f -sockname] 2] gets stdin close $f } @@ -658,8 +662,8 @@ test socket_$af-3.2 {server with several clients} -setup { set counter 0 set s [socket -server accept -myaddr $localhost 0] proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -buffering line + chan event $s readable [list echo $s] + chan configure $s -buffering line } proc echo {s} { global x @@ -672,7 +676,7 @@ test socket_$af-3.2 {server with several clients} -setup { } } puts ready - puts [lindex [fconfigure $s -sockname] 2] + puts [lindex [chan configure $s -sockname] 2] vwait x after cancel $t1 vwait x @@ -689,11 +693,11 @@ test socket_$af-3.2 {server with several clients} -setup { } -constraints [list socket supported_$af stdio] -body { # $x == "ready" here set s1 [socket $localhost $listen] - fconfigure $s1 -buffering line + chan configure $s1 -buffering line set s2 [socket $localhost $listen] - fconfigure $s2 -buffering line + chan configure $s2 -buffering line set s3 [socket $localhost $listen] - fconfigure $s3 -buffering line + chan configure $s3 -buffering line for {set i 0} {$i < 100} {incr i} { puts $s1 hello,s1 gets $s1 @@ -717,7 +721,7 @@ test socket_$af-4.1 {server with several clients} -setup { puts $f { set port [gets stdin] set s [socket $localhost $port] - fconfigure $s -buffering line + chan configure $s -buffering line for {set i 0} {$i < 100} {incr i} { puts $s hello gets $s @@ -728,15 +732,15 @@ test socket_$af-4.1 {server with several clients} -setup { } close $f set p1 [open "|[list [interpreter] $path(script)]" r+] - fconfigure $p1 -buffering line + chan configure $p1 -buffering line set p2 [open "|[list [interpreter] $path(script)]" r+] - fconfigure $p2 -buffering line + chan configure $p2 -buffering line set p3 [open "|[list [interpreter] $path(script)]" r+] - fconfigure $p3 -buffering line + chan configure $p3 -buffering line } -constraints [list socket supported_$af stdio] -body { proc accept {s a p} { - fconfigure $s -buffering line - fileevent $s readable [list echo $s] + chan configure $s -buffering line + chan event $s readable [list echo $s] } proc echo {s} { global x @@ -752,7 +756,7 @@ test socket_$af-4.1 {server with several clients} -setup { set t2 [after 31000 "set x timed_out"] set t3 [after 32000 "set x timed_out"] set s [socket -server accept -myaddr $localhost 0] - set listen [lindex [fconfigure $s -sockname] 2] + set listen [lindex [chan configure $s -sockname] 2] puts $p1 $listen puts $p2 $listen puts $p3 $listen @@ -820,7 +824,7 @@ test socket_$af-6.1 {accept callback error} -constraints [list socket supported_ set f [open "|[list [interpreter] $path(script)]" r+] proc accept {s a p} {expr 10 / 0} set s [socket -server accept -myaddr $localhost 0] - puts $f [lindex [fconfigure $s -sockname] 2] + puts $f [lindex [chan configure $s -sockname] 2] close $f set timer [after 10000 "set x timed_out"] vwait x @@ -832,19 +836,19 @@ test socket_$af-6.1 {accept callback error} -constraints [list socket supported_ } -result {divide by zero} test socket_$af-6.2 { - readable fileevent on server socket + readable chan event on server socket } -setup { set sock [socket -server dummy 0] } -constraints [list socket supported_$af] -body { - fileevent $sock readable dummy + chan event $sock readable dummy } -cleanup { close $sock } -returnCodes 1 -result "channel is not readable" -test socket_$af-6.3 {writable fileevent on server socket} -setup { +test socket_$af-6.3 {writable chan event on server socket} -setup { set sock [socket -server dummy 0] } -constraints [list socket supported_$af] -body { - fileevent $sock writable dummy + chan event $sock writable dummy } -cleanup { close $sock } -returnCodes 1 -result "channel is not writable" @@ -859,7 +863,7 @@ test socket_$af-7.1 {testing socket specific options} -setup { set x done } puts ready - puts [lindex [fconfigure $ss -sockname] 2] + puts [lindex [chan configure $ss -sockname] 2] set timer [after 10000 "set x timed_out"] vwait x after cancel $timer @@ -871,7 +875,7 @@ test socket_$af-7.1 {testing socket specific options} -setup { set l "" } -constraints [list socket supported_$af stdio] -body { set s [socket $localhost $listen] - set p [fconfigure $s -peername] + set p [chan configure $s -peername] close $s lappend l [string compare [lindex $p 0] $localhost] lappend l [string compare [lindex $p 2] $listen] @@ -890,7 +894,7 @@ test socket_$af-7.2 {testing socket specific options} -setup { set x done } puts ready - puts [lindex [fconfigure $ss -sockname] 2] + puts [lindex [chan configure $ss -sockname] 2] set timer [after 10000 "set x timed_out"] vwait x after cancel $timer @@ -901,7 +905,7 @@ test socket_$af-7.2 {testing socket specific options} -setup { gets $f listen } -constraints [list socket supported_$af stdio] -body { set s [socket $localhost $listen] - set p [fconfigure $s -sockname] + set p [chan configure $s -sockname] close $s list [llength $p] \ [regexp {^(127\.0\.0\.1|0\.0\.0\.0|::1)$} [lindex $p 0]] \ @@ -911,7 +915,7 @@ test socket_$af-7.2 {testing socket specific options} -setup { } -result {3 1 0} test socket_$af-7.3 {testing socket specific options} -constraints [list socket supported_$af] -body { set s [socket -server accept -myaddr $localhost 0] - set l [fconfigure $s] + set l [chan configure $s] close $s update llength $l @@ -923,10 +927,10 @@ test socket_$af-7.4 {testing socket specific options} -constraints [list socket set s [socket -server accept -myaddr $localhost 0] proc accept {s a p} { global x - set x [fconfigure $s -sockname] + set x [chan configure $s -sockname] close $s } - set listen [lindex [fconfigure $s -sockname] 2] + set listen [lindex [chan configure $s -sockname] 2] set s1 [socket $localhost $listen] vwait x lappend l [expr {[lindex $x 2] == $listen}] [llength $x] @@ -942,10 +946,10 @@ test socket_$af-7.5 {testing socket specific options} -setup { set s [socket -server accept 0] proc accept {s a p} { global x - set x [fconfigure $s -sockname] + set x [chan configure $s -sockname] close $s } - set listen [lindex [fconfigure $s -sockname] 2] + set listen [lindex [chan configure $s -sockname] 2] set s1 [socket $localhost $listen] vwait x lappend l [lindex $x 0] [expr {[lindex $x 2] == $listen}] [llength $x] @@ -977,7 +981,7 @@ test socket_$af-8.1 {testing -async flag on sockets} -constraints [list socket s close $s set x done } - set s1 [socket -async $localhost [lindex [fconfigure $s -sockname] 2]] + set s1 [socket -async $localhost [lindex [chan configure $s -sockname] 2]] vwait x gets $s1 } -cleanup { @@ -1006,11 +1010,11 @@ test socket_$af-9.1 {testing spurious events} -constraints [list socket supporte } } proc accept {s a p} { - fconfigure $s -buffering none -blocking off - fileevent $s readable [list readlittle $s] + chan configure $s -buffering none -blocking off + chan event $s readable [list readlittle $s] } set s [socket -server accept -myaddr $localhost 0] - set c [socket $localhost [lindex [fconfigure $s -sockname] 2]] + set c [socket $localhost [lindex [chan configure $s -sockname] 2]] puts -nonewline $c 01234567890123456789012345678901234567890123456789 close $c vwait done @@ -1019,7 +1023,7 @@ test socket_$af-9.1 {testing spurious events} -constraints [list socket supporte } -cleanup { after cancel $timer } -result {0 50} -test socket_$af-9.2 {testing async write, fileevents, flush on close} -constraints [list socket supported_$af] -setup { +test socket_$af-9.2 {testing async write, chan events, flush on close} -constraints [list socket supported_$af] -setup { set firstblock "" for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"} set secondblock "" @@ -1029,13 +1033,13 @@ test socket_$af-9.2 {testing async write, fileevents, flush on close} -constrain set timer [after 10000 "set done timed_out"] set l [socket -server accept -myaddr $localhost 0] proc accept {s a p} { - fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ + chan configure $s -blocking 0 -translation lf -buffersize 16384 \ -buffering line - fileevent $s readable "readable $s" + chan event $s readable "readable $s" } proc readable {s} { set l [gets $s] - fileevent $s readable {} + chan event $s readable {} after idle respond $s } proc respond {s} { @@ -1049,8 +1053,8 @@ test socket_$af-9.2 {testing async write, fileevents, flush on close} -constrain close $s } } -body { - set s [socket $localhost [lindex [fconfigure $l -sockname] 2]] - fconfigure $s -blocking 0 -trans lf -buffering line + set s [socket $localhost [lindex [chan configure $l -sockname] 2]] + chan configure $s -blocking 0 -trans lf -buffering line set count 0 puts $s hello proc readit {s} { @@ -1062,7 +1066,7 @@ test socket_$af-9.2 {testing async write, fileevents, flush on close} -constrain set done 1 } } - fileevent $s readable "readit $s" + chan event $s readable "readit $s" vwait done return $count } -cleanup { @@ -1073,12 +1077,12 @@ test socket_$af-9.3 {testing EOF stickyness} -constraints [list socket supported set count 0 set done false proc write_then_close {s} { - puts $s bye - close $s + chan puts $s bye + chan close $s } proc accept {s a p} { - fconfigure $s -buffering line -translation lf - fileevent $s writable "write_then_close $s" + chan configure $s -buffering line -translation lf + chan event $s writable "write_then_close $s" } set s [socket -server accept -myaddr $localhost 0] } -body { @@ -1100,9 +1104,9 @@ test socket_$af-9.3 {testing EOF stickyness} -constraints [list socket supported set count {timer went off, eof is not sticky} close $s } - set c [socket $localhost [lindex [fconfigure $s -sockname] 2]] - fconfigure $c -blocking off -buffering line -translation lf - fileevent $c readable "count_to_eof $c" + set c [socket $localhost [lindex [chan configure $s -sockname] 2]] + chan configure $c -blocking off -buffering line -translation lf + chan event $c readable "count_to_eof $c" set timer [after 1000 timerproc $c] vwait done return $count @@ -1124,7 +1128,7 @@ test socket_$af-10.1 {testing socket accept callback error handling} \ } -body { set s [socket -server accept -myaddr $localhost 0] proc accept {s a p} {close $s; error} - set c [socket $localhost [lindex [fconfigure $s -sockname] 2]] + set c [socket $localhost [lindex [chan configure $s -sockname] 2]] vwait goterror close $s close $c @@ -1162,7 +1166,7 @@ test socket_$af-11.2 {client specifies its port} -setup { } -constraints [list socket supported_$af doTestsWithRemoteServer] -body { set s [socket -myport $lport $remoteServerIP $rport] set r [gets $s] - expr {$r==$lport ? "ok" : "broken: $r != $port"} + expr {($r == $lport) ? "ok" : "broken: $r != $port"} } -cleanup { close $s sendCommand {close $server} @@ -1181,8 +1185,8 @@ test socket_$af-11.4 {remote echo, one line} -setup { set port [sendCommand { set server [socket -server accept 0] proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -buffering line -translation crlf + chan event $s readable [list echo $s] + chan configure $s -buffering line -translation crlf } proc echo {s} { set l [gets $s] @@ -1196,7 +1200,7 @@ test socket_$af-11.4 {remote echo, one line} -setup { }] } -constraints [list socket supported_$af doTestsWithRemoteServer] -body { set f [socket $remoteServerIP $port] - fconfigure $f -translation crlf -buffering line + chan configure $f -translation crlf -buffering line puts $f hello gets $f } -cleanup { @@ -1207,8 +1211,8 @@ test socket_$af-11.5 {remote echo, 50 lines} -setup { set port [sendCommand { set server [socket -server accept 0] proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -buffering line -translation crlf + chan event $s readable [list echo $s] + chan configure $s -buffering line -translation crlf } proc echo {s} { set l [gets $s] @@ -1222,10 +1226,10 @@ test socket_$af-11.5 {remote echo, 50 lines} -setup { }] } -constraints [list socket supported_$af doTestsWithRemoteServer] -body { set f [socket $remoteServerIP $port] - fconfigure $f -translation crlf -buffering line + chan configure $f -translation crlf -buffering line for {set cnt 0} {$cnt < 50} {incr cnt} { puts $f "hello, $cnt" - if {[gets $f] != "hello, $cnt"} { + if {[gets $f] ne "hello, $cnt"} { break } } @@ -1246,8 +1250,8 @@ test socket_$af-11.7 {server with several clients} -setup { set port [sendCommand { set server [socket -server accept 0] proc accept {s a p} { - fconfigure $s -buffering line - fileevent $s readable [list echo $s] + chan configure $s -buffering line + chan event $s readable [list echo $s] } proc echo {s} { set l [gets $s] @@ -1261,11 +1265,11 @@ test socket_$af-11.7 {server with several clients} -setup { }] } -constraints [list socket supported_$af doTestsWithRemoteServer] -body { set s1 [socket $remoteServerIP $port] - fconfigure $s1 -buffering line + chan configure $s1 -buffering line set s2 [socket $remoteServerIP $port] - fconfigure $s2 -buffering line + chan configure $s2 -buffering line set s3 [socket $remoteServerIP $port] - fconfigure $s3 -buffering line + chan configure $s3 -buffering line for {set i 0} {$i < 100} {incr i} { puts $s1 hello,s1 gets $s1 @@ -1321,11 +1325,11 @@ test socket_$af-11.9 {accept callback error} -constraints [list socket supported sendCommand "set port [getPort $s]" if {[catch { sendCommand { - set peername [fconfigure $callerSocket -peername] + set peername [chan configure $callerSocket -peername] set s [socket [lindex $peername 0] $port] close $s } - } msg]} then { + } msg]} { close $s error $msg } @@ -1344,8 +1348,8 @@ test socket_$af-11.10 {testing socket specific options} -setup { }] } -constraints [list socket supported_$af doTestsWithRemoteServer] -body { set s [socket $remoteServerIP $port] - set p [fconfigure $s -peername] - set n [fconfigure $s -sockname] + set p [chan configure $s -peername] + set n [chan configure $s -sockname] list [expr {[lindex $p 2] == $port}] [llength $p] [llength $n] } -cleanup { close $s @@ -1355,7 +1359,7 @@ test socket_$af-11.11 {testing spurious events} -setup { set port [sendCommand { set server [socket -server accept 0] proc accept {s a p} { - fconfigure $s -translation "auto lf" + chan configure $s -translation "auto lf" after idle writesome $s } proc writesome {s} { @@ -1386,7 +1390,7 @@ test socket_$af-11.11 {testing spurious events} -setup { } } set c [socket $remoteServerIP $port] - fileevent $c readable "readlittle $c" + chan event $c readable "readlittle $c" vwait done list $spurious $len $done } -cleanup { @@ -1422,7 +1426,7 @@ test socket_$af-11.12 {testing EOF stickyness} -constraints [list socket support } } set c [socket $remoteServerIP $port] - fileevent $c readable [list count_up $c] + chan event $c readable [list count_up $c] vwait done return $done } -cleanup { @@ -1441,13 +1445,13 @@ test socket_$af-11.13 {testing async write, async flush, async close} -setup { } set l [socket -server accept 0] proc accept {s a p} { - fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ + chan configure $s -blocking 0 -translation lf -buffersize 16384 \ -buffering line - fileevent $s readable "readable $s" + chan event $s readable "readable $s" } proc readable {s} { set l [gets $s] - fileevent $s readable {} + chan event $s readable {} after idle respond $s } proc respond {s} { @@ -1474,10 +1478,10 @@ test socket_$af-11.13 {testing async write, async flush, async close} -setup { } } set s [socket $remoteServerIP $port] - fconfigure $s -blocking 0 -trans lf -buffering line + chan configure $s -blocking 0 -trans lf -buffering line set count 0 puts $s hello - fileevent $s readable "readit $s" + chan event $s readable "readit $s" vwait done return $count } -cleanup { @@ -1495,7 +1499,7 @@ test socket_$af-12.1 {testing inheritance of server sockets} -setup { # will be held open for 10 seconds set f [open $path(script1) w] puts $f { - fileevent stdin readable exit + chan event stdin readable exit after 10000 exit vwait forever } @@ -1512,7 +1516,7 @@ test socket_$af-12.1 {testing inheritance of server sockets} -setup { close $file } exec $tcltest $delay & - puts [lindex [fconfigure $f -sockname] 2] + puts [lindex [chan configure $f -sockname] 2] close $f exit } @@ -1537,7 +1541,7 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup { # will be held open for 20 seconds set f [open $path(script1) w] puts $f { - fileevent stdin readable exit + chan event stdin readable exit after 20000 exit vwait forever } @@ -1569,8 +1573,8 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup { # When the client connects, establish the read handler global server close $server - fileevent $file readable [list getdata $file] - fconfigure $file -buffering line -blocking 0 + chan event $file readable [list getdata $file] + chan configure $file -buffering line -blocking 0 } proc getdata { file } { # Read handler on the accepted socket. @@ -1580,7 +1584,7 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup { set x {read failed, error was $data} catch { close $file } } elseif {$data ne ""} { - } elseif {[fblocked $file]} { + } elseif {[chan blocked $file]} { } elseif {[eof $file]} { if {$failed} { set x {client socket was inherited} @@ -1596,7 +1600,7 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup { # Launch the script2 process ### exec [interpreter] script2 & set p [open "|[list [interpreter] $path(script2)]" w] - puts $p [lindex [fconfigure $server -sockname] 2] ; flush $p + puts $p [lindex [chan configure $server -sockname] 2] ; flush $p vwait x return $x } -cleanup { @@ -1608,7 +1612,7 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup { file delete $path(script2) set f [open $path(script1) w] puts $f { - fileevent stdin readable exit + chan event stdin readable exit after 10000 exit vwait forever } @@ -1625,7 +1629,7 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup { exec $tcltest $delay & after idle exit } - puts stdout [lindex [fconfigure $server -sockname] 2] + puts stdout [lindex [chan configure $server -sockname] 2] vwait forever } close $f @@ -1636,8 +1640,8 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup { set p [open "|[list [interpreter] $path(script2)]" r] gets $p listen set f [socket $localhost $listen] - fconfigure $f -buffering full -blocking 0 - fileevent $f readable [list getdata $f] + chan configure $f -buffering full -blocking 0 + chan event $f readable [list getdata $f] # If the socket is still open after 5 seconds, the script1 process must # have inherited the accepted socket. set failed 0 @@ -1650,9 +1654,9 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup { if {$status != 0} { set x {read failed, error was $data} catch { close $file } - } elseif {[string compare {} $data]} { - } elseif {[fblocked $file]} { - } elseif {[eof $file]} { + } elseif {[string compare "" $data]} { + } elseif {[chan blocked $file]} { + } elseif {[chan eof $file]} { if {$failed} { set x {accepted socket was inherited} } else { @@ -1676,10 +1680,10 @@ test socket_$af-13.1 {Testing use of shared socket between two threads} -body { # create a thread set serverthread [thread::create -preserved [string map [list @localhost@ $localhost] { set f [socket -server accept -myaddr @localhost@ 0] - set listen [lindex [fconfigure $f -sockname] 2] + set listen [lindex [chan configure $f -sockname] 2] proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -buffering line + chan event $s readable [list echo $s] + chan configure $s -buffering line } proc echo {s} { global i @@ -1700,7 +1704,7 @@ test socket_$af-13.1 {Testing use of shared socket between two threads} -body { }]] set port [thread::send $serverthread {set listen}] set s [socket $localhost $port] - fconfigure $s -buffering line + chan configure $s -buffering line catch { puts $s "hello" gets $s result @@ -1733,10 +1737,10 @@ test socket-14.0 {[socket -async] when server only listens on IPv4} \ set x ok } set server [socket -server accept -myaddr 127.0.0.1 0] - set port [lindex [fconfigure $server -sockname] 2] + set port [lindex [chan configure $server -sockname] 2] } -body { set client [socket -async localhost $port] - set after [after 1000 {set x [fconfigure $client -error]}] + set after [after 1000 {set x [chan configure $client -error]}] vwait x set x } -cleanup { @@ -1745,7 +1749,7 @@ test socket-14.0 {[socket -async] when server only listens on IPv4} \ close $client unset x } -result ok -test socket-14.1 {[socket -async] fileevent while still connecting} \ +test socket-14.1 {[socket -async] chan event while still connecting} \ -constraints [list socket supported_any] \ -setup { proc accept {s a p} { @@ -1755,13 +1759,13 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \ lappend x ok } set server [socket -server accept -myaddr localhost 0] - set port [lindex [fconfigure $server -sockname] 2] + set port [lindex [chan configure $server -sockname] 2] set x "" } -body { set client [socket -async localhost $port] - fileevent $client writable { - lappend x [fconfigure $client -error] - fileevent $client writable {} + chan event $client writable { + lappend x [chan configure $client -error] + chan event $client writable {} } set after [after 1000 {lappend x timeout}] while {[llength $x] < 2 && "timeout" ni $x} { @@ -1774,18 +1778,18 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \ close $client unset x } -result {{} ok} -test socket-14.2 {[socket -async] fileevent connection refused} \ +test socket-14.2 {[socket -async] chan event connection refused} \ -constraints [list socket supported_any] \ -body { if {[catch {socket -async localhost [randport]} client]} { regexp {[^:]*: (.*)} $client -> x } else { - fileevent $client writable {set x [fconfigure $client -error]} + chan event $client writable {set x [chan configure $client -error]} set after [after 1000 {set x timeout}] vwait x after cancel $after if {$x eq "timeout"} { - append x ": [fconfigure $client -error]" + append x ": [chan configure $client -error]" } close $client } @@ -1803,10 +1807,10 @@ test socket-14.3 {[socket -async] when server only listens on IPv6} \ set x ok } set server [socket -server accept -myaddr ::1 0] - set port [lindex [fconfigure $server -sockname] 2] + set port [lindex [chan configure $server -sockname] 2] } -body { set client [socket -async localhost $port] - set after [after 1000 {set x [fconfigure $client -error]}] + set after [after 1000 {set x [chan configure $client -error]}] vwait x set x } -cleanup { @@ -1815,7 +1819,7 @@ test socket-14.3 {[socket -async] when server only listens on IPv6} \ close $client unset x } -result ok -test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ +test socket-14.4 {[socket -async] and both, readdable and writable chan events} \ -constraints [list socket supported_any] \ -setup { proc accept {s a p} { @@ -1823,17 +1827,17 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ close $s } set server [socket -server accept -myaddr localhost 0] - set port [lindex [fconfigure $server -sockname] 2] + set port [lindex [chan configure $server -sockname] 2] set x "" } -body { set client [socket -async localhost $port] - fileevent $client writable { - lappend x [fconfigure $client -error] - fileevent $client writable {} + chan event $client writable { + lappend x [chan configure $client -error] + chan event $client writable "" } - fileevent $client readable {lappend x [gets $client]} + chan event $client readable {lappend x [gets $client]} set after [after 1000 {lappend x timeout}] - while {[llength $x] < 2 && "timeout" ni $x} { + while {([llength $x] < 2) && ("timeout" ni $x)} { vwait x } lsort $x diff --git a/tests/source.test b/tests/source.test index d71212d..eaf8a22 100644 --- a/tests/source.test +++ b/tests/source.test @@ -45,7 +45,7 @@ test source-1.2 {source command} -setup { test source-1.3 {source command} -setup { set sourcefile [makeFile {} source.file] set fd [open $sourcefile w] - fconfigure $fd -translation lf + chan configure $fd -translation lf puts $fd "list a b c \\" puts $fd "d e f" close $fd @@ -111,7 +111,7 @@ test source-2.7 {utf-8 with BOM} -setup { set sourcefile [makeFile {} source.file] } -body { set out [open $sourcefile w] - fconfigure $out -encoding utf-8 + chan configure $out -encoding utf-8 puts $out "\ufeffset y new-y" close $out set y old-y @@ -212,7 +212,7 @@ test source-7.1 {source -encoding test} -setup { set sourcefile [makeFile {} source.file] file delete $sourcefile set f [open $sourcefile w] - fconfigure $f -encoding utf-8 + chan configure $f -encoding utf-8 puts $f "set symbol(square-root) \u221A; set x correct" close $f } -body { @@ -231,7 +231,7 @@ test source-7.2 {source -encoding test} -setup { set sourcefile [makeFile {} source.file] file delete $sourcefile set f [open $sourcefile w] - fconfigure $f -encoding unicode + chan configure $f -encoding unicode puts $f "set symbol(square-root) \u221A; set x correct" close $f } -body { @@ -256,7 +256,7 @@ test source-7.5 {source -encoding: correct operation} -setup { set sourcefile [makeFile {} source.file] file delete $sourcefile set f [open $sourcefile w] - fconfigure $f -encoding utf-8 + chan configure $f -encoding utf-8 puts $f "proc \u20ac {} {return foo}" close $f } -body { @@ -270,7 +270,7 @@ test source-7.6 {source -encoding: mismatch encoding error} -setup { set sourcefile [makeFile {} source.file] file delete $sourcefile set f [open $sourcefile w] - fconfigure $f -encoding utf-8 + chan configure $f -encoding utf-8 puts $f "proc \u20ac {} {return foo}" close $f } -body { diff --git a/tests/split.test b/tests/split.test index 778131f..65202bd 100644 --- a/tests/split.test +++ b/tests/split.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } diff --git a/tests/string.test b/tests/string.test index f558d30..2f78242 100644 --- a/tests/string.test +++ b/tests/string.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -22,8 +22,8 @@ catch [list package require -exact Tcltest [info patchlevel]] # Some tests require the testobj command -testConstraint testobj [expr {[info commands testobj] != {}}] -testConstraint testindexobj [expr {[info commands testindexobj] != {}}] +testConstraint testobj [expr {[info commands testobj] ne ""}] +testConstraint testindexobj [expr {[info commands testindexobj] ne ""}] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] @@ -291,14 +291,13 @@ test string-5.20 {string index, bytearray object out of bounds} { string index [binary format I* {0x50515253 0x52}] 20 } {} - proc largest_int {} { # This will give us what the largest valid int on this machine is, # so we can test for overflow properly below on >32 bit systems set int 1 set exp 7; # assume we get at least 8 bits - while {wide($int) > 0} { set int [expr {wide(1) << [incr exp]}] } - return [expr {$int-1}] + while { ( wide ($int) ) > 0} { set int [expr { ( wide (1) ) << [incr exp]}] } + return [expr {$int - 1}] } test string-6.1 {string is, too few args} { @@ -326,7 +325,7 @@ test string-6.8 {string is, error in var} { list [string is alpha -failindex var abc5def] $var } {0 3} test string-6.9 {string is, var shouldn't get set} { - catch {unset var} + unset -nocomplain var list [catch {string is alpha -failindex var abc; set var} msg] $msg } {1 {can't read "var": no such variable}} test string-6.10 {string is, ok on empty} { @@ -444,11 +443,11 @@ test string-6.45 {string is false, false} { list [string is false -fail var abc] $var } {0 0} test string-6.46 {string is false, false} { - catch {unset var} + unset -nocomplain var list [string is false -fail var Y] $var } {0 0} test string-6.47 {string is false, false} { - catch {unset var} + unset -nocomplain var list [string is false -fail var offensive] $var } {0 0} test string-6.48 {string is integer, true} { @@ -530,11 +529,11 @@ test string-6.72 {string is true, false} { list [string is true -fail var onto] $var } {0 0} test string-6.73 {string is true, false} { - catch {unset var} + unset -nocomplain var list [string is true -fail var 25] $var } {0 0} test string-6.74 {string is true, false} { - catch {unset var} + unset -nocomplain var list [string is true -fail var no] $var } {0 0} test string-6.75 {string is upper, true} { diff --git a/tests/stringComp.test b/tests/stringComp.test index 9e00ce7..2a92e59 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -15,7 +15,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -39,7 +39,7 @@ test stringComp-1.3 {error condition - undefined method during compile} { # We don't want this to complain about 'never' because it may never # be called, or string may get redefined. This must compile OK. proc foo {str i} { - if {"yes" == "no"} { string never called but complains here } + if {"yes" eq "no"} { string never called but complains here } string index $str $i } foo abc 0 @@ -353,14 +353,13 @@ test stringComp-5.20 {string index, bytearray object out of bounds} { foo } {} - proc largest_int {} { # This will give us what the largest valid int on this machine is, # so we can test for overflow properly below on >32 bit systems set int 1 set exp 7; # assume we get at least 8 bits while {$int > 0} { set int [expr {1 << [incr exp]}] } - return [expr {$int-1}] + return [expr {$int - 1}] } ## string is diff --git a/tests/stringObj.test b/tests/stringObj.test index 6f331d3..0cc2d81 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } diff --git a/tests/subst.test b/tests/subst.test index 4be4798..9df0a1b 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2.1 namespace import -force ::tcltest::* } @@ -55,13 +55,13 @@ test subst-4.2 {variable substitutions} { subst {x$a.y{$a}.z} } {x44.y{44}.z} test subst-4.3 {variable substitutions} -setup { - catch {unset a} + unset -nocomplain a } -body { set a(13) 82 set i 13 subst {x.$a($i)} } -result {x.82} -catch {unset a} +unset -nocomplain a set long {This is a very long string, intentionally made so long that it will overflow the static character size for dstrings, so that additional memory will have to be allocated by subst. That way, @@ -113,7 +113,7 @@ test subst-5.10 {command substitutions} { } {1 {missing close-bracket}} test subst-6.1 {clear the result after command substitution} -body { - catch {unset a} + unset -nocomplain a subst {[concat foo] $a} } -returnCodes error -result {can't read "a": no such variable} @@ -178,7 +178,7 @@ test subst-9.2 {error in a subst} -body { subst {[if 1 { error foo; bogus code}]bar} } -returnCodes error -result foo test subst-9.3 {error in a variable subst} -setup { - catch {unset var} + unset -nocomplain var } -body { subst {foo $var([error foo]) bar} } -returnCodes error -result foo diff --git a/tests/switch.test b/tests/switch.test index a03948b..c384766 100644 --- a/tests/switch.test +++ b/tests/switch.test @@ -327,14 +327,70 @@ test switch-10.5 {compiled -exact switch} { } 1 test switch-10.6 {compiled -exact switch} { if 1 {switch -exact -- b {a { - set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 - set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 - set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 - set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 - set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 - set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 - set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 - set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1;set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 + set x 1 } b {subst 2}}} } 2 @@ -342,118 +398,146 @@ test switch-10.6 {compiled -exact switch} { # c* are compiled switches, i* are interpreted # *-glob use glob matching, *-exact use exact matching # *2* include a default clause (different results too.) -proc cswtest-glob s { - set x 0; set y 0 - foreach c [split $s {}] { - switch -glob $c { +proc cswtest-glob {s} { + set x 0 + set y 0 + foreach c [split $s ""] { + switch -glob -- $c { a {incr x} b {incr y} } } - set x [expr {$x*100}]; set y [expr {$y*100}] - foreach c [split $s {}] { + set x [expr {$x * 100}] + set y [expr {$y * 100}] + foreach c [split $s ""] { switch -glob -- $c a {incr x} b {incr y} } return $x,$y } -proc iswtest-glob s { - set x 0; set y 0; set switch switch - foreach c [split $s {}] { - $switch -glob $c { +proc iswtest-glob {s} { + set x 0 + set y 0 + set switch switch + foreach c [split $s ""] { + $switch -glob -- $c { a {incr x} b {incr y} } } - set x [expr {$x*100}]; set y [expr {$y*100}] - foreach c [split $s {}] { + set x [expr {$x * 100}] + set y [expr {$y * 100}] + foreach c [split $s ""] { $switch -glob -- $c a {incr x} b {incr y} } return $x,$y } -proc cswtest-exact s { - set x 0; set y 0 - foreach c [split $s {}] { - switch -exact $c { +proc cswtest-exact {s} { + set x 0 + set y 0 + foreach c [split $s ""] { + switch -exact -- $c { a {incr x} b {incr y} } } - set x [expr {$x*100}]; set y [expr {$y*100}] + set x [expr {$x * 100}] + set y [expr {$y * 100}] foreach c [split $s {}] { switch -exact -- $c a {incr x} b {incr y} } return $x,$y } -proc iswtest-exact s { - set x 0; set y 0; set switch switch - foreach c [split $s {}] { - $switch -exact $c { +proc iswtest-exact {s} { + set x 0 + set y 0 + set switch switch + foreach c [split $s ""] { + $switch -exact -- $c { a {incr x} b {incr y} } } - set x [expr {$x*100}]; set y [expr {$y*100}] - foreach c [split $s {}] { + set x [expr {$x * 100}] + set y [expr {$y * 100}] + foreach c [split $s ""] { $switch -exact -- $c a {incr x} b {incr y} } return $x,$y } -proc cswtest2-glob s { - set x 0; set y 0; set z 0 - foreach c [split $s {}] { - switch -glob $c { +proc cswtest2-glob {s} { + set x 0 + set y 0 + set z 0 + foreach c [split $s ""] { + switch -glob -- $c { a {incr x} b {incr y} default {incr z} } } - set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}] - foreach c [split $s {}] { + set x [expr {$x * 100}] + set y [expr {$y * 100}] + set z [expr {$z * 100}] + foreach c [split $s ""] { switch -glob -- $c a {incr x} b {incr y} default {incr z} } return $x,$y,$z } -proc iswtest2-glob s { - set x 0; set y 0; set z 0; set switch switch - foreach c [split $s {}] { - $switch -glob $c { +proc iswtest2-glob {s} { + set x 0 + set y 0 + set z 0 + set switch switch + foreach c [split $s ""] { + $switch -glob -- $c { a {incr x} b {incr y} default {incr z} } } - set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}] - foreach c [split $s {}] { + set x [expr {$x * 100}] + set y [expr {$y * 100}] + set z [expr {$z * 100}] + foreach c [split $s ""] { $switch -glob -- $c a {incr x} b {incr y} default {incr z} } return $x,$y,$z } -proc cswtest2-exact s { - set x 0; set y 0; set z 0 - foreach c [split $s {}] { - switch -exact $c { +proc cswtest2-exact {s} { + set x 0 + set y 0 + set z 0 + foreach c [split $s ""] { + switch -exact -- $c { a {incr x} b {incr y} default {incr z} } } - set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}] - foreach c [split $s {}] { + set x [expr {$x * 100}] + set y [expr {$y * 100}] + set z [expr {$z * 100}] + foreach c [split $s ""] { switch -exact -- $c a {incr x} b {incr y} default {incr z} } return $x,$y,$z } -proc iswtest2-exact s { - set x 0; set y 0; set z 0; set switch switch - foreach c [split $s {}] { - $switch -exact $c { +proc iswtest2-exact {s} { + set x 0 + set y 0 + set z 0 + set switch switch + foreach c [split $s ""] { + $switch -exact -- $c { a {incr x} b {incr y} default {incr z} } } - set x [expr {$x*100}]; set y [expr {$y*100}]; set z [expr {$z*100}] - foreach c [split $s {}] { + set x [expr {$x * 100}] + set y [expr {$y * 100}] + set z [expr {$z * 100}] + foreach c [split $s ""] { $switch -exact -- $c a {incr x} b {incr y} default {incr z} } return $x,$y,$z diff --git a/tests/tailcall.test b/tests/tailcall.test index 2d04f82..dcbdaa7 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -34,9 +34,9 @@ if {[testConstraint testnrelevels]} { proc depthDiff {} { variable last set depth [testnrelevels] - set res {} + set res [list] foreach t $depth l $last { - lappend res [expr {$t-$l}] + lappend res [expr {$t - $l}] } set last $depth return $res @@ -46,7 +46,7 @@ if {[testConstraint testnrelevels]} { namespace import testnre::* } -proc errorcode options { +proc errorcode {options} { dict get [dict merge {-errorcode NONE} $options] -errorcode } @@ -222,7 +222,6 @@ test tailcall-1 {tailcall} -body { namespace delete a b } -result {1::b | 0:: *::a *::b | {{1 ::b::moo} {2 xset}}} - test tailcall-2 {tailcall in non-proc} -body { namespace eval a [list tailcall set x 1] } -match glob -result *tailcall* -returnCodes error @@ -232,7 +231,7 @@ test tailcall-3 {tailcall falls off tebc} -body { proc foo {} {tailcall set x 1} list [catch foo msg] $msg [set x] } -cleanup { - rename foo {} + rename foo "" unset x } -result {0 1 1} diff --git a/tests/timer.test b/tests/timer.test index ab6efc9..45c3a3a 100644 --- a/tests/timer.test +++ b/tests/timer.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -466,7 +466,7 @@ test timer-7.5 {GetAfterEvent procedure} -returnCodes error -body { } -result "event \"after#${lastId}x\" doesn't exist" test timer-7.6 {GetAfterEvent procedure} -returnCodes error -body { after info afterx[expr {$lastId+1}] -} -result "event \"afterx[expr {$lastId+1}]\" doesn't exist" +} -result "event \"afterx[expr {$lastId + 1}]\" doesn't exist" after cancel $event test timer-8.1 {AfterProc procedure} { diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test index 2453e01..9b5d305 100644 --- a/tests/unixFCmd.test +++ b/tests/unixFCmd.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -28,10 +28,10 @@ cd [temporaryDirectory] set user {} if {[testConstraint unix]} { catch {set user [exec whoami]} - if {$user == ""} { + if {$user eq ""} { catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} } - if {$user == ""} { + if {$user eq ""} { set user "root" } } @@ -77,9 +77,9 @@ proc cleanup {args} { } foreach file $x { if { - [catch {file delete -force -- $file}] - && [testConstraint testchmod] - } then { + [catch {file delete -force -- $file}] && + [testConstraint testchmod] + } { openup $file file delete -force -- $file } diff --git a/tests/unixFile.test b/tests/unixFile.test index 8147f48..4dd9920 100644 --- a/tests/unixFile.test +++ b/tests/unixFile.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test index 2f03529..a88be90 100644 --- a/tests/unixNotfy.test +++ b/tests/unixNotfy.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -20,8 +20,8 @@ testConstraint noTk [expr {0 != [catch {package present Tk}]}] testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] # Darwin always uses a threaded notifier testConstraint unthreaded [expr { - ![::tcl::pkgconfig get threaded] - && $tcl_platform(os) ne "Darwin" + (![::tcl::pkgconfig get threaded]) && + ($tcl_platform(os) ne "Darwin") }] # The next two tests will hang if threads are enabled because the notifier @@ -30,7 +30,7 @@ testConstraint unthreaded [expr { test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -body { catch {vwait x} set f [open [makeFile "" foo] w] - fileevent $f writable {set x 1} + chan event $f writable {set x 1} vwait x close $f list [catch {vwait x} msg] $msg @@ -42,8 +42,8 @@ test unixNotfy-1.2 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} - catch {vwait x} set f1 [open [makeFile "" foo] w] set f2 [open [makeFile "" foo2] w] - fileevent $f1 writable {set x 1} - fileevent $f2 writable {set y 1} + chan event $f1 writable {set x 1} + chan event $f2 writable {set y 1} vwait x close $f1 vwait y @@ -61,7 +61,7 @@ test unixNotfy-2.1 {Tcl_DeleteFileHandler} \ -body { update set f [open [makeFile "" foo] w] - fileevent $f writable {set x 1} + chan event $f writable {set x 1} vwait x close $f thread::create "thread::send [thread::id] {set x ok}" @@ -79,8 +79,8 @@ test unixNotfy-2.2 {Tcl_DeleteFileHandler} \ update set f1 [open [makeFile "" foo] w] set f2 [open [makeFile "" foo2] w] - fileevent $f1 writable {set x 1} - fileevent $f2 writable {set y 1} + chan event $f1 writable {set x 1} + chan event $f2 writable {set y 1} vwait x close $f1 vwait y diff --git a/tests/unload.test b/tests/unload.test index 5a374c4..56e71cd 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } diff --git a/tests/uplevel.test b/tests/uplevel.test index 0410469..fa185a5 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.test @@ -11,13 +11,13 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } proc a {x y} { - newset z [expr $x+$y] + newset z [expr {$x + $y}] return $z } proc newset {name value} { @@ -103,7 +103,7 @@ test uplevel-4.4 {error: not enough args} -returnCodes error -body { } -result {wrong # args: should be "uplevel ?level? command ?arg ...?"} proc a2 {} { - uplevel a3 + uplevel 1 a3 } proc a3 {} { global x y @@ -114,11 +114,11 @@ a2 test uplevel-5.1 {info level} {set x} 1 test uplevel-5.2 {info level} {set y} a3 -namespace eval ns1 { - proc set args {return ::ns1} +namespace eval {ns1} { + proc set {args} {return ::ns1} } proc a2 {} { - uplevel {set x ::} + uplevel 1 {set x ::} } test uplevel-6.1 {uplevel and shadowed cmds} { set res [namespace eval ns1 a2] diff --git a/tests/upvar.test b/tests/upvar.test index e2c9ffd..0087c62 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -83,8 +83,7 @@ test upvar-2.2 {writing variables with upvar} { list $x1 $x2 } {newbits morebits} test upvar-2.3 {writing variables with upvar} { - catch {unset x1} - catch {unset x2} + unset -nocomplain x1 x2 proc p1 {x1 x2} { upvar #0 x1 a upvar x2 b @@ -156,11 +155,15 @@ test upvar-3.6 {unsetting then resetting array elements with upvar} { set a(0) zeroth set a(1) first set a(2) second - p2 + p2 list [lsort [array names a]] [catch {set a(0)} msg] $msg } - proc p2 {} {upvar a(0) x; unset x; set x 12345} - p1 + proc p2 {} { + upvar a(0) x + unset x + set x 12345 + } + p1 } {{0 1 2} 0 12345} test upvar-4.1 {nested upvars} { @@ -185,10 +188,21 @@ test upvar-4.2 {nested upvars} { list [p1 14 15] $x1 } {{14 15 bar 33} foo} -proc tproc {args} {global x; set x [list $args [uplevel info vars]]} +proc tproc {args} { + global x + set x [list $args [uplevel 1 info vars]] +} test upvar-5.1 {traces involving upvars} { - proc p1 {a b} {set c 22; set d 33; trace var c rw tproc; p2} - proc p2 {} {upvar c x1; set x1 22} + proc p1 {a b} { + set c 22 + set d 33 + trace var c rw tproc + p2 + } + proc p2 {} { + upvar 1 c x1 + set x1 22 + } set x --- p1 foo bar set x @@ -252,7 +266,7 @@ test upvar-6.3 {retargeting an upvar} { test upvar-7.1 {upvar to same level} { set x 44 set y 55 - catch {unset uv} + unset -nocomplain uv upvar #0 x uv set uv abc upvar 0 y uv @@ -322,7 +336,7 @@ test upvar-8.7 {errors in upvar command} -returnCodes error -body { } -result {variable "a" has traces: can't use for upvar} test upvar-8.8 {create nested array with upvar} -body { proc p1 {} {upvar x(a) b; set b(2) 44} - catch {unset x} + unset -nocomplain x p1 } -returnCodes error -cleanup { unset x @@ -341,13 +355,13 @@ test upvar-8.9 {upvar won't create namespace variable that refers to procedure v MakeLink 1 } -result {bad variable name "a": upvar won't create namespace variable that refers to procedure variable} test upvar-8.10 {upvar will create element alias for new array element} -setup { - catch {unset upvarArray} + unset -nocomplain upvarArray } -body { array set upvarArray {} catch {upvar 0 upvarArray(elem) upvarArrayElemAlias} } -result {0} test upvar-8.11 {upvar will not create a variable that looks like an array} -setup { - catch {unset upvarArray} + unset -nocomplain upvarArray } -body { array set upvarArray {} upvar 0 upvarArray(elem) upvarArrayElemAlias(elem) @@ -357,8 +371,7 @@ test upvar-9.1 {Tcl_UpVar2 procedure} testupvar { list [catch {testupvar xyz a {} x global} msg] $msg } {1 {bad level "xyz"}} test upvar-9.2 {Tcl_UpVar2 procedure} testupvar { - catch {unset a} - catch {unset x} + unset -nocomplain a x set a 44 list [catch "testupvar #0 a 1 x global" msg] $msg } {1 {can't access "a(1)": variable isn't array}} @@ -367,8 +380,7 @@ test upvar-9.3 {Tcl_UpVar2 procedure} testupvar { testupvar 1 a {} x local set x } - catch {unset a} - catch {unset x} + unset -nocomplain a x set a 44 foo } {44} @@ -377,8 +389,7 @@ test upvar-9.4 {Tcl_UpVar2 procedure} testupvar { testupvar 1 a {} _up_ global list [catch {set x} msg] $msg } - catch {unset a} - catch {unset _up_} + unset -nocomplain a _up_ set a 44 concat [foo] $_up_ } {1 {can't read "x": no such variable} 44} @@ -387,8 +398,7 @@ test upvar-9.5 {Tcl_UpVar2 procedure} testupvar { testupvar 1 a b x local set x } - catch {unset a} - catch {unset x} + unset -nocomplain a x set a(b) 1234 foo } {1234} @@ -397,8 +407,7 @@ test upvar-9.6 {Tcl_UpVar procedure} testupvar { testupvar 1 a x local set x } - catch {unset a} - catch {unset x} + unset -nocomplain a x set a xyzzy foo } {xyzzy} @@ -407,12 +416,11 @@ test upvar-9.7 {Tcl_UpVar procedure} testupvar { testupvar #0 a(b) x local set x } - catch {unset a} - catch {unset x} + unset -nocomplain a x set a(b) 1234 foo } {1234} -catch {unset a} +unset -nocomplain a # # Tests for 'namespace upvar'. As the implementation is essentially the same as diff --git a/tests/utf.test b/tests/utf.test index c41cfe3..aea9cf6 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -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. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } @@ -16,7 +16,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -catch {unset x} +unset -nocomplain x test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} { set x \x01 @@ -120,7 +120,6 @@ test utf-9.2 {Tcl_UtfAtIndex: index > 0} { string range \u4e4e\u25a\xff\u543klmnop 1 5 } "\u25a\xff\u543kl" - test utf-10.1 {Tcl_UtfBackslash: dst == NULL} { set x \n } { diff --git a/tests/util.test b/tests/util.test index 0e50483..0718239 100644 --- a/tests/util.test +++ b/tests/util.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -96,26 +96,26 @@ proc convertDouble { x } { return $result } -proc verdonk_test {sig binexp shouldbe exp} { - regexp {([-+]?)([0-9a-f]+)} $sig -> signum sig +proc verdonk_test {a_sig a_binexp shouldbe exp} { + regexp {([-+]?)([0-9a-f]+)} $a_sig ___ signum sig scan $sig %llx sig - if {$signum eq {-}} { - set signum [expr 1<<63] + if {$signum eq "-"} { + set signum [expr {1 << 63}] } else { set signum 0 } - regexp {E([-+]?[0-9]+)} $binexp -> binexp - set word [expr {$signum | (($binexp + 0x3ff)<<52)|($sig & ~(1<<52))}] + regexp {E([-+]?[0-9]+)} $a_binexp ___ binexp + set word [expr {$signum | (($binexp + 0x3ff) << 52) | ($sig & ( ~ (1 << 52)))}] binary scan [binary format w $word] q double - regexp {([-+])(\d+)_(\d+)\&} $shouldbe -> signum digits1 digits2 - regexp {E([-+]\d+)} $exp -> decexp + regexp {([-+])(\d+)_(\d+)&} $shouldbe ___ signum digits1 digits2 + regexp {E([-+]\d+)} $exp ___ decexp incr decexp [expr {[string length $digits1] - 1}] lassign [testdoubledigits $double [string length $digits1] e] \ outdigits decpt outsign if {[string index $digits2 0] >= 5} { incr digits1 } - if {$outsign != $signum || $outdigits != $digits1 || $decpt != $decexp} { + if {($outsign != $signum) || ($outdigits != $digits1) || ($decpt != $decexp)} { return -code error "result is ${outsign}0.${outdigits}E$decpt\ should be ${signum}0.${digits1}E$decexp" } @@ -2153,8 +2153,8 @@ foreach ::tcl_precision {0 12} { 1.1 for {set e 1} {$e < 17} {incr e} { test util-16.1.$::tcl_precision.$e {shortening of numbers} \ - "expr 11[string repeat 0 [expr {$e-1}]].0" \ - 11[string repeat 0 [expr {$e-1}]].0 + "expr 11[string repeat 0 [expr {$e - 1}]].0" \ + 11[string repeat 0 [expr {$e - 1}]].0 } for {set e 17} {$e < 309} {incr e} { test util-16.1.$::tcl_precision.$e {shortening of numbers} \ diff --git a/tests/var.test b/tests/var.test index ed7e930..e3f2914 100644 --- a/tests/var.test +++ b/tests/var.test @@ -28,15 +28,10 @@ testConstraint testsetnoerr [llength [info commands testsetnoerr]] catch {rename p ""} catch {namespace delete test_ns_var} -catch {unset xx} -catch {unset x} -catch {unset y} -catch {unset i} -catch {unset a} -catch {unset arr} +unset -nocomplain xx x y i a arr test var-1.1 {TclLookupVar, Array handling} -setup { - catch {unset a} + unset -nocomplain a } -body { set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd set i 10 @@ -84,7 +79,7 @@ test var-1.9 {TclLookupVar, create new namespace var} { } } {hello} test var-1.10 {TclLookupVar, create new namespace var} -setup { - catch {unset y} + unset -nocomplain y } -body { namespace eval test_ns_var { set ::y 789 @@ -102,7 +97,7 @@ test var-1.12 {TclLookupVar, error creating new namespace var} -body { } } -returnCodes error -result {can't set "::test_ns_var::foo::": parent namespace doesn't exist} test var-1.13 {TclLookupVar, new namespace var is created in a particular namespace} { - catch {unset aNeWnAmEiNnS} + unset -nocomplain aNeWnAmEiNnS namespace eval test_ns_var { namespace eval test_ns_var2::test_ns_var3 { set aNeWnAmEiNnS 77777 @@ -184,12 +179,12 @@ test var-1.19 {TclLookupVar, right error message when parsing variable name} -bo } -returnCodes error -result {can't read "thisvar(doesntexist)": no such variable} test var-2.1 {Tcl_LappendObjCmd, create var if new} { - catch {unset x} + unset -nocomplain x lappend x 1 2 } {1 2} test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} -setup { - catch {unset x} + unset -nocomplain x } -body { set x 1997 proc p {} { @@ -200,7 +195,7 @@ test var-3.1 {MakeUpvar, TCL_NAMESPACE_ONLY not specified for other var} -setup } -result {1997} test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} { namespace eval test_ns_var { - catch {unset v} + unset -nocomplain v variable v 1998 proc p {} { variable v ;# TCL_NAMESPACE_ONLY specified for other var x @@ -210,7 +205,7 @@ test var-3.2 {MakeUpvar, other var has TCL_NAMESPACE_ONLY specified} { } } {1998} test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} -setup { - catch {unset a} + unset -nocomplain a } -constraints testupvar -body { set a 123321 proc p {} { @@ -220,11 +215,11 @@ test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} -setup { list [p] $xx [set xx 789] $a } -result {{} 123321 789 789} test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} -setup { - catch {unset a} + unset -nocomplain a } -constraints testupvar -body { set a 456 namespace eval test_ns_var { - catch {unset ::test_ns_var::vv} + unset -nocomplain ::test_ns_var::vv proc p {} { # create namespace var vv linked to global a testupvar 1 a {} vv namespace @@ -234,15 +229,14 @@ test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} -setup { list $test_ns_var::vv [set test_ns_var::vv 123] $a } -result {456 123 123} test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} -setup { - catch {unset aaaaa} - catch {unset xxxxx} + unset -nocomplain aaaaa xxxxx } -body { set aaaaa 77777 upvar #0 aaaaa xxxxx list [set xxxxx] [set aaaaa] } -result {77777 77777} test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} -setup { - catch {unset a} + unset -nocomplain a } -body { set a 121212 namespace eval test_ns_var { @@ -251,7 +245,7 @@ test var-3.6 {MakeUpvar, active call frame pushed for namespace eval} -setup { } } -result {121212} test var-3.7 {MakeUpvar, my var has ::s} -setup { - catch {unset a} + unset -nocomplain a } -body { set a 789789 upvar #0 a test_ns_var::lnk @@ -260,8 +254,7 @@ test var-3.7 {MakeUpvar, my var has ::s} -setup { } } -result {789789} test var-3.8 {MakeUpvar, my var already exists in global ns} -setup { - catch {unset aaaaa} - catch {unset xxxxx} + unset -nocomplain aaaaa xxxxx } -body { set aaaaa 456654 set xxxxx hello @@ -269,7 +262,7 @@ test var-3.8 {MakeUpvar, my var already exists in global ns} -setup { set xxxxx } -result {hello} test var-3.9 {MakeUpvar, my var has invalid ns name} -setup { - catch {unset aaaaa} + unset -nocomplain aaaaa } -returnCodes error -body { set aaaaa 789789 upvar #0 aaaaa test_ns_fred::lnk @@ -285,14 +278,14 @@ test var-3.10 {MakeUpvar, between namespaces} -body { unset ::aaaaa } -result {1 1} test var-3.11 {MakeUpvar, my var looks like array elem} -setup { - catch {unset aaaaa} + unset -nocomplain aaaaa } -returnCodes error -body { set aaaaa 789789 upvar #0 aaaaa foo(bar) } -result {bad variable name "foo(bar)": upvar won't create a scalar variable that looks like an array element} test var-4.1 {Tcl_GetVariableName, global variable} testgetvarfullname { - catch {unset a} + unset -nocomplain a set a 123 testgetvarfullname a global } ::a @@ -303,14 +296,14 @@ test var-4.2 {Tcl_GetVariableName, namespace variable} testgetvarfullname { } } ::test_ns_var::george test var-4.3 {Tcl_GetVariableName, variable can't be array element} -setup { - catch {unset a} + unset -nocomplain a } -constraints testgetvarfullname -body { set a(1) foo testgetvarfullname a(1) global } -returnCodes error -result {unknown variable "a(1)"} test var-5.1 {Tcl_GetVariableFullName, global variable} -setup { - catch {unset a} + unset -nocomplain a } -body { set a bar namespace which -variable a @@ -403,9 +396,7 @@ test var-7.4 {Tcl_VariableObjCmd, list of vars} { [namespace eval test_ns_var {expr $three+$four}] } [list [lsort {::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one}] 7] test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} -setup { - catch {unset a} - catch {unset five} - catch {unset six} + unset -nocomplain a five six } -body { set a "" set five 555 @@ -417,18 +408,17 @@ test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} -setup { lappend a $test_ns_var::five \ [set test_ns_var::six 6] [set test_ns_var::six] $six } -cleanup { - catch {unset five} - catch {unset six} + unset -nocomplain five six } -result {5 5 6 6 666} test var-7.6 {Tcl_VariableObjCmd, variable name can be qualified} -setup { - catch {unset newvar} + unset -nocomplain newvar } -body { namespace eval test_ns_var { variable ::newvar cheers! } return $newvar } -cleanup { - catch {unset newvar} + unset -nocomplain newvar } -result {cheers!} test var-7.7 {Tcl_VariableObjCmd, bad var name} -returnCodes error -body { namespace eval test_ns_var { @@ -532,7 +522,7 @@ test var-7.17 {Tcl_VariableObjCmd, no args (TIP 323)} { test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var names} -setup { catch {namespace delete test_ns_var} - catch {unset a} + unset -nocomplain a } -body { namespace eval test_ns_var { variable v 123 @@ -547,7 +537,7 @@ test var-8.1 {TclDeleteVars, "unset" traces are called with fully-qualified var } -result {{} {test_ns_var::v {} u}} test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called with fully-qualified var names} -setup { catch {namespace delete test_ns_var} - catch {unset a} + unset -nocomplain a } -body { set info "" namespace eval test_ns_var { @@ -561,8 +551,7 @@ test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called wit } -result {{} {::test_ns_var::v {} u}} test var-9.1 {behaviour of TclGet/SetVar simple get/set} -setup { - catch {unset u} - catch {unset v} + unset -nocomplain u v } -constraints testsetnoerr -body { list \ [set u a; testsetnoerr u] \ @@ -581,7 +570,7 @@ test var-9.2 {behaviour of TclGet/SetVar namespace get/set} -setup { [unset ns::v; testseterr ns::v b] } -result [list {before get a} {before set b} {before get a} {before set b}] test var-9.3 {behaviour of TclGetVar no variable} -setup { - catch {unset u} + unset -nocomplain u } -constraints testsetnoerr -body { list \ [catch {testsetnoerr u} res] $res \ @@ -610,7 +599,7 @@ test var-9.6 {behaviour of TclSetVar no namespace} -setup { [catch {testseterr ns::v 1} res] $res } -result {1 {before set} 1 {can't set "ns::v": parent namespace doesn't exist}} test var-9.7 {behaviour of TclGetVar array variable} -setup { - catch {unset arr} + unset -nocomplain arr } -constraints testsetnoerr -body { set arr(1) 1 list \ @@ -618,7 +607,7 @@ test var-9.7 {behaviour of TclGetVar array variable} -setup { [catch {testseterr arr} res] $res } -result {1 {before get} 1 {can't read "arr": variable is array}} test var-9.8 {behaviour of TclSetVar array variable} -setup { - catch {unset arr} + unset -nocomplain arr } -constraints testsetnoerr -body { set arr(1) 1 list \ @@ -626,8 +615,7 @@ test var-9.8 {behaviour of TclSetVar array variable} -setup { [catch {testseterr arr 2} res] $res } -result {1 {before set} 1 {can't set "arr": variable is array}} test var-9.9 {behaviour of TclGetVar read trace success} -setup { - catch {unset u} - catch {unset v} + unset -nocomplain u v } -constraints testsetnoerr -body { proc resetvar {val name elem op} {upvar 1 $name v; set v $val} set u 10 @@ -646,8 +634,7 @@ test var-9.10 {behaviour of TclGetVar read trace error} testsetnoerr { [catch {testseterr v} msg] $msg } {1 {before get} 1 {can't read "v": write-only}} test var-9.11 {behaviour of TclSetVar write trace success} -setup { - catch {unset u} - catch {unset v} + unset -nocomplain u v } -constraints testsetnoerr -body { proc doubleval {name elem op} {upvar 1 $name v; set v [expr {2 * $v}]} set v 1 @@ -667,32 +654,32 @@ test var-9.12 {behaviour of TclSetVar write trace error} testsetnoerr { } {1 {before set} 2 1 {can't set "v": read-only} 3} test var-10.1 {can't nest arrays with array set} -setup { - catch {unset arr} + unset -nocomplain arr } -returnCodes error -body { array set arr(x) {a 1 b 2} } -result {can't set "arr(x)": variable isn't array} test var-10.2 {can't nest arrays with array set} -setup { - catch {unset arr} + unset -nocomplain arr } -returnCodes error -body { array set arr(x) {} } -result {can't set "arr(x)": variable isn't array} test var-11.1 {array unset} -setup { - catch {unset a} + unset -nocomplain a } -body { array set a { 1,1 a 1,2 b 2,1 c 2,3 d } array unset a 1,* lsort -dict [array names a] } -result {2,1 2,3} test var-11.2 {array unset} -setup { - catch {unset a} + unset -nocomplain a } -body { array set a { 1,1 a 1,2 b } array unset a array exists a } -result 0 test var-11.3 {array unset errors} -setup { - catch {unset a} + unset -nocomplain } -returnCodes error -body { array set a { 1,1 a 1,2 b } array unset a pattern too @@ -714,7 +701,7 @@ test var-12.1 {TclFindCompiledLocals, {} array name} { } {0 1 2 2,foo} test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} -setup { - catch {unset t} + unset -nocomplain t } -body { proc foo {var ind op} { global t @@ -795,19 +782,12 @@ test var-19.1 {crash when freeing locals hashtable: Bug 3037525} { } {} catch {namespace delete ns} -catch {unset arr} -catch {unset v} +unset -nocomplain arr v catch {rename p ""} catch {namespace delete test_ns_var} catch {namespace delete test_ns_var2} -catch {unset xx} -catch {unset x} -catch {unset y} -catch {unset i} -catch {unset a} -catch {unset xxxxx} -catch {unset aaaaa} +unset -nocomplain xx x y i a xxxxx aaaaa # cleanup ::tcltest::cleanupTests diff --git a/tests/while-old.test b/tests/while-old.test index ee17d0b..96e7d09 100644 --- a/tests/while-old.test +++ b/tests/while-old.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -94,7 +94,7 @@ test while-old-4.4 {errors in while loops} { list $err $msg } {1 {can't use non-numeric string as operand of "+"}} test while-old-4.5 {errors in while loops} { - catch {unset x} + unset -nocomplain x set x 1 set err [catch {while {$x} {set x foo}} msg] list $err $msg diff --git a/tests/while.test b/tests/while.test index 642ec93..de12d53 100644 --- a/tests/while.test +++ b/tests/while.test @@ -17,8 +17,7 @@ if {"::tcltest" ni [namespace children]} { # Basic "while" operation. -catch {unset i} -catch {unset a} +unset -nocomplain i a test while-1.1 {TclCompileWhileCmd: missing test expression} -body { while @@ -94,16 +93,14 @@ test while-1.10 {TclCompileWhileCmd: command body in quotes} -body { unset a i } -result {xxxxx} test while-1.11 {TclCompileWhileCmd: computed command body} -setup { - catch {unset x1} - catch {unset bb} - catch {unset x2} + unset -nocomplain x1 bb x2 } -body { set x1 {append a x1; } set bb {break} set x2 {; append a x2; incr i} - set a {} + set a "" set i 1 - while {$i<6} $x1$bb$x2 + while {$i < 6} $x1$bb$x2 return $a } -cleanup { unset x1 bb x2 a i @@ -114,27 +111,27 @@ test while-1.12 {TclCompileWhileCmd: long command body} -body { while {$i<6} { if $i==4 break if $i>5 continue - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg @@ -210,27 +207,27 @@ test while-2.4 {continue tests, long command body} -body { if $i==2 {incr i; continue} if $i==4 break if $i>5 continue - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg @@ -274,34 +271,34 @@ test while-3.2 {break tests, nested loops} -body { unset a i msg } -result {1.1 1.2 2.1 3.1 4.1} test while-3.3 {break tests, long command body} -body { - set a {} + set a "" set i 1 - while {$i<6} { - if $i==2 {incr i; continue} - if $i==5 break - if $i>5 continue - if {$i>6 && $tcl_platform(machine)=="xxx"} { + while {$i < 6} { + if {$i == 2} {incr i; continue} + if {$i == 5} break + if {$i > 5} continue + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } if $i==4 break - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg @@ -419,9 +416,7 @@ test while-4.11 {while (not compiled): command body in quotes} -body { unset a i z } -result {xxxxx} test while-4.12 {while (not compiled): computed command body} -setup { - catch {unset x1} - catch {unset bb} - catch {unset x2} + unset -nocomplain x1 bb x2 } -body { set z while set x1 {append a x1; } @@ -441,27 +436,27 @@ test while-4.13 {while (not compiled): long command body} -body { $z {$i<6} { if $i==4 break if $i>5 continue - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg @@ -541,28 +536,28 @@ test while-5.4 {break tests, long command body with computed command names} -bod if $i==2 {incr i; continue} if $i==5 $z if $i>5 continue - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } if $i==4 $z - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg @@ -640,27 +635,27 @@ test while-6.5 {continue tests, long command body with computed command names} - if $i==2 {incr i; continue} if $i==4 break if $i>5 $z - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg } - if {$i>6 && $tcl_platform(machine)=="xxx"} { + if {($i > 6) && ($tcl_platform(machine) eq "xxx")} { catch {set a $a} msg catch {incr i 5} msg catch {incr i -5} msg diff --git a/tests/winConsole.test b/tests/winConsole.test index fdde41c..2e0e904 100644 --- a/tests/winConsole.test +++ b/tests/winConsole.test @@ -9,18 +9,17 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } - test winConsole-1.1 {Console file channel: non-blocking gets} {win interactive} { - set oldmode [fconfigure stdin] + set oldmode [chan configure stdin] puts stdout "Enter abcdef<return> now: " nonewline flush stdout - fileevent stdin readable { + chan event stdin readable { if {[gets stdin line] >= 0} { set result $line } else { @@ -28,14 +27,14 @@ test winConsole-1.1 {Console file channel: non-blocking gets} {win interactive} } } - fconfigure stdin -blocking 0 -buffering line + chan configure stdin -blocking 0 -buffering line set result {} vwait result - #cleanup the fileevent - fileevent stdin readable {} - fconfigure stdin {*}$oldmode + #cleanup the chan event + chan event stdin readable {} + chan configure stdin {*}$oldmode set result diff --git a/tests/winDde.test b/tests/winDde.test index f04fb45..3acfe2b 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -31,10 +31,10 @@ if {[testConstraint win]} { # Setup a script for a test server # -set scriptName [makeFile {} script1.tcl] +set scriptName [makeFile "" script1.tcl] proc createChildProcess {ddeServerName args} { - file delete -force $::scriptName + file delete -force -- $::scriptName set f [open $::scriptName w+] puts $f [list set ddeServerName $ddeServerName] @@ -60,7 +60,7 @@ proc createChildProcess {ddeServerName args} { # Define a restricted handler. proc Handler1 {cmd} { if {$cmd eq "stop"} {set ::done 1} - if {$cmd == ""} { + if {$cmd eq ""} { set cmd "null data" } puts $cmd ; flush stdout @@ -96,8 +96,8 @@ proc createChildProcess {ddeServerName args} { # run the child server script. set f [open |[list [interpreter] $::scriptName] r] - fconfigure $f -buffering line - gets $f line + chan configure $f -buffering line + chan gets $f line return $f } @@ -482,7 +482,7 @@ test winDde-9.4 {External safe DDE check null data passing} -constraints {dde st #cleanup #catch {interp delete $slave}; # ensure we clean up the slave. -file delete -force $::scriptName +file delete -force -- $::scriptName ::tcltest::cleanupTests return diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 28a0e9f..6cb2fd1 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -50,7 +50,7 @@ proc cleanup {args} { catch { set x [glob -directory $p tf* td*] } - if {$x != ""} { + if {$x ne ""} { catch {file delete -force -- {*}$x} } } @@ -58,7 +58,7 @@ proc cleanup {args} { if {[testConstraint winOnly]} { set major [string index $tcl_platform(osVersion) 0] - if {[testConstraint nt] && $major > 4} { + if {[testConstraint nt] && ($major > 4)} { if {$major > 5} { testConstraint winVista 1 } elseif {$major == 5} { @@ -86,7 +86,7 @@ proc findfile {dir} { if {[testConstraint testvolumetype]} { foreach p {d e f g h i j k l m n o p q r s t u v w x y z} { - if {![catch {testvolumetype ${p}:} result] && $result in {CDFS UDF}} { + if {(![catch {testvolumetype ${p}:} result]) && ($result in {CDFS UDF})} { set cdrom ${p}: set cdfile [findfile $cdrom] testConstraint cdrom 1 @@ -424,14 +424,13 @@ test winFCmd-1.38 {TclpRenameFile: check rename of conflicting inodes} -setup { cleanup } -constraints {win winNonZeroInodes} -body { file mkdir td1 - foreach {a b} [MakeFiles td1] break + lassign [MakeFiles td1] a b file rename -force $a $b file exists $a } -cleanup { cleanup } -result {0} - test winFCmd-2.1 {TclpCopyFile: errno: EACCES} -setup { cleanup } -constraints {win cdrom testfile} -body { diff --git a/tests/winFile.test b/tests/winFile.test index fba9bcb..2954272 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -26,7 +26,7 @@ testConstraint win2000 0 if {[testConstraint testvolumetype]} { testConstraint notNTFS [expr {[testvolumetype] eq "NTFS"}] } -if {[testConstraint nt] && $::tcl_platform(osVersion) >= 5.0} { +if {[testConstraint nt] && ($::tcl_platform(osVersion) >= 5.0)} { testConstraint win2000 1 } @@ -86,7 +86,7 @@ test winFile-3.1 {file system} -constraints {win testvolumetype} -setup { } } set res -} -result {} +} -result "" proc cacls {fname args} { string trim [eval [list exec cacls [file nativename $fname]] $args <<y] @@ -106,7 +106,7 @@ proc getuser {fname} { } set owner "" set tail [file tail $tryname] - if {[info exists env(OSTYPE)] && $env(OSTYPE) eq "msys"} { + if {[info exists env(OSTYPE)] && ($env(OSTYPE) eq "msys")} { set dirtext [exec ls -l $fname] foreach line [split $dirtext "\n"] { set owner [lindex $line 2] @@ -131,26 +131,26 @@ proc test_read {fname} { if {[catch {open $fname r} ifs]} { return 0 } - set readfailed [catch {read $ifs}] - return [expr {![catch {close $ifs}] && !$readfailed}] + set readfailed [catch {chan read $ifs}] + return [expr {(![catch {chan close $ifs}]) && (!$readfailed)}] } proc test_writ {fname} { if {[catch {open $fname w} ofs]} { return 0 } - set writefailed [catch {puts $ofs "Hello"}] - return [expr {![catch {close $ofs}] && !$writefailed}] + set writefailed [catch {chan puts $ofs "Hello"}] + return [expr {(![catch {chan close $ofs}]) && (!$writefailed)}] } proc test_access {fname read writ} { - set problem {} + set problem [list] foreach type {read writ} { - if {[set $type] != [file ${type}able $fname]} { - lappend problem "[set $type] != \[file ${type}able $fname\]" + if {[set [set type]] != [file ${type}able $fname]} { + lappend problem "[set [set type]] != \[file ${type}able $fname\]" } - if {[set $type] != [test_${type} $fname]} { - lappend problem "[set $type] != \[test_${type} $fname\]" + if {[set [set type]] != [test_${type} $fname]} { + lappend problem "[set [set type]] != \[test_${type} $fname\]" } } if {![llength $problem]} { @@ -165,8 +165,8 @@ if {[testConstraint win]} { # creation in a particular filesystem? If not, try [makeFile] # in a -setup script. set fname test.dat - file delete $fname - close [open $fname w] + file delete -- $fname + chan close [open $fname w] } test winFile-4.0 { @@ -183,7 +183,7 @@ test winFile-4.0 { catch {cacls $fname /E /R $owner} result cacls $fname /E /P $user:N test_access $fname 0 0 -} -result {} +} -result "" test winFile-4.1 { Enhanced NTFS user/group permissions: test readable only } -constraints { @@ -194,7 +194,7 @@ test winFile-4.1 { cacls $fname /E /P $user:N cacls $fname /E /G $user:R test_access $fname 1 0 -} -result {} +} -result "" test winFile-4.2 { Enhanced NTFS user/group permissions: test writable only } -constraints { @@ -206,7 +206,7 @@ test winFile-4.2 { cacls $fname /E /P $user:N cacls $fname /E /G $user:W test_access $fname 0 1 -} -result {} +} -result "" test winFile-4.3 { Enhanced NTFS user/group permissions: test read+write } -constraints { @@ -219,7 +219,7 @@ test winFile-4.3 { cacls $fname /E /G $user:R cacls $fname /E /G $user:W test_access $fname 1 1 -} -result {} +} -result "" test winFile-4.4 { Enhanced NTFS user/group permissions: test full access } -constraints { @@ -231,10 +231,10 @@ test winFile-4.4 { cacls $fname /E /P $user:N cacls $fname /E /G $user:F test_access $fname 1 1 -} -result {} +} -result "" if {[testConstraint win]} { - file delete $fname + file delete -- $fname } # cleanup diff --git a/tests/winNotify.test b/tests/winNotify.test index 3e9aa29..3e48dbf 100644 --- a/tests/winNotify.test +++ b/tests/winNotify.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } diff --git a/tests/winPipe.test b/tests/winPipe.test index d2e804d..f93e3e9 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -31,7 +31,6 @@ testConstraint AllocConsole [catch {puts console1 ""}] testConstraint RealConsole [expr {![testConstraint AllocConsole]}] testConstraint testexcept [llength [info commands testexcept]] - set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n append big $big append big $big @@ -42,8 +41,8 @@ append big $big set path(little) [makeFile {} little] set f [open $path(little) w] -puts -nonewline $f "little" -close $f +chan puts -nonewline $f "little" +chan close $f set path(big) [makeFile {} big] set f [open $path(big) w] @@ -191,8 +190,8 @@ test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} { } } set f [open "|[list $cat32] < $path(big) 2> $path(stderr)" r] - fconfigure $f -buffering none -blocking 0 - fileevent $f readable "readResults $f" + chan configure $f -buffering none -blocking 0 + chan event $f readable "readResults $f" set x 0 set result "" vwait x @@ -284,12 +283,12 @@ test winpipe-5.4 {TclpCreateTempFile: TEMP specifies non-existent directory} \ test winpipe-6.1 {PipeSetupProc & PipeCheckProc: read threads} \ {win exec cat32} { set f [open "|[list $cat32]" r+] - fconfigure $f -blocking 0 - fileevent $f writable { set x writable } - set x {} + chan configure $f -blocking 0 + chan event $f writable { set x writable } + set x "" vwait x - fileevent $f writable {} - fileevent $f readable { lappend x readable } + chan event $f writable {} + chan event $f readable { lappend x readable } after 100 { lappend x timeout } vwait x puts $f foobar @@ -298,16 +297,16 @@ test winpipe-6.1 {PipeSetupProc & PipeCheckProc: read threads} \ lappend x [read $f] after 100 { lappend x timeout } vwait x - fconfigure $f -blocking 1 + chan configure $f -blocking 1 lappend x [catch {close $f} msg] $msg } {writable timeout readable {foobar } timeout 1 stderr32} test winpipe-6.2 {PipeSetupProc & PipeCheckProc: write threads} \ {win exec cat32} { set f [open "|[list $cat32]" r+] - fconfigure $f -blocking 0 - fileevent $f writable { set x writable } - set x {} + chan configure $f -blocking 0 + chan event $f writable { set x writable } + set x "" vwait x puts -nonewline $f $big$big$big$big flush $f diff --git a/tests/winTime.test b/tests/winTime.test index add8f98..ceeca55 100644 --- a/tests/winTime.test +++ b/tests/winTime.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { +if {"::tcltest" ni [namespace children]} { package require tcltest namespace import -force ::tcltest::* } @@ -45,18 +45,18 @@ test winTime-2.1 {Synchronization of Tcl and Windows clocks} {testwinclock} { # http://support.microsoft.com/default.aspx?scid=kb;en-us;274323 set failed {} set ok 1 - foreach start_sec [testwinclock] break + lassign [testwinclock] start_sec while { 1 } { - foreach { sys_sec sys_usec tcl_sec tcl_usec } [testwinclock] break + lassign [testwinclock] sys_sec sys_usec tcl_sec tcl_usec set diff [expr { $tcl_sec - $sys_sec - + 1.0e-6 * ( $tcl_usec - $sys_usec ) }] + + (1.0e-6 * ( $tcl_usec - $sys_usec )) }] if { abs($diff) > 0.06 } { set failed "Tcl clock differs from system clock by $diff sec" break } else { testwinsleep 1 } - if { $sys_sec - $start_sec >= 30 } break + if { ($sys_sec - $start_sec) >= 30 } break } set failed } {} diff --git a/tests/zlib.test b/tests/zlib.test index 891dba0..c09e848 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -150,22 +150,22 @@ test zlib-8.2 {zlib transformation} -constraints zlib -setup { close $f removeFile $file } -result ok -test zlib-8.3 {zlib transformation and fileevent} -constraints zlib -setup { +test zlib-8.3 {zlib transformation and chan event} -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { - fconfigure $c -translation binary -buffering none -blocking 0 + chan configure $c -translation binary -buffering none -blocking 0 puts -nonewline $c [zlib gzip [string repeat a 81920]] close $c }}} 0] - set port [lindex [fconfigure $srv -sockname] 2] + set port [lindex [chan configure $srv -sockname] 2] set file [makeFile {} test.gz] set fout [open $file wb] } -body { set sin [socket localhost $port] try { - fconfigure $sin -translation binary + chan configure $sin -translation binary zlib push gunzip $sin after 1000 {set total timeout} - fcopy $sin $fout -command {apply {{c {e {}}} { + chan copy $sin $fout -command {apply {{c {e {}}} { set ::total [expr {$e eq {} ? $c : $e}] }}} vwait total @@ -185,46 +185,46 @@ test zlib-8.4 {transformation and flushing: Bug 3517696} -setup { } -constraints zlib -body { zlib push compress $fd puts $fd "qwertyuiop" - fconfigure $fd -flush sync + chan configure $fd -flush sync puts $fd "qwertyuiop" } -cleanup { catch {close $fd} removeFile $file } -result {} -test zlib-8.5 {transformation and flushing and fileevents: Bug 3525907} -setup { - foreach {r w} [chan pipe] break +test zlib-8.5 {transformation and flushing and chan events: Bug 3525907} -setup { + lassign [chan pipe] r w } -constraints zlib -body { set ::res {} - fconfigure $w -buffering none + chan configure $w -buffering none zlib push compress $w puts -nonewline $w qwertyuiop chan configure $w -flush sync after 500 {puts -nonewline $w asdfghjkl;close $w} - fconfigure $r -blocking 0 -buffering none + chan configure $r -blocking 0 -buffering none zlib push decompress $r - fileevent $r readable {set msg [read $r];lappend ::res $msg;if {[eof $r]} {set ::done 1}} + chan event $r readable {set msg [read $r];lappend ::res $msg;if {[eof $r]} {set ::done 1}} after 250 {lappend ::res MIDDLE} vwait ::done set ::res } -cleanup { catch {close $r} } -result {qwertyuiop MIDDLE asdfghjkl} -test zlib-8.6 {transformation and fconfigure} -setup { +test zlib-8.6 {transformation and chan configure} -setup { set file [makeFile {} test.z] set fd [open $file wb] } -constraints zlib -body { - list [fconfigure $fd] [zlib push compress $fd; fconfigure $fd] \ - [chan pop $fd; fconfigure $fd] + list [chan configure $fd] [zlib push compress $fd; chan configure $fd] \ + [chan pop $fd; chan configure $fd] } -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}} -test zlib-8.7 {transformation and fconfigure} -setup { +test zlib-8.7 {transformation and chan configure} -setup { set file [makeFile {} test.gz] set fd [open $file wb] } -constraints zlib -body { - list [fconfigure $fd] [zlib push gzip $fd; fconfigure $fd] \ - [chan pop $fd; fconfigure $fd] + list [chan configure $fd] [zlib push gzip $fd; chan configure $fd] \ + [chan pop $fd; chan configure $fd] } -cleanup { catch {close $fd} removeFile $file @@ -233,12 +233,12 @@ test zlib-8.7 {transformation and fconfigure} -setup { # 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" set spdyDict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl" -test zlib-8.8 {transformtion and fconfigure} -setup { +test zlib-8.8 {transformtion and chan configure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { zlib push compress $outSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -translation binary -buffering none - fconfigure $inSide -blocking 0 -translation binary + chan configure $outSide -blocking 0 -translation binary -buffering none + chan configure $inSide -blocking 0 -translation binary puts -nonewline $outSide $spdyHeaders chan pop $outSide set compressed [read $inSide] @@ -250,15 +250,15 @@ test zlib-8.8 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} } -result {260 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010} -test zlib-8.9 {transformtion and fconfigure} -setup { +test zlib-8.9 {transformtion and chan configure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream decompress] } -constraints zlib -body { zlib push compress $outSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -translation binary -buffering none - fconfigure $inSide -blocking 0 -translation binary + chan configure $outSide -blocking 0 -translation binary -buffering none + chan configure $inSide -blocking 0 -translation binary puts -nonewline $outSide $spdyHeaders - set result [fconfigure $outSide -checksum] + set result [chan configure $outSide -checksum] chan pop $outSide $strm put -dictionary $spdyDict [read $inSide] lappend result [string length $spdyHeaders] [string length [$strm get]] @@ -267,12 +267,12 @@ test zlib-8.9 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {3064818174 358 358} -test zlib-8.10 {transformtion and fconfigure} -setup { +test zlib-8.10 {transformtion and chan configure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { zlib push deflate $outSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -translation binary -buffering none - fconfigure $inSide -blocking 0 -translation binary + chan configure $outSide -blocking 0 -translation binary -buffering none + chan configure $inSide -blocking 0 -translation binary puts -nonewline $outSide $spdyHeaders chan pop $outSide set compressed [read $inSide] @@ -284,13 +284,13 @@ test zlib-8.10 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} } -result {254 212 {data error} {TCL ZLIB DATA}} -test zlib-8.11 {transformtion and fconfigure} -setup { +test zlib-8.11 {transformtion and chan configure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream inflate] } -constraints zlib -body { zlib push deflate $outSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -translation binary -buffering none - fconfigure $inSide -blocking 0 -translation binary + chan configure $outSide -blocking 0 -translation binary -buffering none + chan configure $inSide -blocking 0 -translation binary puts -nonewline $outSide $spdyHeaders chan pop $outSide $strm put -dictionary $spdyDict [read $inSide] @@ -300,48 +300,48 @@ test zlib-8.11 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} -test zlib-8.12 {transformtion and fconfigure} -setup { +test zlib-8.12 {transformtion and chan configure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] } -constraints zlib -body { $strm put -dictionary $spdyDict -finalize $spdyHeaders zlib push decompress $inSide - fconfigure $outSide -blocking 0 -translation binary - fconfigure $inSide -translation binary -dictionary $spdyDict + chan configure $outSide -blocking 0 -translation binary + chan configure $inSide -translation binary -dictionary $spdyDict puts -nonewline $outSide [$strm get] close $outSide list [string length $spdyHeaders] [string length [read $inSide]] \ - [fconfigure $inSide -checksum] + [chan configure $inSide -checksum] } -cleanup { catch {close $outSide} catch {close $inSide} catch {$strm close} } -result {358 358 3064818174} -test zlib-8.13 {transformtion and fconfigure} -setup { +test zlib-8.13 {transformtion and chan configure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] } -constraints zlib -body { $strm put -dictionary $spdyDict -finalize $spdyHeaders zlib push decompress $inSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -translation binary - fconfigure $inSide -translation binary + chan configure $outSide -blocking 0 -translation binary + chan configure $inSide -translation binary puts -nonewline $outSide [$strm get] close $outSide list [string length $spdyHeaders] [string length [read $inSide]] \ - [fconfigure $inSide -checksum] + [chan configure $inSide -checksum] } -cleanup { catch {close $outSide} catch {close $inSide} catch {$strm close} } -result {358 358 3064818174} -test zlib-8.14 {transformtion and fconfigure} -setup { +test zlib-8.14 {transformtion and chan configure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream deflate] } -constraints zlib -body { $strm put -finalize -dictionary $spdyDict $spdyHeaders zlib push inflate $inSide - fconfigure $outSide -blocking 0 -buffering none -translation binary - fconfigure $inSide -translation binary -dictionary $spdyDict + chan configure $outSide -blocking 0 -buffering none -translation binary + chan configure $inSide -translation binary -dictionary $spdyDict puts -nonewline $outSide [$strm get] close $outSide list [string length $spdyHeaders] [string length [read $inSide]] @@ -350,14 +350,14 @@ test zlib-8.14 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} -test zlib-8.15 {transformtion and fconfigure} -setup { +test zlib-8.15 {transformtion and chan configure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream deflate] } -constraints zlib -body { $strm put -finalize -dictionary $spdyDict $spdyHeaders zlib push inflate $inSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -buffering none -translation binary - fconfigure $inSide -translation binary + chan configure $outSide -blocking 0 -buffering none -translation binary + chan configure $inSide -translation binary puts -nonewline $outSide [$strm get] close $outSide list [string length $spdyHeaders] [string length [read $inSide]] @@ -367,7 +367,7 @@ test zlib-8.15 {transformtion and fconfigure} -setup { catch {$strm close} } -result {358 358} -test zlib-9.1 "check fcopy with push" -constraints zlib -setup { +test zlib-9.1 "check chan copy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] set file [makeFile {} test.gz] set f [open $sfile wb] @@ -376,14 +376,14 @@ test zlib-9.1 "check fcopy with push" -constraints zlib -setup { } -body { set fin [zlib push gunzip [open $sfile rb]] set fout [open $file wb] - set total [fcopy $fin $fout] + set total [chan copy $fin $fout] close $fin ; close $fout list copied $total size [file size $file] } -cleanup { removeFile $file removeFile $sfile } -result {copied 81920 size 81920} -test zlib-9.2 "socket fcopy with push" -constraints zlib -setup { +test zlib-9.2 "socket chan copy with push" -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { chan configure $c -translation binary -buffering none -blocking 0 puts -nonewline $c [zlib gzip [string repeat a 81920]] @@ -396,7 +396,7 @@ test zlib-9.2 "socket fcopy with push" -constraints zlib -setup { chan configure $sin -translation binary zlib push gunzip $sin update - set total [fcopy $sin [set fout [open $file wb]]] + set total [chan copy $sin [set fout [open $file wb]]] close $sin close $fout list read $total size [file size $file] @@ -404,7 +404,7 @@ test zlib-9.2 "socket fcopy with push" -constraints zlib -setup { close $srv removeFile $file } -result {read 81920 size 81920} -test zlib-9.3 "socket fcopy bg (identity)" -constraints {tempNotWin zlib} -setup { +test zlib-9.3 "socket chan copy bg (identity)" -constraints {tempNotWin zlib} -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { #puts "connection from $a:$p on $c" chan configure $c -translation binary -buffering none -blocking 0 @@ -420,7 +420,7 @@ test zlib-9.3 "socket fcopy bg (identity)" -constraints {tempNotWin zlib} -setup update set fout [open $file wb] after 1000 {set ::total timeout} - fcopy $sin $fout -command {apply {{c {e {}}} { + chan copy $sin $fout -command {apply {{c {e {}}} { set ::total [expr {$e eq {} ? $c : $e}] }}} vwait ::total @@ -431,7 +431,7 @@ test zlib-9.3 "socket fcopy bg (identity)" -constraints {tempNotWin zlib} -setup close $srv removeFile $file } -returnCodes {ok error} -result {read 81920 size 81920} -test zlib-9.4 "socket fcopy bg (gzip)" -constraints zlib -setup { +test zlib-9.4 "socket chan copy bg (gzip)" -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { chan configure $c -translation binary -buffering none -blocking 0 puts -nonewline $c [zlib gzip [string repeat a 81920]] @@ -446,7 +446,7 @@ test zlib-9.4 "socket fcopy bg (gzip)" -constraints zlib -setup { update set fout [open $file wb] after 1000 {set ::total timeout} - fcopy $sin $fout -command {apply {{c {e {}}} { + chan copy $sin $fout -command {apply {{c {e {}}} { set ::total [expr {$e eq {} ? $c : $e}] }}} vwait ::total @@ -457,7 +457,7 @@ test zlib-9.4 "socket fcopy bg (gzip)" -constraints zlib -setup { close $srv removeFile $file } -result {read 81920 size 81920} -test zlib-9.5 "socket fcopy incremental (gzip)" -constraints zlib -setup { +test zlib-9.5 "socket chan copy incremental (gzip)" -constraints zlib -setup { set srv [socket -myaddr localhost -server {apply {{c a p} { chan configure $c -translation binary -buffering none -blocking 0 puts -nonewline $c [zlib gzip [string repeat a 81920]] @@ -470,7 +470,7 @@ test zlib-9.5 "socket fcopy incremental (gzip)" -constraints zlib -setup { } elseif {[eof $i]} { set ::total [list eof $t] } else { - fcopy $i $o -size 8192 -command [list zlib95copy $i $o $t] + chan copy $i $o -size 8192 -command [list zlib95copy $i $o $t] } } set file [makeFile {} test.gz] @@ -482,7 +482,7 @@ test zlib-9.5 "socket fcopy incremental (gzip)" -constraints zlib -setup { update set fout [open $file wb] after 1000 {set ::total timeout} - fcopy $sin $fout -size 8192 -command [list zlib95copy $sin $fout 0] + chan copy $sin $fout -size 8192 -command [list zlib95copy $sin $fout 0] vwait ::total after cancel {set ::total timeout} close $sin; close $fout diff --git a/tools/checkLibraryDoc.tcl b/tools/checkLibraryDoc.tcl index 6d147ac..4af6eb9 100755 --- a/tools/checkLibraryDoc.tcl +++ b/tools/checkLibraryDoc.tcl @@ -139,17 +139,17 @@ proc compare {list1 list2} { # the results to the file. proc filter {code docs dir pkg {outFile stdout}} { - set apis {} + set apis [list] # A list of Tcl command APIs. These are not documented. # This list should just be verified for accuracy. - set cmds {} + set cmds [list] # A list of proc pointer structs. These are not documented. # This list should just be verified for accuracy. - set procs {} + set procs [list] # A list of internal declarations. These are not documented. # This list should just be verified for accuracy. @@ -161,23 +161,23 @@ proc filter {code docs dir pkg {outFile stdout}} { set misc [grepMisc $dir $pkg] - set pat1 ".*(${pkg}_\[A-z0-9]+).*$" + set pat1 ".*\(${pkg}_\[A-z0-9\]+\).*$" # A list of APIs in the source, not in the docs. # This list should just be verified for accuracy. foreach x $code { - if {[string match *Cmd $x]} { - if {[string match ${pkg}* $x]} { + if {[string match "*Cmd" $x]} { + if {[string match "${pkg}*" $x]} { lappend cmds $x } - } elseif {[string match *Proc $x]} { - if {[string match ${pkg}* $x]} { + } elseif {[string match "*Proc" $x]} { + if {[string match "${pkg}*" $x]} { lappend procs $x } - } elseif {[lsearch -exact $decls $x] >= 0} { + } elseif {$x in $decls} { # No Op. - } elseif {[lsearch -exact $misc $x] >= 0} { + } elseif {$x in $misc} { # No Op. } else { lappend apis $x @@ -211,7 +211,7 @@ proc dump {list title file} { proc grepCode {dir pkg} { set apis [myGrep "${pkg}_\.\*" "${dir}/\*/\*\.\[ch\]"] - set pat1 ".*(${pkg}_\[A-z0-9]+).*$" + set pat1 ".*\(${pkg}_\[A-z0-9\]+\).*$" foreach a $apis { if {[regexp -- $pat1 $a main n1]} { @@ -226,7 +226,7 @@ proc grepCode {dir pkg} { proc grepDocs {dir pkg} { set apis [myGrep "\\fB${pkg}_\.\*\\fR" "${dir}/doc/\*\.3"] - set pat1 ".*(${pkg}_\[A-z0-9]+)\\\\fR.*$" + set pat1 ".*\(${pkg}_\[A-z0-9\]+\)\\\\fR.*$" foreach a $apis { if {[regexp -- $pat1 $a main n1]} { @@ -242,7 +242,7 @@ proc grepDocs {dir pkg} { proc grepDecl {dir pkg} { set file [file join $dir generic "[string tolower $pkg]IntDecls.h"] set apis [myGrep "^EXTERN.*\[ \t\]${pkg}_.*" $file] - set pat1 ".*(${pkg}_\[A-z0-9]+).*$" + set pat1 ".*\(${pkg}_\[A-z0-9\]+\).*$" foreach a $apis { if {[regexp -- $pat1 $a main n1]} { @@ -260,7 +260,7 @@ proc grepMisc {dir pkg} { global StructList set apis [myGrep "^EXTERN.*\[ \t\]${pkg}_Db.*" "${dir}/\*/\*\.\[ch\]"] - set pat1 ".*(${pkg}_\[A-z0-9]+).*$" + set pat1 ".*\(${pkg}_\[A-z0-9\]+\).*$" foreach a $apis { if {[regexp -- $pat1 $a main n1]} { @@ -268,7 +268,8 @@ proc grepMisc {dir pkg} { } } - set result {} + set result [list] + # Question: Use {*} instead of eval ? eval {lappend result} $StructList eval {lappend result} [lsort [array names dbg]] eval {lappend result} $CommentList @@ -276,11 +277,11 @@ proc grepMisc {dir pkg} { } proc myGrep {searchPat globPat} { - set result {} - foreach file [glob -nocomplain $globPat] { + set result [list] + foreach file [glob -nocomplain -- $globPat] { set file [open $file r] - set data [read $file] - close $file + set data [chan read $file] + chan close $file foreach line [split $data "\n"] { if {[regexp "^.*${searchPat}.*\$" $line]} { lappend result $line diff --git a/tools/eolFix.tcl b/tools/eolFix.tcl index 3f35ed4..4d5d955 100644 --- a/tools/eolFix.tcl +++ b/tools/eolFix.tcl @@ -13,7 +13,7 @@ namespace eval ::EOL { variable outMode crlf } -proc EOL::fix {filename {newfilename {}}} { +proc EOL::fix {filename {newfilename ""}} { variable outMode if {![file exists $filename]} { @@ -21,23 +21,23 @@ proc EOL::fix {filename {newfilename {}}} { } puts "EOL Fixing: $filename" - file rename ${filename} ${filename}.o - set fhnd [open ${filename}.o r] + file rename -- $filename $filename.o + set fhnd [open $filename.o r] if {$newfilename ne ""} { - set newfhnd [open ${newfilename} w] + set newfhnd [open $newfilename w] } else { - set newfhnd [open ${filename} w] + set newfhnd [open $filename w] } - fconfigure $newfhnd -translation [list auto $outMode] + chan configure $newfhnd -translation [list auto $outMode] seek $fhnd 0 end - set theEnd [tell $fhnd] - seek $fhnd 0 start + set theEnd [chan tell $fhnd] + chan seek $fhnd 0 start - fconfigure $fhnd -translation binary -buffersize $theEnd - set rawFile [read $fhnd $theEnd] - close $fhnd + chan configure $fhnd -translation binary -buffersize $theEnd + set rawFile [chan read $fhnd $theEnd] + chan close $fhnd regsub -all {(\r)|(\r){1,2}(\n)} $rawFile "\n" rawFile @@ -47,12 +47,12 @@ proc EOL::fix {filename {newfilename {}}} { puts $newfhnd $line } - close $newfhnd - file delete ${filename}.o + chan close $newfhnd + file delete -- ${filename}.o } proc EOL::fixall {args} { - if {[llength $args] == 0} { + if {![llength $args]} { puts stderr "no files to fix" exit 1 } else { @@ -64,13 +64,16 @@ proc EOL::fixall {args} { } } -if {$tcl_interactive == 0 && $argc > 0} { +if {($tcl_interactive == 0) && ($argc > 0)} { if {[string index [lindex $argv 0] 0] eq "-"} { switch -- [lindex $argv 0] { -cr {set ::EOL::outMode cr} -crlf {set ::EOL::outMode crlf} -lf {set ::EOL::outMode lf} - default {puts stderr "improper mode switch"; exit 1} + default { + puts stderr "improper mode switch" + exit 1 + } } set argv [lrange $argv 1 end] } diff --git a/tools/findBadExternals.tcl b/tools/findBadExternals.tcl index 7592f17..fdcbb76 100755 --- a/tools/findBadExternals.tcl +++ b/tools/findBadExternals.tcl @@ -17,6 +17,8 @@ #---------------------------------------------------------------------- proc main {argc argv} { + global errorCode + global tcl_platform if {$argc != 1} { puts stderr "syntax is: [info script] libtcl" @@ -24,7 +26,7 @@ proc main {argc argv} { } - switch -exact -- $::tcl_platform(platform) { + switch -exact -- $tcl_platform(platform) { unix - macosx { set status [catch { @@ -36,8 +38,9 @@ proc main {argc argv} { exec dumpbin /exports [lindex $argv 0] } result] } + default {} } - if {$status != 0 && $::errorCode ne "NONE"} { + if {($status != 0) && ($errorCode ne "NONE")} { puts $result return 1 } diff --git a/tools/fix_tommath_h.tcl b/tools/fix_tommath_h.tcl index 04bf857..b6cbe95 100755 --- a/tools/fix_tommath_h.tcl +++ b/tools/fix_tommath_h.tcl @@ -10,18 +10,18 @@ #---------------------------------------------------------------------- set f [open [lindex $argv 0] r] -set data [read $f] -close $f +set data [chan read $f] +chan close $f set eat_endif 0 set eat_semi 0 set def_count 0 foreach line [split $data \n] { - if {!$eat_semi && !$eat_endif} { + if {(!$eat_semi) && (!$eat_endif)} { switch -regexp -- $line { - {#define BN_H_} { + "#define BN_H_" { puts $line - puts {} + puts "" puts "\#include \"tclInt.h\"" puts "\#include \"tclTomMathDecls.h\"" puts "\#ifndef MODULE_SCOPE" @@ -64,7 +64,7 @@ foreach line [split $data \n] { } {^extern (int|const)} { puts "\#if defined(BUILD_tcl) || !defined(_WIN32)" - puts [regsub {^extern} $line "MODULE_SCOPE"] + puts [regsub "^extern" $line "MODULE_SCOPE"] set eat_semi 1 set after_semi "\#endif" } @@ -94,8 +94,8 @@ foreach line [split $data \n] { } } if {$eat_endif} { - if {[regexp {^\#endif} $line]} { - puts "\#endif" + if {[string match "#endif*" $line]} { + puts "#endif" set eat_endif 0 } } diff --git a/tools/genStubs.tcl b/tools/genStubs.tcl index 93e0a9a..e9a0a08 100644 --- a/tools/genStubs.tcl +++ b/tools/genStubs.tcl @@ -46,7 +46,7 @@ namespace eval genStubs { # (@@@TODO: should be an array mapping interface names -> numbers) # - variable epoch {} + variable epoch "" variable revision 0 # hooks -- @@ -106,7 +106,7 @@ proc genStubs::interface {name} { variable curName $name variable interfaces - set interfaces($name) {} + set interfaces($name) "" return } @@ -196,8 +196,8 @@ proc genStubs::declare {args} { foreach platform $platformList { if {$decl ne ""} { set stubs($curName,$platform,$index) $decl - if {![info exists stubs($curName,$platform,lastNum)] \ - || ($index > $stubs($curName,$platform,lastNum))} { + if {(![info exists stubs($curName,$platform,lastNum)]) || + ($index > $stubs($curName,$platform,lastNum))} { set stubs($curName,$platform,lastNum) $index } } @@ -244,7 +244,7 @@ proc genStubs::rewriteFile {file text} { } set in [open ${file} r] set out [open ${file}.new w] - fconfigure $out -translation lf + chan configure $out -translation lf while {![eof $in]} { set line [gets $in] @@ -255,17 +255,17 @@ proc genStubs::rewriteFile {file text} { } puts $out "/* !BEGIN!: Do not edit below this line. */" puts $out $text - while {![eof $in]} { - set line [gets $in] + while {![chan eof $in]} { + set line [chan gets $in] if {[string match "*!END!*" $line]} { break } } - puts $out "/* !END!: Do not edit above this line. */" - puts -nonewline $out [read $in] - close $in - close $out - file rename -force ${file}.new ${file} + chan puts $out "/* !END!: Do not edit above this line. */" + chan puts -nonewline $out [read $in] + chan close $in + chan close $out + file rename -force -- ${file}.new ${file} return } @@ -281,7 +281,7 @@ proc genStubs::rewriteFile {file text} { proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} { set text "" - switch $plat { + switch -- $plat { win { append text "#if defined(__WIN32__)" if {$withCygwin} { @@ -320,11 +320,11 @@ proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} { append text "#endif /* AQUA */\n" } x11 { - append text "#if !(defined(__WIN32__)" + append text "#if !\(defined(__WIN32__)" if {$withCygwin} { append text " || defined(__CYGWIN__)" } - append text " || defined(MAC_OSX_TK))\ + append text " || defined(MAC_OSX_TK)\)\ /* X11 */\n${iftxt}" if {$eltxt ne ""} { append text "#else /* X11 */\n${eltxt}" @@ -352,7 +352,7 @@ proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} { # None. proc genStubs::emitSlots {name textVar} { - upvar $textVar text + upvar 1 $textVar text forAllStubs $name makeSlot 1 text {" void (*reserved$i)(void);\n"} return @@ -374,7 +374,7 @@ proc genStubs::emitSlots {name textVar} { proc genStubs::parseDecl {decl} { if {![regexp {^(.*)\((.*)\)$} $decl all prefix args]} { set prefix $decl - set args {} + set args [list] } set prefix [string trim $prefix] if {![regexp {^(.+[ ][*]*)([^ *]+)$} $prefix all rtype fname]} { @@ -383,7 +383,7 @@ proc genStubs::parseDecl {decl} { } set rtype [string trim $rtype] if {$args eq ""} { - return [list $rtype $fname {}] + return [list $rtype $fname ""] } foreach arg [split $args ,] { lappend argList [string trim $arg] @@ -392,7 +392,7 @@ proc genStubs::parseDecl {decl} { set args TCL_VARARGS foreach arg [lrange $argList 0 end-1] { set argInfo [parseArg $arg] - if {[llength $argInfo] == 2 || [llength $argInfo] == 3} { + if {([llength $argInfo] == 2) || ([llength $argInfo] == 3)} { lappend args $argInfo } else { puts stderr "Bad argument: '$arg' in '$decl'" @@ -400,13 +400,13 @@ proc genStubs::parseDecl {decl} { } } } else { - set args {} + set args [list] foreach arg $argList { set argInfo [parseArg $arg] if {![string compare $argInfo "void"]} { lappend args "void" break - } elseif {[llength $argInfo] == 2 || [llength $argInfo] == 3} { + } elseif {([llength $argInfo] == 2) || ([llength $argInfo] == 3)} { lappend args $argInfo } else { puts stderr "Bad argument: '$arg' in '$decl'" @@ -477,22 +477,21 @@ proc genStubs::makeDecl {name decl index} { append line $fname set arg1 [lindex $args 0] - switch -exact $arg1 { + switch -exact -- $arg1 { void { append line "(void)" } TCL_VARARGS { - set sep "(" + set sep "\(" foreach arg [lrange $args 1 end] { append line $sep - set next {} + set next "" append next [lindex $arg 0] if {[string index $next end] ne "*"} { append next " " } append next [lindex $arg 1] [lindex $arg 2] - if {[string length $line] + [string length $next] \ - + $pad > 76} { + if {([string length $line] + [string length $next] + $pad) > 76} { append text [string trimright $line] \n set line "\t\t\t\t" set pad 28 @@ -500,23 +499,22 @@ proc genStubs::makeDecl {name decl index} { append line $next set sep ", " } - append line ", ...)" + append line ", ...\)" if {[lindex $args end] eq "{const char *} format"} { - append line " TCL_FORMAT_PRINTF(" [expr [llength $args] - 1] ", " [llength $args] ")" + append line " TCL_FORMAT_PRINTF\(" [expr {[llength $args] - 1}] ", " [llength $args] "\)" } } default { - set sep "(" + set sep "\(" foreach arg $args { append line $sep - set next {} + set next "" append next [lindex $arg 0] if {[string index $next end] ne "*"} { append next " " } append next [lindex $arg 1] [lindex $arg 2] - if {[string length $line] + [string length $next] \ - + $pad > 76} { + if {([string length $line] + [string length $next] + $pad) > 76} { append text [string trimright $line] \n set line "\t\t\t\t" set pad 28 @@ -524,7 +522,7 @@ proc genStubs::makeDecl {name decl index} { append line $next set sep ", " } - append line ")" + append line "\)" } } return "$text$line;\n" @@ -548,11 +546,11 @@ proc genStubs::makeMacro {name decl index} { set lfname [string tolower [string index $fname 0]] append lfname [string range $fname 1 end] - set text "#define $fname \\\n\t(" + set text "#define $fname \\\n\t\(" if {$args eq ""} { append text "*" } - append text "${name}StubsPtr->$lfname)" + append text "${name}StubsPtr->$lfname\)" append text " /* $index */\n" return $text } @@ -581,17 +579,17 @@ proc genStubs::makeSlot {name decl index} { return $text } if {[string range $rtype end-8 end] eq "__stdcall"} { - append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") " + append text [string trim [string range $rtype 0 end-9]] " \(__stdcall *" $lfname "\) " } else { - append text $rtype " (*" $lfname ") " + append text $rtype " \(*" $lfname "\) " } set arg1 [lindex $args 0] - switch -exact $arg1 { + switch -exact -- $arg1 { void { append text "(void)" } TCL_VARARGS { - set sep "(" + set sep "\(" foreach arg [lrange $args 1 end] { append text $sep [lindex $arg 0] if {[string index $text end] ne "*"} { @@ -600,13 +598,13 @@ proc genStubs::makeSlot {name decl index} { append text [lindex $arg 1] [lindex $arg 2] set sep ", " } - append text ", ...)" + append text ", ...\)" if {[lindex $args end] eq "{const char *} format"} { - append text " TCL_FORMAT_PRINTF(" [expr [llength $args] - 1] ", " [llength $args] ")" + append text " TCL_FORMAT_PRINTF\(" [expr {[llength $args] - 1}] ", " [llength $args] "\)" } } default { - set sep "(" + set sep "\(" foreach arg $args { append text $sep [lindex $arg 0] if {[string index $text end] ne "*"} { @@ -615,7 +613,7 @@ proc genStubs::makeSlot {name decl index} { append text [lindex $arg 1] [lindex $arg 2] set sep ", " } - append text ")" + append text "\)" } } @@ -668,7 +666,7 @@ proc genStubs::makeInit {name decl index} { proc genStubs::forAllStubs {name slotProc onAll textVar {skipString {"/* Slot $i is reserved */\n"}}} { variable stubs - upvar $textVar text + upvar 1 $textVar text set plats [array names stubs $name,*,lastNum] if {[info exists stubs($name,generic,lastNum)]} { @@ -698,18 +696,19 @@ proc genStubs::forAllStubs {name slotProc onAll textVar # "macosx" implies "unix", "aqua" implies "macosx" and "x11" # implies "unix", so we need to be careful not to emit # duplicate stubs entries: - if {($slot(unix) && $slot(macosx)) || ( - ($slot(unix) || $slot(macosx)) && - ($slot(x11) || $slot(aqua)))} { + if {($slot(unix) && $slot(macosx)) || + (($slot(unix) || $slot(macosx)) && + ($slot(x11) || $slot(aqua)))} { puts stderr "conflicting platform entries: $name $i" } ## unix ## - set temp {} + set temp "" set plat unix - if {!$slot(aqua) && !$slot(x11)} { + if {(!$slot(aqua)) && (!$slot(x11))} { if {$slot($plat)} { append temp [$slotProc $name $stubs($name,$plat,$i) $i] } elseif {$onAll} { + # Question: Use {*} instead of eval ? eval {append temp} $skipString } } @@ -718,12 +717,13 @@ proc genStubs::forAllStubs {name slotProc onAll textVar set emit 1 } ## x11 ## - set temp {} + set temp "" set plat x11 - if {!$slot(unix) && !$slot(macosx)} { + if {(!$slot(unix)) && (!$slot(macosx))} { if {$slot($plat)} { append temp [$slotProc $name $stubs($name,$plat,$i) $i] } elseif {$onAll} { + # Question: Use {*} instead of eval ? eval {append temp} $skipString } } @@ -732,11 +732,12 @@ proc genStubs::forAllStubs {name slotProc onAll textVar set emit 1 } ## win ## - set temp {} + set temp "" set plat win if {$slot($plat)} { append temp [$slotProc $name $stubs($name,$plat,$i) $i] } elseif {$onAll} { + # Question: Use {*} instead of eval ? eval {append temp} $skipString } if {$temp ne ""} { @@ -744,14 +745,15 @@ proc genStubs::forAllStubs {name slotProc onAll textVar set emit 1 } ## macosx ## - set temp {} + set temp "" set plat macosx - if {!$slot(aqua) && !$slot(x11)} { + if {(!$slot(aqua)) && (!$slot(x11))} { if {$slot($plat)} { append temp [$slotProc $name $stubs($name,$plat,$i) $i] } elseif {$slot(unix)} { append temp [$slotProc $name $stubs($name,unix,$i) $i] } elseif {$onAll} { + # Question: Use {*} instead of eval ? eval {append temp} $skipString } } @@ -760,9 +762,9 @@ proc genStubs::forAllStubs {name slotProc onAll textVar set emit 1 } ## aqua ## - set temp {} + set temp "" set plat aqua - if {!$slot(unix) && !$slot(macosx)} { + if {(!$slot(unix)) && (!$slot(macosx))} { if {[string range $skipString 1 2] ne "/*"} { # genStubs.tcl previously had a bug here causing it to # erroneously generate both a unix entry and an aqua @@ -773,6 +775,8 @@ proc genStubs::forAllStubs {name slotProc onAll textVar # actual position of the entry in the stubs table, e.g. # TkIntStubs entry 113 for aqua is in fact at position # 114 in the table, entry 114 at position 116 etc). + + # Question: Use {*} instead of eval ? eval {append temp} $skipString set temp "[string range $temp 0 end-1] /*\ Dummy entry for stubs table backwards\ @@ -781,6 +785,7 @@ proc genStubs::forAllStubs {name slotProc onAll textVar if {$slot($plat)} { append temp [$slotProc $name $stubs($name,$plat,$i) $i] } elseif {$onAll} { + # Question: Use {*} instead of eval ? eval {append temp} $skipString } } @@ -790,6 +795,7 @@ proc genStubs::forAllStubs {name slotProc onAll textVar } } if {!$emit} { + # Question: Use {*} instead of eval ? eval {append text} $skipString } } @@ -800,36 +806,38 @@ proc genStubs::forAllStubs {name slotProc onAll textVar set block([lindex [split $s ,] 1]) 1 } ## unix ## - if {$block(unix) && !$block(x11)} { - set temp {} + if {$block(unix) && (!$block(x11))} { + set temp "" set plat unix set lastNum $stubs($name,$plat,lastNum) for {set i 0} {$i <= $lastNum} {incr i} { if {[info exists stubs($name,$plat,$i)]} { append temp [$slotProc $name $stubs($name,$plat,$i) $i] } else { + # Question: Use {*} instead of eval ? eval {append temp} $skipString } } - append text [addPlatformGuard $plat $temp {} true] + append text [addPlatformGuard $plat $temp "" true] } ## win ## if {$block(win)} { - set temp {} + set temp "" set plat win set lastNum $stubs($name,$plat,lastNum) for {set i 0} {$i <= $lastNum} {incr i} { if {[info exists stubs($name,$plat,$i)]} { append temp [$slotProc $name $stubs($name,$plat,$i) $i] } else { + # Question: Use {*} instead of eval ? eval {append temp} $skipString } } - append text [addPlatformGuard $plat $temp {} true] + append text [addPlatformGuard $plat $temp "" true] } ## macosx ## - if {($block(unix) || $block(macosx)) && !$block(aqua) && !$block(x11)} { - set temp {} + if {($block(unix) || $block(macosx)) && (!$block(aqua)) && (!$block(x11))} { + set temp "" set lastNum -1 foreach plat {unix macosx} { if {$block($plat)} { @@ -847,6 +855,7 @@ proc genStubs::forAllStubs {name slotProc onAll textVar } } if {!$emit} { + # Question: Use {*} instead of eval ? eval {append temp} $skipString } } @@ -854,7 +863,7 @@ proc genStubs::forAllStubs {name slotProc onAll textVar } ## aqua ## if {$block(aqua)} { - set temp {} + set temp "" set lastNum -1 foreach plat {unix macosx aqua} { if {$block($plat)} { @@ -872,6 +881,7 @@ proc genStubs::forAllStubs {name slotProc onAll textVar } } if {!$emit} { + # Question: Use {*} instead of eval ? eval {append temp} $skipString } } @@ -879,7 +889,7 @@ proc genStubs::forAllStubs {name slotProc onAll textVar } ## x11 ## if {$block(x11)} { - set temp {} + set temp "" set lastNum -1 foreach plat {unix macosx x11} { if {$block($plat)} { @@ -895,6 +905,7 @@ proc genStubs::forAllStubs {name slotProc onAll textVar append temp [$slotProc $name \ $stubs($name,$plat,$i) $i] } else { + # Question: Use {*} instead of eval ? eval {set etxt} $skipString append temp [addPlatformGuard $plat [$slotProc \ $name $stubs($name,$plat,$i) $i] $etxt true] @@ -904,10 +915,11 @@ proc genStubs::forAllStubs {name slotProc onAll textVar } } if {!$emit} { + # Question: Use {*} instead of eval ? eval {append temp} $skipString } } - append text [addPlatformGuard x11 $temp {} true] + append text [addPlatformGuard x11 $temp "" true] } } } @@ -924,7 +936,7 @@ proc genStubs::forAllStubs {name slotProc onAll textVar # None. proc genStubs::emitDeclarations {name textVar} { - upvar $textVar text + upvar 1 $textVar text append text "\n/*\n * Exported function declarations:\n */\n\n" forAllStubs $name makeDecl 0 text @@ -944,7 +956,7 @@ proc genStubs::emitDeclarations {name textVar} { proc genStubs::emitMacros {name textVar} { variable libraryName - upvar $textVar text + upvar 1 $textVar text set upName [string toupper $libraryName] append text "\n#if defined(USE_${upName}_STUBS)\n" @@ -986,15 +998,15 @@ proc genStubs::emitHeader {name} { emitDeclarations $name text if {[info exists hooks($name)]} { - append text "\ntypedef struct {\n" + append text "\ntypedef struct \{\n" foreach hook $hooks($name) { set capHook [string toupper [string index $hook 0]] append capHook [string range $hook 1 end] append text " const struct ${capHook}Stubs *${hook}Stubs;\n" } - append text "} ${capName}StubHooks;\n" + append text "\} ${capName}StubHooks;\n" } - append text "\ntypedef struct ${capName}Stubs {\n" + append text "\ntypedef struct ${capName}Stubs \{\n" append text " int magic;\n" if {$epoch ne ""} { append text " int epoch;\n" @@ -1008,11 +1020,11 @@ proc genStubs::emitHeader {name} { emitSlots $name text - append text "} ${capName}Stubs;\n\n" + append text "\} ${capName}Stubs;\n\n" - append text "#ifdef __cplusplus\nextern \"C\" {\n#endif\n" + append text "#ifdef __cplusplus\nextern \"C\" \{\n#endif\n" append text "extern const ${capName}Stubs *${name}StubsPtr;\n" - append text "#ifdef __cplusplus\n}\n#endif\n" + append text "#ifdef __cplusplus\n\}\n#endif\n" emitMacros $name text @@ -1035,7 +1047,7 @@ proc genStubs::emitInit {name textVar} { variable hooks variable interfaces variable epoch - upvar $textVar text + upvar 1 $textVar text set root 1 set capName [string toupper [string index $name 0]] @@ -1101,8 +1113,9 @@ proc genStubs::emitInits {} { # Assuming that dependencies only go one level deep, we need to emit # all of the leaves first to avoid needing forward declarations. - set leaves {} - set roots {} + set leaves [list] + set roots [list] + set text "" foreach name [lsort [array names interfaces]] { if {[info exists hooks($name)]} { lappend roots $name @@ -1165,14 +1178,14 @@ proc genStubs::init {} { # Results: # Returns any values that were not assigned to variables. -if {[string length [namespace which lassign]] == 0} { +if {[namespace which lassign] eq ""} { proc lassign {valueList args} { - if {[llength $args] == 0} { + if {![llength $args]} { error "wrong # args: should be \"lassign list varName ?varName ...?\"" } - uplevel [list foreach $args $valueList {break}] + uplevel 1 [list foreach $args $valueList {break}] return [lrange $valueList [llength $args] end] } } -genStubs::init +genStubs::init diff --git a/tools/index.tcl b/tools/index.tcl index 71329c2..8f4a724 100644 --- a/tools/index.tcl +++ b/tools/index.tcl @@ -37,7 +37,7 @@ proc getPackages {} { global topics foreach i [array names topics] { regsub {^(.*),.*,.*$} $i {\1} i - set temp($i) {} + set temp($i) "" } lsort [array names temp] } @@ -55,7 +55,7 @@ proc getSections {pkg} { regsub -all {[][*?\\]} $pkg {\\&} pkg foreach i [array names topics "${pkg},*"] { regsub {^.*,(.*),.*$} $i {\1} i - set temp($i) {} + set temp($i) "" } lsort [array names temp] } @@ -75,7 +75,7 @@ proc getTopics {pkg sect} { regsub -all {[][*?\\]} $sect {\\&} sect foreach i [array names topics "${pkg},${sect},*"] { regsub {^.*,.*,(.*)$} $i {\1} i - set temp($i) {} + set temp($i) "" } lsort [array names temp] } @@ -88,16 +88,16 @@ proc getTopics {pkg sect} { # string - Text to index. -proc text string { +proc text {string} { global state curID curPkg curSect topics keywords - switch $state { + switch -- $state { NAME { foreach i [split $string ","] { set topic [string trim $i] set index "$curPkg,$curSect,$topic" if {[info exists topics($index)] - && [string compare $topics($index) $curID] != 0} { + && ($topics($index) ne $curID)} { puts stderr "duplicate topic $topic in $curPkg" } set topics($index) $curID @@ -129,11 +129,11 @@ proc text string { # args - Any additional arguments to the macro. proc macro {name args} { - switch $name { + switch -- $name { SH - SS { global state - switch $args { + switch -- $args { NAME { if {$state eq "INIT" } { set state NAME @@ -157,11 +157,12 @@ proc macro {name args} { set topic [lindex $args 0] ;# Tcl_UpVar set curPkg [lindex $args 3] ;# Tcl set curSect [lindex $args 4] ;# {Tcl Library Procedures} - regsub -all {\\ } $curSect { } curSect + regsub -all {\\ } $curSect " " curSect set index "$curPkg,$curSect,$topic" set topics($index) $curID lappend keywords($topic) $curID } + default {} } } @@ -193,7 +194,7 @@ proc dash {} { proc initGlobals {} {} proc newline {} {} proc tab {} {} -proc font type {} -proc char name {} +proc font {type} {} +proc char {name} {} proc macro2 {name args} {} diff --git a/tools/installData.tcl b/tools/installData.tcl index 4b43f1e..04f46b0 100644 --- a/tools/installData.tcl +++ b/tools/installData.tcl @@ -19,7 +19,7 @@ exec tclsh "$0" ${1+"$@"} proc copyDir {d1 d2} { - puts [format {%*sCreating %s} [expr {4 * [info level]}] {} \ + puts [format "%*sCreating %s" [expr {4 * [info level]}] "" \ [file tail $d2]] file delete -force -- $d2 @@ -30,7 +30,7 @@ proc copyDir {d1 d2} { if {[file isdirectory $f] && [string compare CVS $ftail]} { copyDir $f [file join $d2 $ftail] } elseif {[file isfile $f]} { - file copy -force $f [file join $d2 $ftail] + file copy -force -- $f [file join $d2 $ftail] if {$::tcl_platform(platform) eq {unix}} { file attributes [file join $d2 $ftail] -permissions 0644 } else { diff --git a/tools/loadICU.tcl b/tools/loadICU.tcl index 5b09e2c..76eb75b 100755 --- a/tools/loadICU.tcl +++ b/tools/loadICU.tcl @@ -29,12 +29,12 @@ # Calculate the Chinese numerals from zero to ninety-nine. -set zhDigits [list {} \u4e00 \u4e8c \u4e09 \u56db \ +set zhDigits [list "" \u4e00 \u4e8c \u4e09 \u56db \ \u4e94 \u516d \u4e03 \u516b \u4e5d] set t 0 foreach zt $zhDigits { if { $t == 0 } { - set zt {} + set zt "" } elseif { $t == 10 } { set zt \u5341 } else { @@ -42,11 +42,11 @@ foreach zt $zhDigits { } set d 0 foreach zd $zhDigits { - if { $t == 0 && $d == 0 } { + if { ($t == 0) && ($d == 0) } { set zd \u3007 - } elseif { $t == 20 && $d != 0 } { + } elseif { ($t == 20) && ($d != 0) } { set zt \u5eff - } elseif { $t == 30 && $d != 0 } { + } elseif { ($t == 30) && ($d != 0) } { set zt \u5345 } lappend zhNumbers $zt$zd @@ -73,185 +73,185 @@ set format(ko,LOCALE_TIME_FORMAT) "%H\uc2dc%M\ubd84%S\ucd08" set format(zh,LOCALE_DATE_TIME_FORMAT) "%A %Y\u5e74%B%Od\u65E5%OH\u65f6%OM\u5206%OS\u79d2 %z" set format(ja,LOCALE_DATE_TIME_FORMAT) "%EY\u5e74%m\u6708%d\u65E5 (%a) %H\u6642%M\u5206%S\u79d2 %z" set format(ko,LOCALE_DATE_TIME_FORMAT) "%A %Y\ub144%B%Od\uc77c%H\uc2dc%M\ubd84%S\ucd08 %z" -set format(ja,TIME_FORMAT_12) {%P %I:%M:%S} +set format(ja,TIME_FORMAT_12) "%P %I:%M:%S" # The next set of format overrides were obtained from the glibc # localization strings. -set format(cs_CZ,DATE_FORMAT) %d.%m.%Y -set format(cs_CZ,DATE_TIME_FORMAT) {%a %e. %B %Y, %H:%M:%S %z} -set format(cs_CZ,TIME_FORMAT) %H:%M:%S -set format(cs_CZ,TIME_FORMAT_12) %I:%M:%S -set format(da_DK,DATE_FORMAT) %d-%m-%Y -set format(da_DK,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} -set format(da_DK,TIME_FORMAT) %T -set format(da_DK,TIME_FORMAT_12) %T -set format(de_AT,DATE_FORMAT) %Y-%m-%d -set format(de_AT,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} -set format(de_AT,TIME_FORMAT) %T -set format(de_AT,TIME_FORMAT_12) %T -set format(de_BE,DATE_FORMAT) %Y-%m-%d -set format(de_BE,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} -set format(de_BE,TIME_FORMAT) %T -set format(de_BE,TIME_FORMAT_12) %T -set format(de_CH,DATE_FORMAT) %Y-%m-%d -set format(de_CH,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} -set format(de_CH,TIME_FORMAT) %T -set format(de_CH,TIME_FORMAT_12) %T -set format(de_DE,DATE_FORMAT) %Y-%m-%d -set format(de_DE,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} -set format(de_DE,TIME_FORMAT) %T -set format(de_DE,TIME_FORMAT_12) %T -set format(de_LU,DATE_FORMAT) %Y-%m-%d -set format(de_LU,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} -set format(de_LU,TIME_FORMAT) %T -set format(de_LU,TIME_FORMAT_12) %T -set format(en_CA,DATE_FORMAT) %d/%m/%y -set format(en_CA,DATE_TIME_FORMAT) {%a %d %b %Y %r %z} -set format(en_CA,TIME_FORMAT) %r -set format(en_CA,TIME_FORMAT_12) {%I:%M:%S %p} -set format(en_DK,DATE_FORMAT) %Y-%m-%d -set format(en_DK,DATE_TIME_FORMAT) {%Y-%m-%dT%T %z} -set format(en_DK,TIME_FORMAT) %T +set format(cs_CZ,DATE_FORMAT) "%d.%m.%Y" +set format(cs_CZ,DATE_TIME_FORMAT) "%a %e. %B %Y, %H:%M:%S %z" +set format(cs_CZ,TIME_FORMAT) "%H:%M:%S" +set format(cs_CZ,TIME_FORMAT_12) "%I:%M:%S" +set format(da_DK,DATE_FORMAT) "%d-%m-%Y" +set format(da_DK,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" +set format(da_DK,TIME_FORMAT) "%T" +set format(da_DK,TIME_FORMAT_12) "%T" +set format(de_AT,DATE_FORMAT) "%Y-%m-%d" +set format(de_AT,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" +set format(de_AT,TIME_FORMAT) "%T" +set format(de_AT,TIME_FORMAT_12) "%T" +set format(de_BE,DATE_FORMAT) "%Y-%m-%d" +set format(de_BE,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" +set format(de_BE,TIME_FORMAT) "%T" +set format(de_BE,TIME_FORMAT_12) "%T" +set format(de_CH,DATE_FORMAT) "%Y-%m-%d" +set format(de_CH,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" +set format(de_CH,TIME_FORMAT) "%T" +set format(de_CH,TIME_FORMAT_12) "%T" +set format(de_DE,DATE_FORMAT) "%Y-%m-%d" +set format(de_DE,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" +set format(de_DE,TIME_FORMAT) "%T" +set format(de_DE,TIME_FORMAT_12) "%T" +set format(de_LU,DATE_FORMAT) "%Y-%m-%d" +set format(de_LU,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" +set format(de_LU,TIME_FORMAT) "%T" +set format(de_LU,TIME_FORMAT_12) "%T" +set format(en_CA,DATE_FORMAT) "%d/%m/%y" +set format(en_CA,DATE_TIME_FORMAT) "%a %d %b %Y %r %z" +set format(en_CA,TIME_FORMAT) "%r" +set format(en_CA,TIME_FORMAT_12) "%I:%M:%S %p" +set format(en_DK,DATE_FORMAT) "%Y-%m-%d" +set format(en_DK,DATE_TIME_FORMAT) "%Y-%m-%dT%T %z" +set format(en_DK,TIME_FORMAT) "%T" set format(en_DK,TIME_FORMAT_12) %T set format(en_GB,DATE_FORMAT) %d/%m/%y -set format(en_GB,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(en_GB,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(en_GB,TIME_FORMAT) %T set format(en_GB,TIME_FORMAT_12) %T set format(en_IE,DATE_FORMAT) %d/%m/%y -set format(en_IE,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(en_IE,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(en_IE,TIME_FORMAT) %T set format(en_IE,TIME_FORMAT_12) %T set format(en_US,DATE_FORMAT) %m/%d/%y -set format(en_US,DATE_TIME_FORMAT) {%a %d %b %Y %r %z} +set format(en_US,DATE_TIME_FORMAT) "%a %d %b %Y %r %z" set format(en_US,TIME_FORMAT) %r -set format(en_US,TIME_FORMAT_12) {%I:%M:%S %p} +set format(en_US,TIME_FORMAT_12) "%I:%M:%S %p" set format(es_ES,DATE_FORMAT) %d/%m/%y -set format(es_ES,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} -set format(es_ES,TIME_FORMAT) %T -set format(es_ES,TIME_FORMAT_12) %T -set format(et_EE,DATE_FORMAT) %d.%m.%Y -set format(et_EE,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(es_ES,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" +set format(es_ES,TIME_FORMAT) "%T" +set format(es_ES,TIME_FORMAT_12) "%T" +set format(et_EE,DATE_FORMAT) "%d.%m.%Y" +set format(et_EE,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(et_EE,TIME_FORMAT) %T set format(et_EE,TIME_FORMAT_12) %T -set format(eu_ES,DATE_FORMAT) {%a, %Yeko %bren %da} -set format(eu_ES,DATE_TIME_FORMAT) {%y-%m-%d %T %z} +set format(eu_ES,DATE_FORMAT) "%a, %Yeko %bren %da" +set format(eu_ES,DATE_TIME_FORMAT) "%y-%m-%d %T %z" set format(eu_ES,TIME_FORMAT) %T set format(eu_ES,TIME_FORMAT_12) %T set format(fi_FI,DATE_FORMAT) %d.%m.%Y -set format(fi_FI,DATE_TIME_FORMAT) {%a %e %B %Y %T} +set format(fi_FI,DATE_TIME_FORMAT) "%a %e %B %Y %T" set format(fi_FI,TIME_FORMAT) %T set format(fi_FI,TIME_FORMAT_12) %T set format(fo_FO,DATE_FORMAT) %d/%m-%Y -set format(fo_FO,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(fo_FO,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(fo_FO,TIME_FORMAT) %T set format(fo_FO,TIME_FORMAT_12) %T set format(fr_BE,DATE_FORMAT) %d/%m/%y -set format(fr_BE,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(fr_BE,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(fr_BE,TIME_FORMAT) %T set format(fr_BE,TIME_FORMAT_12) %T set format(fr_CA,DATE_FORMAT) %Y-%m-%d -set format(fr_CA,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(fr_CA,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(fr_CA,TIME_FORMAT) %T set format(fr_CA,TIME_FORMAT_12) %T -set format(fr_CH,DATE_FORMAT) {%d. %m. %y} -set format(fr_CH,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(fr_CH,DATE_FORMAT) "%d. %m. %y" +set format(fr_CH,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(fr_CH,TIME_FORMAT) %T set format(fr_CH,TIME_FORMAT_12) %T set format(fr_FR,DATE_FORMAT) %d.%m.%Y -set format(fr_FR,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(fr_FR,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(fr_FR,TIME_FORMAT) %T set format(fr_FR,TIME_FORMAT_12) %T set format(fr_LU,DATE_FORMAT) %d.%m.%Y -set format(fr_LU,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(fr_LU,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(fr_LU,TIME_FORMAT) %T set format(fr_LU,TIME_FORMAT_12) %T set format(ga_IE,DATE_FORMAT) %d.%m.%y -set format(ga_IE,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(ga_IE,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(ga_IE,TIME_FORMAT) %T set format(ga_IE,TIME_FORMAT_12) %T set format(gr_GR,DATE_FORMAT) %d/%m/%Y -set format(gr_GR,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(gr_GR,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(gr_GR,TIME_FORMAT) %T set format(gr_GR,TIME_FORMAT_12) %T set format(hr_HR,DATE_FORMAT) %d.%m.%y -set format(hr_HR,DATE_TIME_FORMAT) {%a %d %b %Y %T} +set format(hr_HR,DATE_TIME_FORMAT) "%a %d %b %Y %T" set format(hr_HR,TIME_FORMAT) %T set format(hr_HR,TIME_FORMAT_12) %T set format(hu_HU,DATE_FORMAT) %Y-%m-%d -set format(hu_HU,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(hu_HU,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(hu_HU,TIME_FORMAT) %T set format(hu_HU,TIME_FORMAT_12) %T -set format(is_IS,DATE_FORMAT) {%a %e.%b %Y} -set format(is_IS,DATE_TIME_FORMAT) {%a %e.%b %Y, %T %z} +set format(is_IS,DATE_FORMAT) "%a %e.%b %Y" +set format(is_IS,DATE_TIME_FORMAT) "%a %e.%b %Y, %T %z" set format(is_IS,TIME_FORMAT) %T set format(is_IS,TIME_FORMAT_12) %T set format(it_IT,DATE_FORMAT) %d/%m/%Y -set format(it_IT,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(it_IT,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(it_IT,TIME_FORMAT) %T set format(it_IT,TIME_FORMAT_12) %T set format(iw_IL,DATE_FORMAT) %d/%m/%y -set format(iw_IL,DATE_TIME_FORMAT) {%z %H:%M:%S %Y %b %d %a} +set format(iw_IL,DATE_TIME_FORMAT) "%z %H:%M:%S %Y %b %d %a" set format(iw_IL,TIME_FORMAT) %H:%M:%S -set format(iw_IL,TIME_FORMAT_12) {%I:%M:%S %P} -set format(kl_GL,DATE_FORMAT) {%d %b %Y} -set format(kl_GL,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(iw_IL,TIME_FORMAT_12) "%I:%M:%S %P" +set format(kl_GL,DATE_FORMAT) "%d %b %Y" +set format(kl_GL,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(kl_GL,TIME_FORMAT) %T set format(kl_GL,TIME_FORMAT_12) %T set format(lt_LT,DATE_FORMAT) %Y.%m.%d -set format(lt_LT,DATE_TIME_FORMAT) {%Y m. %B %d d. %T} +set format(lt_LT,DATE_TIME_FORMAT) "%Y m. %B %d d. %T" set format(lt_LT,TIME_FORMAT) %T set format(lt_LT,TIME_FORMAT_12) %T set format(lv_LV,DATE_FORMAT) %Y.%m.%d. -set format(lv_LV,DATE_TIME_FORMAT) {%A, %Y. gada %e. %B, plkst. %H un %M} +set format(lv_LV,DATE_TIME_FORMAT) "%A, %Y. gada %e. %B, plkst. %H un %M" set format(lv_LV,TIME_FORMAT) %T set format(lv_LV,TIME_FORMAT_12) %T set format(nl_BE,DATE_FORMAT) %d-%m-%y -set format(nl_BE,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(nl_BE,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(nl_BE,TIME_FORMAT) %T set format(nl_BE,TIME_FORMAT_12) %T set format(nl_NL,DATE_FORMAT) %d-%m-%y -set format(nl_NL,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(nl_NL,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(nl_NL,TIME_FORMAT) %T set format(nl_NL,TIME_FORMAT_12) %T set format(no_NO,DATE_FORMAT) %d-%m-%Y -set format(no_NO,DATE_TIME_FORMAT) {%a %d-%m-%Y %T %z} +set format(no_NO,DATE_TIME_FORMAT) "%a %d-%m-%Y %T %z" set format(no_NO,TIME_FORMAT) %T set format(no_NO,TIME_FORMAT_12) %T set format(pl_PL,DATE_FORMAT) %Y-%m-%d -set format(pl_PL,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(pl_PL,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(pl_PL,TIME_FORMAT) %T set format(pl_PL,TIME_FORMAT_12) %T set format(pt_BR,DATE_FORMAT) %d-%m-%Y -set format(pt_BR,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(pt_BR,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(pt_BR,TIME_FORMAT) %T set format(pt_BR,TIME_FORMAT_12) %T set format(pt_PT,DATE_FORMAT) %d-%m-%Y -set format(pt_PT,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(pt_PT,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(pt_PT,TIME_FORMAT) %T set format(pt_PT,TIME_FORMAT_12) %T set format(ro_RO,DATE_FORMAT) %Y-%m-%d -set format(ro_RO,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(ro_RO,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(ro_RO,TIME_FORMAT) %T set format(ro_RO,TIME_FORMAT_12) %T set format(ru_RU,DATE_FORMAT) %d.%m.%Y -set format(ru_RU,DATE_TIME_FORMAT) {%a %d %b %Y %T} +set format(ru_RU,DATE_TIME_FORMAT) "%a %d %b %Y %T" set format(ru_RU,TIME_FORMAT) %T set format(ru_RU,TIME_FORMAT_12) %T set format(sl_SI,DATE_FORMAT) %d.%m.%Y -set format(sl_SI,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(sl_SI,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(sl_SI,TIME_FORMAT) %T set format(sl_SI,TIME_FORMAT_12) %T set format(sv_FI,DATE_FORMAT) %Y-%m-%d -set format(sv_FI,DATE_TIME_FORMAT) {%a %e %b %Y %H.%M.%S} +set format(sv_FI,DATE_TIME_FORMAT) "%a %e %b %Y %H.%M.%S" set format(sv_FI,TIME_FORMAT) %H.%M.%S set format(sv_FI,TIME_FORMAT_12) %H.%M.%S set format(sv_SE,DATE_FORMAT) %Y-%m-%d -set format(sv_SE,DATE_TIME_FORMAT) {%a %e %b %Y %H.%M.%S} +set format(sv_SE,DATE_TIME_FORMAT) "%a %e %b %Y %H.%M.%S" set format(sv_SE,TIME_FORMAT) %H.%M.%S set format(sv_SE,TIME_FORMAT_12) %H.%M.%S set format(tr_TR,DATE_FORMAT) %Y-%m-%d -set format(tr_TR,DATE_TIME_FORMAT) {%a %d %b %Y %T %z} +set format(tr_TR,DATE_TIME_FORMAT) "%a %d %b %Y %T %z" set format(tr_TR,TIME_FORMAT) %T set format(tr_TR,TIME_FORMAT_12) %T @@ -276,20 +276,21 @@ set format(tr_TR,TIME_FORMAT_12) %T proc handleLocaleFile { localeName fileName msgFileName } { variable format + global argv0 # Get the content of the ICU file set f [open $fileName r] - fconfigure $f -encoding utf-8 - set data [read $f] - close $f + chan configure $f -encoding utf-8 + set data [chan read $f] + chan close $f # Parse the ICU data - set state {} + set state "" foreach line [split $data \n] { switch -exact -- $state { - {} { + "" { # Look for the beginnings of data blocks @@ -322,26 +323,28 @@ proc handleLocaleFile { localeName fileName msgFileName } { set state data set key MonthNames } + default {} } } data { - - # Inside a data block, collect the strings, doing backslash # expansion to pick up the Unicodes - if { [regexp {"(.*)",} $line -> item] } { + if { [regexp {"(.*)",} $line ___ item] } { lappend items($key) [subst -nocommands -novariables $item] } elseif { [regexp {^[[:space:]]*[\}][[:space:]]*$} $line] } { - set state {} + set state "" } } + default {} } } # Skip locales that don't change time strings. - if {![array exists items]} return + if {![array exists items]} { + return + } # Write the Tcl message catalog @@ -349,7 +352,7 @@ proc handleLocaleFile { localeName fileName msgFileName } { # Write a header - puts $f "\# created by $::argv0 -- do not edit" + puts $f "\# created by $argv0 -- do not edit" puts $f "namespace eval ::tcl::clock \{" # Do ordinary sets of strings (weekday and month names) @@ -375,7 +378,7 @@ proc handleLocaleFile { localeName fileName msgFileName } { # Do the eras, B.C.E., and C.E. if { [info exists items(Eras)] } { - foreach { bce ce } $items(Eras) break + lassign $items(Eras) bce ce set cmd " ::msgcat::mcset " append cmd $localeName " " BCE " \"" [backslashify $bce] \" puts $f $cmd @@ -387,7 +390,7 @@ proc handleLocaleFile { localeName fileName msgFileName } { # Do the AM and PM markers if { [info exists items(AmPmMarkers)] } { - foreach { am pm } $items(AmPmMarkers) break + lassign $items(AmPmMarkers) am pm set cmd " ::msgcat::mcset " append cmd $localeName " " AM " \"" [backslashify $am] \" puts $f $cmd @@ -441,7 +444,7 @@ proc handleLocaleFile { localeName fileName msgFileName } { set fmt \ [backslashify \ [percentify [lindex $items(DateTimePatterns) $i]]] - regsub { %Z} $fmt {} format($localeName,TIME_FORMAT) + regsub " %Z" $fmt "" format($localeName,TIME_FORMAT) } } @@ -473,7 +476,7 @@ proc handleLocaleFile { localeName fileName msgFileName } { set fmt \ [backslashify \ [percentify [lindex $items(DateTimePatterns) $i]]] - regsub { %Z} $fmt {} format($localeName,TIME_FORMAT_12) + regsub " %Z" $fmt "" format($localeName,TIME_FORMAT_12) } } @@ -489,17 +492,17 @@ proc handleLocaleFile { localeName fileName msgFileName } { # Date and time... Prefer 24-hour format to 12-hour format. - if { ![info exists format($localeName,DATE_TIME_FORMAT)] - && [info exists format($localeName,DATE_FORMAT)] - && [info exists format($localeName,TIME_FORMAT)]} { + if { (![info exists format($localeName,DATE_TIME_FORMAT)]) && + [info exists format($localeName,DATE_FORMAT)] && + [info exists format($localeName,TIME_FORMAT)]} { set format($localeName,DATE_TIME_FORMAT) \ $format($localeName,DATE_FORMAT) append format($localeName,DATE_TIME_FORMAT) \ " " $format($localeName,TIME_FORMAT) " %z" } - if { ![info exists format($localeName,DATE_TIME_FORMAT)] - && [info exists format($localeName,DATE_FORMAT)] - && [info exists format($localeName,TIME_FORMAT_12)]} { + if { (![info exists format($localeName,DATE_TIME_FORMAT)]) && + [info exists format($localeName,DATE_FORMAT)] && + [info exists format($localeName,TIME_FORMAT_12)]} { set format($localeName,DATE_TIME_FORMAT) \ $format($localeName,DATE_FORMAT) append format($localeName,DATE_TIME_FORMAT) \ @@ -553,8 +556,8 @@ proc handleLocaleFile { localeName fileName msgFileName } { #---------------------------------------------------------------------- proc percentify { string } { - set retval {} - foreach { unquoted quoted } [split $string '] { + set retval "" + foreach { unquoted quoted } [split $string "'"] { append retval [string map { EEEE %A MMMM %B yyyy %Y MMM %b EEE %a @@ -585,15 +588,13 @@ proc percentify { string } { proc backslashify { string } { - set retval {} - foreach char [split $string {}] { + set retval "" + foreach char [split $string ""] { scan $char %c ccode - if { $ccode >= 0x0020 && $ccode < 0x007f && $char ne "\"" - && $char ne "\{" && $char ne "\}" && $char ne "\[" - && $char ne "\]" && $char ne "\\" && $char ne "\$" } { + if { ($ccode >= 0x0020) && ($ccode < 0x007f) && ($char ni "\" \{ \} \[ \] \\ \$") } { append retval $char } else { - append retval \\u [format %04x $ccode] + append retval "\\u" [format %04x $ccode] } } return $retval @@ -607,7 +608,7 @@ proc backslashify { string } { # Extract directories from command line -foreach { icudir msgdir } $argv break +lassign $argv icudir msgdir # Walk the ICU files and create corresponding Tcl message catalogs diff --git a/tools/makeTestCases.tcl b/tools/makeTestCases.tcl index d96a221..072e543 100755 --- a/tools/makeTestCases.tcl +++ b/tools/makeTestCases.tcl @@ -4,7 +4,7 @@ package require msgcat set d [file dirname [file dirname [info script]]] puts "getting transition data from [file join $d library tzdata America Detroit]" -source [file join $d library/tzdata/America/Detroit] +source [file join $d library tzdata America Detroit] namespace eval ::tcl::clock { ::msgcat::mcmset en_US_roman { @@ -86,14 +86,14 @@ proc listYears { startOfYearArray } { set s 0 set dw 4 ;# Thursday while { $y < 2100 } { - if { $y % 4 == 0 && $y % 100 != 0 || $y % 400 == 0 } { + if { (($y % 4) == 0) && (($y % 100) != 0) || (($y % 400) == 0) } { set l 1 incr dw 366 - set s2 [expr { $s + wide( 366 * 86400 ) }] + set s2 [expr { $s + ( wide ( 366 * 86400 ) ) }] } else { set l 0 incr dw 365 - set s2 [expr { $s + wide( 365 * 86400 ) }] + set s2 [expr { $s + ( wide ( 365 * 86400 ) ) }] } set x [expr { $y >= 2037 }] set dw [expr {$dw % 7}] @@ -116,14 +116,14 @@ proc listYears { startOfYearArray } { set s0 $s incr dw 371 incr y -1 - if { $y % 4 == 0 && $y % 100 != 0 || $y % 400 == 0 } { + if { (($y % 4) == 0) && (($y % 100) != 0) || (($y % 400) == 0) } { set l 1 incr dw -366 - set s [expr { $s - wide(366 * 86400) }] + set s [expr { $s - ( wide (366 * 86400) ) }] } else { set l 0 incr dw -365 - set s [expr { $s - wide(365 * 86400) }] + set s [expr { $s - ( wide (365 * 86400) ) }] } set dw [expr {$dw % 7}] set c [expr { $y / 100 }] @@ -154,18 +154,18 @@ proc processFile {d} { # Open two files - set f1 [open [file join $d tests/clock.test] r] - set f2 [open [file join $d tests/clock.new] w] + set f1 [open [file join $d [file join tests clock.test]] r] + set f2 [open [file join $d [file join tests clock.new]] w] # Copy leading portion of the test file - set state {} - while { [gets $f1 line] >= 0 } { + set state "" + while { [chan gets $f1 line] >= 0 } { switch -exact -- $state { - {} { + "" { puts $f2 $line - if { [regexp "^\# BEGIN (.*)" $line -> cases] - && [string compare {} [info commands $cases]] } { + if { [regexp "^\# BEGIN (.*)" $line ___ cases] && + [string compare "" [info commands $cases]] } { set state inCaseSet $cases $f2 } @@ -173,9 +173,10 @@ proc processFile {d} { inCaseSet { if { [regexp "^\#\ END $cases\$" $line] } { puts $f2 $line - set state {} + set state "" } } + default {} } } @@ -183,10 +184,10 @@ proc processFile {d} { close $f1 close $f2 - file delete -force [file join $d tests/clock.bak] - file rename -force [file join $d tests/clock.test] \ - [file join $d tests/clock.bak] - file rename [file join $d tests/clock.new] [file join $d tests/clock.test] + file delete -force -- [file join $d tests clock.bak] + file rename -force -- [file join $d tests clock.test] \ + [file join $d tests clock.bak] + file rename -- [file join $d tests clock.new] [file join $d tests clock.test] } @@ -236,9 +237,9 @@ proc testcases2 { f2 } { # Names of the months - set short {{} Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec} + set short {"" Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec} set long { - {} January February March April May June July August September + "" January February March April May June July August September October November December } @@ -253,13 +254,13 @@ proc testcases2 { f2 } { # from 1896 to 2045 set n 0 - foreach { y } [lsort -integer [array names startOfYear]] { - set s [expr { $startOfYear($y) + wide(12*3600 + 34*60 + 56) }] + foreach y [lsort -integer [array names startOfYear]] { + set s [expr { $startOfYear($y) + ( wide ( (12 * 3600) + (34 * 60) + 56) ) }] set m 0 set yd 1 foreach hath { 31 28 31 30 31 30 31 31 30 31 30 31 } { incr m - if { $m == 2 && ( $y%4 == 0 && $y%100 != 0 || $y%400 == 0 ) } { + if { ($m == 2) && ( (($y % 4) == 0) && (($y % 100) != 0) || (($y % 400) == 0) ) } { incr hath } @@ -291,11 +292,11 @@ proc testcases2 { f2 } { [lindex $romanc [expr { $y / 100 }]] \ [lindex $roman [expr { $y % 100 }]] \ " " $yy " " [lindex $roman [expr { $y % 100 }]] " " $y - puts $f2 "test clock-2.[incr n] {conversion of $dt} {" + puts $f2 "test clock-2.[incr n] \{conversion of $dt\} \{" puts $f2 " clock format $s \\" puts $f2 "\t-format {%b %B %c %Ec %C %EC %d %Od %e %Oe %h %j %J %m %Om %N %x %Ex %y %Oy %Y} \\" puts $f2 "\t-gmt true -locale en_US_roman" - puts $f2 "} {$result}" + puts $f2 "\} \{$result\}" set hm1 [expr { $hath - 1 }] incr s [expr { 86400 * ( $hath - 1 ) }] @@ -327,11 +328,11 @@ proc testcases2 { f2 } { [lindex $romanc [expr { $y / 100 }]] \ [lindex $roman [expr { $y % 100 }]] \ " " $yy " " [lindex $roman [expr { $y % 100 }]] " " $y - puts $f2 "test clock-2.[incr n] {conversion of $dt} {" + puts $f2 "test clock-2.[incr n] \{conversion of $dt\} \{" puts $f2 " clock format $s \\" puts $f2 "\t-format {%b %B %c %Ec %C %EC %d %Od %e %Oe %h %j %J %m %Om %N %x %Ex %y %Oy %Y} \\" puts $f2 "\t-gmt true -locale en_US_roman" - puts $f2 "} {$result}" + puts $f2 "\} \{$result\}" incr s 86400 incr yd @@ -364,11 +365,11 @@ proc testcases3 { f2 } { listYears startOfYear set case 0 - foreach { y } [lsort -integer [array names startOfYear]] { + foreach y [lsort -integer [array names startOfYear]] { set secs $startOfYear($y) set ym1 [expr { $y - 1 }] - set dow [expr { ( $secs / 86400 + 4 ) % 7}] - switch -exact $dow { + set dow [expr { ( ( $secs / 86400 ) + 4 ) % 7}] + switch -exact -- $dow { 0 { # Year starts on a Sunday. # Prior year started on a Friday or Saturday, and was @@ -377,13 +378,13 @@ proc testcases3 { f2 } { # begins ISO week 1 of the current year. # 1 January is week 1 according to %U. According to %W, # week 1 begins on 2 January - testISO $f2 $ym1 52 1 [expr { $secs - 6*86400 }] + testISO $f2 $ym1 52 1 [expr { $secs - (6 * 86400) }] testISO $f2 $ym1 52 6 [expr { $secs - 86400 }] testISO $f2 $ym1 52 7 $secs testISO $f2 $y 1 1 [expr { $secs + 86400 }] - testISO $f2 $y 1 6 [expr { $secs + 6*86400}] - testISO $f2 $y 1 7 [expr { $secs + 7*86400 }] - testISO $f2 $y 2 1 [expr { $secs + 8*86400 }] + testISO $f2 $y 1 6 [expr { $secs + (6 * 86400)}] + testISO $f2 $y 1 7 [expr { $secs + (7 * 86400) }] + testISO $f2 $y 2 1 [expr { $secs + (8 * 86400) }] } 1 { # Year starts on a Monday. @@ -392,71 +393,72 @@ proc testcases3 { f2 } { # 1 January is ISO week 1 of the current year # According to %U, it's week 0 until 7 January # 1 January is week 1 according to %W - testISO $f2 $ym1 52 1 [expr { $secs - 7*86400 }] - testISO $f2 $ym1 52 6 [expr {$secs - 2*86400}] + testISO $f2 $ym1 52 1 [expr { $secs - (7 * 86400) }] + testISO $f2 $ym1 52 6 [expr {$secs - (2 * 86400)}] testISO $f2 $ym1 52 7 [expr { $secs - 86400 }] testISO $f2 $y 1 1 $secs - testISO $f2 $y 1 6 [expr {$secs + 5*86400}] - testISO $f2 $y 1 7 [expr { $secs + 6*86400 }] - testISO $f2 $y 2 1 [expr { $secs + 7*86400 }] + testISO $f2 $y 1 6 [expr {$secs + (5 * 86400)}] + testISO $f2 $y 1 7 [expr { $secs + (6 * 86400)}] + testISO $f2 $y 2 1 [expr { $secs + (7 * 86400)}] } 2 { # Year starts on a Tuesday. - testISO $f2 $ym1 52 1 [expr { $secs - 8*86400 }] - testISO $f2 $ym1 52 6 [expr {$secs - 3*86400}] - testISO $f2 $ym1 52 7 [expr { $secs - 2*86400 }] + testISO $f2 $ym1 52 1 [expr { $secs - (8 * 86400) }] + testISO $f2 $ym1 52 6 [expr {$secs - (3 * 86400)}] + testISO $f2 $ym1 52 7 [expr { $secs - (2 * 86400) }] testISO $f2 $y 1 1 [expr { $secs - 86400 }] testISO $f2 $y 1 2 $secs - testISO $f2 $y 1 6 [expr {$secs + 4*86400}] - testISO $f2 $y 1 7 [expr { $secs + 5*86400 }] - testISO $f2 $y 2 1 [expr { $secs + 6*86400 }] + testISO $f2 $y 1 6 [expr {$secs + (4 * 86400)}] + testISO $f2 $y 1 7 [expr { $secs + (5 * 86400) }] + testISO $f2 $y 2 1 [expr { $secs + (6 * 86400) }] } 3 { - testISO $f2 $ym1 52 1 [expr { $secs - 9*86400 }] - testISO $f2 $ym1 52 6 [expr {$secs - 4*86400}] - testISO $f2 $ym1 52 7 [expr { $secs - 3*86400 }] - testISO $f2 $y 1 1 [expr { $secs - 2*86400 }] + testISO $f2 $ym1 52 1 [expr { $secs - (9 * 86400) }] + testISO $f2 $ym1 52 6 [expr {$secs - (4 * 86400)}] + testISO $f2 $ym1 52 7 [expr { $secs - (3 * 86400) }] + testISO $f2 $y 1 1 [expr { $secs - (2 * 86400) }] testISO $f2 $y 1 3 $secs - testISO $f2 $y 1 6 [expr {$secs + 3*86400}] - testISO $f2 $y 1 7 [expr { $secs + 4*86400 }] - testISO $f2 $y 2 1 [expr { $secs + 5*86400 }] + testISO $f2 $y 1 6 [expr {$secs + (3 * 86400)}] + testISO $f2 $y 1 7 [expr { $secs + (4 * 86400) }] + testISO $f2 $y 2 1 [expr { $secs + (5 * 86400) }] } 4 { - testISO $f2 $ym1 52 1 [expr { $secs - 10*86400 }] - testISO $f2 $ym1 52 6 [expr {$secs - 5*86400}] - testISO $f2 $ym1 52 7 [expr { $secs - 4*86400 }] - testISO $f2 $y 1 1 [expr { $secs - 3*86400 }] + testISO $f2 $ym1 52 1 [expr { $secs - (10 * 86400) }] + testISO $f2 $ym1 52 6 [expr {$secs - (5 * 86400)}] + testISO $f2 $ym1 52 7 [expr { $secs - (4 * 86400) }] + testISO $f2 $y 1 1 [expr { $secs - (3 * 86400) }] testISO $f2 $y 1 4 $secs - testISO $f2 $y 1 6 [expr {$secs + 2*86400}] - testISO $f2 $y 1 7 [expr { $secs + 3*86400 }] - testISO $f2 $y 2 1 [expr { $secs + 4*86400 }] + testISO $f2 $y 1 6 [expr {$secs + (2 * 86400)}] + testISO $f2 $y 1 7 [expr { $secs + (3 * 86400) }] + testISO $f2 $y 2 1 [expr { $secs + (4 * 86400) }] } 5 { - testISO $f2 $ym1 53 1 [expr { $secs - 4*86400 }] + testISO $f2 $ym1 53 1 [expr { $secs - (4 * 86400) }] testISO $f2 $ym1 53 5 $secs testISO $f2 $ym1 53 6 [expr {$secs + 86400}] - testISO $f2 $ym1 53 7 [expr { $secs + 2*86400 }] - testISO $f2 $y 1 1 [expr { $secs + 3*86400 }] - testISO $f2 $y 1 6 [expr {$secs + 8*86400}] - testISO $f2 $y 1 7 [expr { $secs + 9*86400 }] - testISO $f2 $y 2 1 [expr { $secs + 10*86400 }] + testISO $f2 $ym1 53 7 [expr { $secs + (2 * 86400) }] + testISO $f2 $y 1 1 [expr { $secs + (3 * 86400) }] + testISO $f2 $y 1 6 [expr {$secs + (8 * 86400)}] + testISO $f2 $y 1 7 [expr { $secs + (9 * 86400) }] + testISO $f2 $y 2 1 [expr { $secs + (10 * 86400) }] } 6 { # messy case because previous year may have had 52 or 53 weeks - if { $y%4 == 1 } { - testISO $f2 $ym1 53 1 [expr { $secs - 5*86400 }] + if { ($y % 4) == 1 } { + testISO $f2 $ym1 53 1 [expr { $secs - (5 * 86400) }] testISO $f2 $ym1 53 6 $secs testISO $f2 $ym1 53 7 [expr { $secs + 86400 }] } else { - testISO $f2 $ym1 52 1 [expr { $secs - 5*86400 }] + testISO $f2 $ym1 52 1 [expr { $secs - (5 * 86400) }] testISO $f2 $ym1 52 6 $secs testISO $f2 $ym1 52 7 [expr { $secs + 86400 }] } - testISO $f2 $y 1 1 [expr { $secs + 2*86400 }] - testISO $f2 $y 1 6 [expr { $secs + 7*86400 }] - testISO $f2 $y 1 7 [expr { $secs + 8*86400 }] - testISO $f2 $y 2 1 [expr { $secs + 9*86400 }] + testISO $f2 $y 1 1 [expr { $secs + (2 * 86400) }] + testISO $f2 $y 1 6 [expr { $secs + (7 * 86400) }] + testISO $f2 $y 1 7 [expr { $secs + (8 * 86400) }] + testISO $f2 $y 2 1 [expr { $secs + (9 * 86400) }] } + default {} } } puts "testcases3: $case test cases." @@ -464,20 +466,19 @@ proc testcases3 { f2 } { } proc testISO { f2 G V u secs } { - upvar 1 case case - set longdays {Sunday Monday Tuesday Wednesday Thursday Friday Saturday Sunday} - set shortdays {Sun Mon Tue Wed Thu Fri Sat Sun} + set longdays [list Sunday Monday Tuesday Wednesday Thursday Friday Saturday Sunday] + set shortdays [list Sun Mon Tue Wed Thu Fri Sat Sun] - puts $f2 "test clock-3.[incr case] {ISO week-based calendar [format %04d-W%02d-%d $G $V $u]} {" + puts $f2 "test clock-3.[incr case] \{ISO week-based calendar [format %04d-W%02d-%d $G $V $u]\} \{" puts $f2 " clock format $secs -format {%a %A %g %G %u %U %V %w %W} -gmt true; \# $G-W[format %02d $V]-$u" - puts $f2 "} {[lindex $shortdays $u] [lindex $longdays $u]\ + puts $f2 "\} \{[lindex $shortdays $u] [lindex $longdays $u]\ [format %02d [expr { $G % 100 }]] $G\ $u\ [clock format $secs -format %U -gmt true]\ [format %02d $V] [expr { $u % 7 }]\ - [clock format $secs -format %W -gmt true]}" + [clock format $secs -format %W -gmt true]\}" } @@ -500,10 +501,10 @@ proc testISO { f2 G V u secs } { proc testcases4 { f2 } { - puts $f2 {} + puts $f2 "" puts $f2 "\# Test formatting of time of day" puts $f2 "\# Format groups tested: %H %OH %I %OI %k %Ok %l %Ol %M %OM %p %P %r %R %S %OS %T %X %EX %+" - puts $f2 {} + puts $f2 "" set i 0 set fmt "%H %OH %I %OI %k %Ok %l %Ol %M %OM %p %P %r %R %S %OS %T %X %EX %+" @@ -523,7 +524,7 @@ proc testcases4 { f2 } { set mm [format %02d $m] foreach { s romanS } { 0 ? 1 i 58 lviii 59 lix } { set ss [format %02d $s] - set x [expr { ( $h * 60 + $m ) * 60 + $s }] + set x [expr { ( ( ($h * 60) + $m ) * 60 ) + $s }] set result "" append result $hh " " $romanH " " $II " " $romanI " " \ $hs " " $romanH " " $Is " " $romanI " " $mm " " $romanM " " \ @@ -535,12 +536,12 @@ proc testcases4 { f2 } { $hh ":" $mm ":" $ss " " \ $romanH " h " $romanM " m " $romanS " s " \ "Thu Jan 1 " $hh : $mm : $ss " GMT 1970" - puts $f2 "test clock-4.[incr i] { format time of day $hh:$mm:$ss } {" + puts $f2 "test clock-4.[incr i] \{ format time of day $hh:$mm:$ss \} \{" puts $f2 " clock format $x \\" puts $f2 " -format [list $fmt] \\" puts $f2 " -locale en_US_roman \\" puts $f2 " -gmt true" - puts $f2 "} {$result}" + puts $f2 "\} \{$result\}" } } } @@ -569,59 +570,59 @@ proc testcases4 { f2 } { proc testcases5 { f2 } { variable TZData - puts $f2 {} + puts $f2 "" puts $f2 "\# Test formatting of Daylight Saving Time" - puts $f2 {} + puts $f2 "" - set fmt {%H:%M:%S %z %Z} + set fmt "%H:%M:%S %z %Z" set i 0 - puts $f2 "test clock-5.[incr i] {does Detroit exist} {" - puts $f2 " clock format 0 -format {} -timezone :America/Detroit" + puts $f2 "test clock-5.[incr i] \{does Detroit exist\} \{" + puts $f2 " clock format 0 -format \{\} -timezone :America/Detroit" puts $f2 " concat" - puts $f2 "} {}" - puts $f2 "test clock-5.[incr i] {does Detroit have a Y2038 problem} detroit {" - puts $f2 " if { \[clock format 2158894800 -format %z -timezone :America/Detroit\] ne {-0400} } {" - puts $f2 " concat {y2038 problem}" - puts $f2 " } else {" - puts $f2 " concat {ok}" - puts $f2 " }" - puts $f2 "} ok" + puts $f2 "\} \{\}" + puts $f2 "test clock-5.[incr i] \{does Detroit have a Y2038 problem\} detroit \{" + puts $f2 " if \{ \[clock format 2158894800 -format %z -timezone :America/Detroit\] ne \{-0400\} \} \{" + puts $f2 " concat \{y2038 problem\}" + puts $f2 " \} else \{" + puts $f2 " concat \{ok\}" + puts $f2 " \}" + puts $f2 "\} ok" foreach row $TZData(:America/Detroit) { - foreach { t offset isdst tzname } $row break + lassign $row t offset isdst tzname if { $t > -4000000000000 } { set conds [list detroit] if { $t > wide(0x7fffffff) } { set conds [list detroit y2038] } incr t -1 - set x [clock format $t -format {%Y-%m-%d %H:%M:%S} \ + set x [clock format $t -format "%Y-%m-%d %H:%M:%S" \ -timezone :America/Detroit] set r [clock format $t -format $fmt \ -timezone :America/Detroit] - puts $f2 "test clock-5.[incr i] {time zone boundary case $x} [list $conds] {" + puts $f2 "test clock-5.[incr i] \{time zone boundary case $x\} [list $conds] \{" puts $f2 " clock format $t -format [list $fmt] \\" puts $f2 " -timezone :America/Detroit" - puts $f2 "} [list $r]" + puts $f2 "\} [list $r]" incr t - set x [clock format $t -format {%Y-%m-%d %H:%M:%S} \ + set x [clock format $t -format "%Y-%m-%d %H:%M:%S" \ -timezone :America/Detroit] set r [clock format $t -format $fmt \ -timezone :America/Detroit] - puts $f2 "test clock-5.[incr i] {time zone boundary case $x} [list $conds] {" + puts $f2 "test clock-5.[incr i] \{time zone boundary case $x\} [list $conds] \{" puts $f2 " clock format $t -format [list $fmt] \\" puts $f2 " -timezone :America/Detroit" - puts $f2 "} [list $r]" + puts $f2 "\} [list $r]" incr t - set x [clock format $t -format {%Y-%m-%d %H:%M:%S} \ + set x [clock format $t -format "%Y-%m-%d %H:%M:%S" \ -timezone :America/Detroit] set r [clock format $t -format $fmt \ -timezone :America/Detroit] - puts $f2 "test clock-5.[incr i] {time zone boundary case $x} [list $conds] {" + puts $f2 "test clock-5.[incr i] \{time zone boundary case $x\} [list $conds] \{" puts $f2 " clock format $t -format [list $fmt] \\" puts $f2 " -timezone :America/Detroit" - puts $f2 "} [list $r]" + puts $f2 "\} [list $r]" } } puts "testcases5: $i test cases" @@ -665,9 +666,9 @@ proc testcases8 { f2 } { -format "$ccyy $mm $dd" \ -locale en_US_roman \ -gmt true] - puts $f2 "test clock-8.[incr n] {parse ccyymmdd} {" + puts $f2 "test clock-8.[incr n] \{parse ccyymmdd\} \{" puts $f2 " [list clock scan $string -format [list $ccyy $mm $dd] -locale en_US_roman -gmt 1]" - puts $f2 "} $scanned" + puts $f2 "\} $scanned" } } } @@ -676,9 +677,9 @@ proc testcases8 { f2 } { -format $fmt \ -locale en_US_roman \ -gmt true] - puts $f2 "test clock-8.[incr n] {parse ccyymmdd} {" + puts $f2 "test clock-8.[incr n] \{parse ccyymmdd\} \{" puts $f2 " [list clock scan $string -format $fmt -locale en_US_roman -gmt 1]" - puts $f2 "} $scanned" + puts $f2 "\} $scanned" } } } @@ -738,13 +739,14 @@ proc testcases11 { f2 } { j { set value 86400 } + default {} } } set format "%$a%$b%$c%$d" set string "$v($a)$v($b)$v($c)$v($d)" - puts $f2 "test clock-11.[incr n] {precedence of ccyyddd and ccyymmdd} {" + puts $f2 "test clock-11.[incr n] \{precedence of ccyyddd and ccyymmdd\} \{" puts $f2 " [list clock scan $string -format $format -gmt 1]" - puts $f2 "} $value" + puts $f2 "\} $value" } puts "testcases11: $n test cases" @@ -786,9 +788,9 @@ proc testcases12 { f2 } { -format "%G W%V $d" \ -locale en_US_roman \ -gmt true] - puts $f2 "test clock-12.[incr n] {parse ccyyWwwd} {" + puts $f2 "test clock-12.[incr n] \{parse ccyyWwwd\} \{" puts $f2 " [list clock scan $string -format [list %G W%V $d] -locale en_US_roman -gmt 1]" - puts $f2 "} $scanned" + puts $f2 "\} $scanned" } } } @@ -834,9 +836,9 @@ proc testcases14 { f2 } { -format "$yy $mm $dd" \ -locale en_US_roman \ -gmt true] - puts $f2 "test clock-14.[incr n] {parse yymmdd} {" + puts $f2 "test clock-14.[incr n] \{parse yymmdd\} \{" puts $f2 " [list clock scan $string -format [list $yy $mm $dd] -locale en_US_roman -gmt 1]" - puts $f2 "} $scanned" + puts $f2 "\} $scanned" } } } @@ -883,9 +885,9 @@ proc testcases17 { f2 } { -format "%g W%V $d" \ -locale en_US_roman \ -gmt true] - puts $f2 "test clock-17.[incr n] {parse yyWwwd} {" + puts $f2 "test clock-17.[incr n] \{parse yyWwwd\} \{" puts $f2 " [list clock scan $string -format [list %g W%V $d] -locale en_US_roman -gmt 1]" - puts $f2 "} $scanned" + puts $f2 "\} $scanned" } } } @@ -931,9 +933,9 @@ proc testcases19 { f2 } { -format "$mm $dd" \ -locale en_US_roman \ -gmt true] - puts $f2 "test clock-19.[incr n] {parse mmdd} {" + puts $f2 "test clock-19.[incr n] \{parse mmdd\} \{" puts $f2 " [list clock scan $string -format [list $mm $dd] -locale en_US_roman -base $base -gmt 1]" - puts $f2 "} $scanned" + puts $f2 "\} $scanned" } } } @@ -980,9 +982,9 @@ proc testcases22 { f2 } { -format "W%V $d" \ -locale en_US_roman \ -gmt true] - puts $f2 "test clock-22.[incr n] {parse Wwwd} {" + puts $f2 "test clock-22.[incr n] \{parse Wwwd\} \{" puts $f2 " [list clock scan $string -format [list W%V $d] -locale en_US_roman -gmt 1] -base $base" - puts $f2 "} $scanned" + puts $f2 "\} $scanned" } } } @@ -1024,12 +1026,12 @@ proc testcases24 { f2 } { set scanned [clock scan $year$month$day -gmt true] foreach dd {%d %Od %e %Oe} { set string [clock format $scanned \ - -format "$dd" \ + -format $dd \ -locale en_US_roman \ -gmt true] - puts $f2 "test clock-24.[incr n] {parse naked day of month} {" + puts $f2 "test clock-24.[incr n] \{parse naked day of month\} \{" puts $f2 " [list clock scan $string -format $dd -locale en_US_roman -base $base -gmt 1]" - puts $f2 "} $scanned" + puts $f2 "\} $scanned" } } } @@ -1074,12 +1076,12 @@ proc testcases26 { f2 } { -format %GW%V%u -gmt true] foreach d {%a %A %u %w %Ou %Ow} { set string [clock format $scanned \ - -format "$d" \ + -format $d \ -locale en_US_roman \ -gmt true] - puts $f2 "test clock-26.[incr n] {parse naked day of week} {" + puts $f2 "test clock-26.[incr n] \{parse naked day of week\} \{" puts $f2 " [list clock scan $string -format $d -locale en_US_roman -gmt 1] -base $base" - puts $f2 "} $scanned" + puts $f2 "\} $scanned" } } } @@ -1126,15 +1128,15 @@ proc testcases29 { f2 } { set AMPMind [string toupper $ampmind] foreach minute {00 01 59} lminute {? i lix} { foreach second {00 01 59} lsecond {? i lix} { - set time [expr { ( 60 * $hour + $minute ) * 60 + $second }] + set time [expr { ( ( (60 * $hour) + $minute ) * 60 ) + $second }] foreach {hfmt afmt} [list \ - %H {} %k {} %OH {} %Ok {} \ + %H "" %k "" %OH "" %Ok "" \ %I %p %l %p \ %OI %p %Ol %p \ %I %P %l %P \ %OI %P %Ol %P] \ {hfld afld} [list \ - $2dhr {} $sphr {} $lhour {} $lhour {} \ + $2dhr "" $sphr "" $lhour "" $lhour "" \ $2dhampm $AMPMind $sphampm $AMPMind \ $lhampm $AMPMind $lhampm $AMPMind \ $2dhampm $ampmind $sphampm $ampmind \ @@ -1142,33 +1144,33 @@ proc testcases29 { f2 } { { if { $second eq "00" } { if { $minute eq "00" } { - puts $f2 "test clock-29.[incr n] {time parsing} {" + puts $f2 "test clock-29.[incr n] \{time parsing\} \{" puts $f2 " clock scan {2440588 $hfld $afld} \\" puts $f2 " -gmt true -locale en_US_roman \\" puts $f2 " -format {%J $hfmt $afmt}" - puts $f2 "} $time" + puts $f2 "\} $time" } - puts $f2 "test clock-29.[incr n] {time parsing} {" + puts $f2 "test clock-29.[incr n] \{time parsing\} \{" puts $f2 " clock scan {2440588 $hfld:$minute $afld} \\" puts $f2 " -gmt true -locale en_US_roman \\" puts $f2 " -format {%J $hfmt:%M $afmt}" - puts $f2 "} $time" - puts $f2 "test clock-29.[incr n] {time parsing} {" + puts $f2 "\} $time" + puts $f2 "test clock-29.[incr n] \{time parsing\} \{" puts $f2 " clock scan {2440588 $hfld:$lminute $afld} \\" puts $f2 " -gmt true -locale en_US_roman \\" puts $f2 " -format {%J $hfmt:%OM $afmt}" - puts $f2 "} $time" + puts $f2 "\} $time" } - puts $f2 "test clock-29.[incr n] {time parsing} {" + puts $f2 "test clock-29.[incr n] \{time parsing\} \{" puts $f2 " clock scan {2440588 $hfld:$minute:$second $afld} \\" puts $f2 " -gmt true -locale en_US_roman \\" puts $f2 " -format {%J $hfmt:%M:%S $afmt}" - puts $f2 "} $time" - puts $f2 "test clock-29.[incr n] {time parsing} {" + puts $f2 "\} $time" + puts $f2 "test clock-29.[incr n] \{time parsing\} \{" puts $f2 " clock scan {2440588 $hfld:$lminute:$lsecond $afld} \\" puts $f2 " -gmt true -locale en_US_roman \\" puts $f2 " -format {%J $hfmt:%OM:%OS $afmt}" - puts $f2 "} $time" + puts $f2 "\} $time" } } } diff --git a/tools/man2help.tcl b/tools/man2help.tcl index 018fa84..cb2869d 100644 --- a/tools/man2help.tcl +++ b/tools/man2help.tcl @@ -22,18 +22,18 @@ proc generateContents {basename version files} { doFile $f } set fd [open [file join [file dirname [info script]] $basename$version.cnt] w] - fconfigure $fd -translation crlf + chan configure $fd -translation crlf puts $fd ":Base $basename$version.hlp" foreach package [getPackages] { foreach section [getSections $package] { if {![info exists lastSection]} { - set lastSection {} + set lastSection "" } if {[string compare $lastSection $section]} { puts $fd "1 $section" } set lastSection $section - set lastTopic {} + set lastTopic "" foreach topic [getTopics $package $section] { if {[string compare $lastTopic $topic]} { set id $topics($package,$section,$topic) @@ -62,7 +62,7 @@ proc generateHelp {basename files} { } set file [open [file join [file dirname [info script]] $basename.rtf] w] - fconfigure $file -translation crlf + chan configure $file -translation crlf puts $file "\{\\rtf1\\ansi \\deff0\\deflang1033\{\\fonttbl\{\\f0\\froman\\fcharset0\\fprq2 Times New Roman\;\}\{\\f1\\fmodern\\fcharset0\\fprq1 Courier New\;\}\}" foreach f $files { puts "Pass 2 -- $f" @@ -85,7 +85,7 @@ proc generateHelp {basename files} { proc doFile {file} { global man2tclprog - if {[catch {eval [exec $man2tclprog [glob $file]]} msg]} { + if {[catch {eval [exec -- $man2tclprog [glob -- $file]]} msg]} { global errorInfo puts stderr $msg puts "in" @@ -102,7 +102,7 @@ proc doFile {file} { # Arguments: # dir - Name of the directory. -proc doDir dir { +proc doDir {dir} { puts "Generating man pages for $dir..." foreach f [lsort [glob -directory $dir "*.\[13n\]"]] { doFile $f @@ -124,7 +124,7 @@ if {![string compare [lindex $argv $arg] "-bitmap"]} { } set baseName [lindex $argv $arg] set version [lindex $argv [incr arg]] -set files {} +set files [list] foreach i [lrange $argv [incr arg] end] { set i [file join $i] if {[file isdir $i]} { diff --git a/tools/man2help2.tcl b/tools/man2help2.tcl index fe4e7ad..32c5e10 100644 --- a/tools/man2help2.tcl +++ b/tools/man2help2.tcl @@ -47,10 +47,10 @@ proc initGlobals {} { set state(paragraph) 0 set state(textState) 0 set state(curFont) "" - set state(startCode) "{\\b " - set state(startEmphasis) "{\\i " - set state(endCode) "}" - set state(endEmphasis) "}" + set state(startCode) "\{\\b " + set state(startEmphasis) "\{\\i " + set state(endCode) "\}" + set state(endEmphasis) "\}" set state(noFill) 0 set state(charCnt) 0 set state(offset) [getTwips 0.5i] @@ -117,16 +117,16 @@ proc endFont {} { proc textSetup {} { global file state - if $state(breakPending) { + if {$state(breakPending)} { puts $file "\\line" } - if $state(paragraphPending) { + if {$state(paragraphPending)} { puts $file [format "\\par\n\\pard\\fi%.0f\\li%.0f" \ $state(firstIndent) $state(leftIndent)] foreach tab $state(tabs) { puts $file [format "\\tx%.0f" $tab] } - set state(tabs) {} + set state(tabs) [list] if {$state(sb)} { puts $file "\\sb$state(sb)" set state(sb) 0 @@ -175,7 +175,7 @@ proc text {string} { set state(intl) 0 } - switch $state(textState) { + switch -- $state(textState) { REF { if {$state(inTP) == 0} { set string [insertRef $string] @@ -188,15 +188,16 @@ proc text {string} { continue } if {![catch {set ref $topics($curPkg,$curSect,$i)} ]} { - regsub $i $string [link $i $ref] string + regsub -- $i $string [link $i $ref] string } } } KEY { return } + default {} } - puts -nonewline $file "$string" + puts -nonewline $file $string } @@ -212,9 +213,9 @@ proc text {string} { proc insertRef {string} { global NAME_file curPkg curSect topics curID - set path {} + set path "" set string [string trim $string] - set ref {} + set ref "" if {[info exists topics($curPkg,$curSect,$string)]} { set ref $topics($curPkg,$curSect,$string) } else { @@ -231,7 +232,7 @@ proc insertRef {string} { } } - if {($ref != "") && ($ref != $curID)} { + if {($ref ne "") && ($ref != $curID)} { set string [link $string $ref] } return $string @@ -250,9 +251,9 @@ proc insertRef {string} { proc macro {name args} { global state file - switch $name { + switch -- $name { AP { - if {[llength $args] != 3 && [llength $args] != 2} { + if {([llength $args] != 3) && ([llength $args] != 2)} { puts stderr "Bad .AP macro: .$name [join $args " "]" } newPara 3.75i -3.75i @@ -278,7 +279,7 @@ proc macro {name args} { BS {} BE {} CE { - puts -nonewline $::file "\\f0\\fs20 " + puts -nonewline $file "\\f0\\fs20 " set state(noFill) 0 set state(breakPending) 0 newPara "" @@ -291,7 +292,7 @@ proc macro {name args} { newPara "" set state(leftIndent) [expr {$state(leftIndent) + $state(offset)}] set state(sb) 80 - puts -nonewline $::file "\\f1\\fs18 " + puts -nonewline $file "\\f1\\fs18 " } DE { set state(noFill) 0 @@ -413,9 +414,9 @@ proc macro {name args} { TPmacro $args } UL { ;# underline - puts -nonewline $file "{\\ul " + puts -nonewline $file "\{\\ul " text [lindex $args 0] - puts -nonewline $file "}" + puts -nonewline $file "\}" if {[llength $args] == 2} { text [lindex $args 1] } @@ -468,7 +469,7 @@ proc link {label id} { proc font {type} { global state - switch $type { + switch -- $type { P - R { endFont @@ -513,31 +514,31 @@ proc formattedText {text} { text $text return } - text [string range $text 0 [expr {$index-1}]] - set c [string index $text [expr {$index+1}]] + text [string range $text 0 [expr {$index - 1}]] + set c [string index $text [expr {$index + 1}]] switch -- $c { f { - font [string index $text [expr {$index+2}]] - set text [string range $text [expr {$index+3}] end] + font [string index $text [expr {$index + 2}]] + set text [string range $text [expr {$index + 3}] end] } e { text "\\" - set text [string range $text [expr {$index+2}] end] + set text [string range $text [expr {$index + 2}] end] } - { dash - set text [string range $text [expr {$index+2}] end] + set text [string range $text [expr {$index + 2}] end] } & - | { - set text [string range $text [expr {$index+2}] end] + set text [string range $text [expr {$index + 2}] end] } - ( { - char [string range $text $index [expr {$index+3}]] - set text [string range $text [expr {$index+4}] end] + \( { + char [string range $text $index [expr {$index + 3}]] + set text [string range $text [expr {$index + 4}] end] } default { puts stderr "Unknown sequence: \\$c" - set text [string range $text [expr {$index+2}] end] + set text [string range $text [expr {$index + 2}] end] } } } @@ -587,9 +588,9 @@ proc tab {} { proc setTabs {tabList} { global file state - set state(tabs) {} + set state(tabs) [list] foreach arg $tabList { - if {[string match +* $arg]} { + if {[string match "+*" $arg]} { set relativeTo [lindex $state(tabs) end] set arg [string range $arg 1 end] } else { @@ -597,13 +598,13 @@ proc setTabs {tabList} { set relativeTo [expr {$state(leftMargin) \ + ($state(offset) * $state(nestingLevel))}] } - if {[regexp {^\\w'([^']*)'u$} $arg -> submatch]} { + if {[regexp {^\\w'([^']*)'u$} $arg ___ submatch]} { # Magic factor! set distance [expr {[string length $submatch] * 86.4}] } else { set distance [getTwips $arg] } - lappend state(tabs) [expr {round($distance + $relativeTo)}] + lappend state(tabs) [expr { round ($distance + $relativeTo)}] } } @@ -675,7 +676,7 @@ proc pageBreak {} { proc char {name} { global file state - switch -exact $name { + switch -exact -- $name { {\o} { set state(intl) 1 } @@ -765,13 +766,17 @@ proc SHmacro {argList {style section}} { # control what the text proc does with text - switch $args { + switch -- $args { NAME {set state(textState) NAME} DESCRIPTION {set state(textState) INSERT} INTRODUCTION {set state(textState) INSERT} "WIDGET-SPECIFIC OPTIONS" {set state(textState) INSERT} "SEE ALSO" {set state(textState) SEE} - KEYWORDS {set state(textState) KEY; return} + KEYWORDS { + set state(textState) KEY + return + } + default {} } if {$state(breakPending) != -1} { @@ -780,7 +785,7 @@ proc SHmacro {argList {style section}} { set state(breakPending) 0 } set state(noFill) 0 - if {[string compare "subsection" $style] == 0} { + if {"subsection" eq $style} { nextPara .25i } else { nextPara 0i @@ -812,7 +817,7 @@ proc IPmacro {argList} { global file state set length [llength $argList] - foreach {text indent} $argList break + lassign $argList text indent if {$length > 2} { puts stderr "Bad .IP macro: .IP [join $argList " "]" } @@ -823,11 +828,11 @@ proc IPmacro {argList} { } elseif {$length == 1} { set indent 5 } - if {$text == {\(bu}} { + if {$text eq "\(bu\}"} { set text "\u00b7" } - set tab [expr $indent * 0.1]i + set tab [expr {$indent * 0.1}]i newPara $tab -$tab set state(sb) 80 setTabs $tab @@ -856,7 +861,7 @@ proc TPmacro {argList} { if {$length == 0} { set val 0.5i } else { - set val [expr {([lindex $argList 0] * 100.0)/1440}]i + set val [expr {([lindex $argList 0] * 100.0) / 1440}]i } newPara $val -$val setTabs $val @@ -884,18 +889,15 @@ proc THmacro {argList} { puts stderr "Bad .TH macro: .TH $args" } incr curID - set name [lindex $argList 0] ;# Tcl_UpVar - set page [lindex $argList 1] ;# 3 - set curVer [lindex $argList 2] ;# 7.4 - set curPkg [lindex $argList 3] ;# Tcl - set curSect [lindex $argList 4] ;# {Tcl Library Procedures} + # Tcl_UpVar / 3 / 7.4 / Tcl / {Tcl Library Procedures} + lassign $argList name page curVer curPkg curSect - regsub -all {\\ } $curSect { } curSect ;# Clean up for [incr\ Tcl] + regsub -all {\\ } $curSect " " curSect ;# Clean up for [incr\ Tcl] puts $file "#{\\footnote $curID}" ;# Context string puts $file "\${\\footnote $name}" ;# Topic title set browse "${curSect}${name}" - regsub -all {[ _-]} $browse {} browse + regsub -all {[ _-]} $browse "" browse puts $file "+{\\footnote $browse}" ;# Browse sequence # Suppress duplicates @@ -951,7 +953,7 @@ proc nextPara {leftIndent {firstIndent 0i}} { proc newPara {leftIndent {firstIndent 0i}} { global state file - if $state(paragraph) { + if {$state(paragraph)} { puts -nonewline $file "\\line\n" } if {$leftIndent ne ""} { diff --git a/tools/man2html.tcl b/tools/man2html.tcl index fa57b03..4047bfc 100644 --- a/tools/man2html.tcl +++ b/tools/man2html.tcl @@ -23,7 +23,7 @@ package require Tcl 8.4 proc sarray {file args} { set file [open $file w] foreach a $args { - upvar $a array + upvar 1 $a array if {![array exists array]} { puts "sarray: \"$a\" isn't an array" break @@ -47,12 +47,12 @@ proc sarray {file args} { proc footer {packages} { lappend f "<HR>" - set h {[} + set h "\[" foreach package $packages { lappend h "<A HREF=\"../$package/contents.html\">$package</A>" lappend h "|" } - lappend f [join [lreplace $h end end {]} ] " "] + lappend f [join [lreplace $h end end "\]" ] " "] lappend f "<HR>" lappend f "<PRE>Copyright © 1989-1994 The Regents of the University of California." lappend f "Copyright © 1994-1996 Sun Microsystems, Inc." @@ -69,7 +69,7 @@ proc footer {packages} { # Arguments: # dir - Name of the directory. -proc doDir dir { +proc doDir {dir} { foreach f [lsort [glob -directory $dir "*.\[13n\]"]] { do $f ;# defined in man2html1.tcl & man2html2.tcl } @@ -84,14 +84,14 @@ proc doDir dir { # argv - List of arguments to this script. proc main {argv} { - global html_dir + global html_dir argv0 # Global vars used in man2html1.tcl and man2html2.tcl global NAME_file KEY_file lib state curFile file inDT textState nestStk global curFont fontStart fontEnd noFillCount footer if {[llength $argv] < 2} { - puts stderr "usage: $::argv0 html_dir tcl_dir packages..." - puts stderr "usage: $::argv0 -clean html_dir" + puts stderr "usage: $argv0 html_dir tcl_dir packages..." + puts stderr "usage: $argv0 -clean html_dir" exit 1 } @@ -101,14 +101,12 @@ proc main {argv} { flush stdout if {[gets stdin] eq "y"} { puts "removing: $html_dir" - file delete -force $html_dir + file delete -force -- $html_dir } exit 0 } - set html_dir [lindex $argv 0] - set tcl_dir [lindex $argv 1] - set packages [lrange $argv 2 end] + set packages [lassign $argv html_dir tcl_dir] set homeDir [file dirname [info script]] #### need to add glob capability to packages #### @@ -116,11 +114,12 @@ proc main {argv} { # make sure there are doc directories for each package foreach i $packages { - if {![file exists $tcl_dir/$i/doc]} { + set filename [file join $tcl_dir $i doc] + if {![file exists $filename]} { puts stderr "Error: doc directory for package $i is missing" exit 1 } - if {![file isdirectory $tcl_dir/$i/doc]} { + if {![file isdirectory $filename]} { puts stderr "Error: $tcl_dir/$i/doc is not a directory" exit 1 } @@ -140,18 +139,18 @@ proc main {argv} { # make the hyperlink arrays and contents.html for all packages foreach package $packages { - file mkdir $html_dir/$package + file mkdir [file join $html_dir $package] # build hyperlink database arrays: NAME_file and KEY_file # puts "\nScanning man pages in $tcl_dir/$package/doc..." - uplevel \#0 [list source $homeDir/man2html1.tcl] + uplevel \#0 [list source [file join $homeDir man2html1.tcl]] - doDir $tcl_dir/$package/doc + doDir [file join $tcl_dir $package doc] # clean up the NAME_file and KEY_file database arrays # - catch {unset KEY_file()} + unset -nocomplain KEY_file() foreach name [lsort [array names NAME_file]] { set file_name $NAME_file($name) if {[llength $file_name] > 1} { @@ -178,8 +177,7 @@ proc main {argv} { } } - -if [catch { main $argv } result] { +if {[catch { main $argv } result]} { global errorInfo puts stderr $result puts stderr "in" diff --git a/tools/man2html1.tcl b/tools/man2html1.tcl index f2b2e43..cd97427 100644 --- a/tools/man2html1.tcl +++ b/tools/man2html1.tcl @@ -37,10 +37,10 @@ package require Tcl 8.4 # Arguments: # string - Text to index. -proc text string { +proc text {string} { global state curFile NAME_file KEY_file inDT - switch $state { + switch -- $state { NAME { foreach i [split $string ","] { lappend NAME_file([string trim $i]) $curFile @@ -71,11 +71,11 @@ proc text string { # args - Any additional arguments to the macro. proc macro {name args} { - switch $name { + switch -- $name { SH - SS { global state - switch $args { + switch -- $args { NAME { if {$state eq "INIT"} { set state NAME @@ -102,10 +102,10 @@ proc macro {name args} { } set lib [lindex $args 3] ;# Tcl or Tk } + default {} } } - # dash -- # # This procedure is invoked to handle dash characters ("\-" in @@ -145,8 +145,8 @@ proc newline {} { proc initGlobals {} {} proc tab {} {} -proc font type {} -proc char name {} +proc font {type} {} +proc char {name} {} proc macro2 {name args} {} @@ -165,37 +165,38 @@ proc doListing {file pattern} { set max_len 0 foreach name [lsort [array names NAME_file]] { set ref $NAME_file($name) - if [string match $pattern $ref] { + if {[string match $pattern $ref]} { lappend type $name if {[string length $name] > $max_len} { set max_len [string length $name] } } } - if [catch {llength $type} ] { + if {[catch {llength $type} ]} { puts stderr " doListing: no names matched pattern ($pattern)" return } incr max_len - set ncols [expr {90/$max_len}] - set nrows [expr {int(ceil([llength $type] / double($ncols)))} ] + set ncols [expr {90 / $max_len}] + set nrows [expr { int ( ceil ([llength $type] / ($ncols * 1.0)))} ] # ? max_len ncols nrows set index 0 + array set row {} foreach f $type { lappend row([expr {$index % $nrows}]) $f incr index } puts -nonewline $file "<PRE>" - for {set i 0} {$i<$nrows} {incr i} { + for {set i 0} {$i < $nrows} {incr i} { foreach name $row($i) { set str [format "%-*s" $max_len $name] - regsub $name $str "<A HREF=\"$NAME_file($name).html\">$name</A>" str + regsub -- $name $str "<A HREF=\"$NAME_file($name).html\">$name</A>" str puts -nonewline $file $str } - puts $file {} + puts $file "" } puts $file "</PRE>" } @@ -244,13 +245,13 @@ proc doContents {file packageName} { # Arguments: # fileName - Name of the file to scan. -proc do fileName { +proc do {fileName} { global curFile set curFile [file tail $fileName] set file stdout puts " Pass 1 -- $fileName" flush stdout - if [catch {eval [exec man2tcl [glob $fileName]]} msg] { + if {[catch {eval [exec man2tcl [glob -- $fileName]]} msg]} { global errorInfo puts stderr $msg puts "in" diff --git a/tools/man2html2.tcl b/tools/man2html2.tcl index 163196e..b301a8e 100644 --- a/tools/man2html2.tcl +++ b/tools/man2html2.tcl @@ -73,7 +73,7 @@ proc initGlobals {} { # Arguments: # font - Name of new font to use. -proc beginFont font { +proc beginFont {font} { global curFont file fontStart if {$curFont eq $font} { @@ -111,14 +111,14 @@ proc endFont {} { # Arguments: # string - Text to output in the paragraph. -proc text string { +proc text {string} { global file textState inDT charCnt inTable set pos [string first "\t" $string] if {$pos >= 0} { - text [string range $string 0 [expr $pos-1]] + text [string range $string 0 [expr {$pos - 1}]] tab - text [string range $string [expr $pos+1] end] + text [string range $string [expr {$pos + 1}] end] return } if {$inTable} { @@ -129,10 +129,10 @@ proc text string { puts -nonewline $file <TD> } incr charCnt [string length $string] - regsub -all {&} $string {\&} string - regsub -all {<} $string {\<} string - regsub -all {>} $string {\>} string - regsub -all \" $string {\"} string + regsub -all "&" $string {\&} string + regsub -all "<" $string {\<} string + regsub -all ">" $string {\>} string + regsub -all "\"" $string {\"} string switch -exact -- $textState { REF { if {$inDT eq ""} { @@ -147,12 +147,13 @@ proc text string { continue } if {![catch { set ref $NAME_file($i) }]} { - regsub $i $string "<A HREF=\"$ref.html\">$i</A>" string + regsub -- $i $string "<A HREF=\"$ref.html\">$i</A>" string } } } + default {} } - puts -nonewline $file "$string" + puts -nonewline $file $string if {$inTable} { puts -nonewline $file </TD> } @@ -164,9 +165,9 @@ proc text string { # Arguments: # string - Text to output in the paragraph. -proc insertRef string { +proc insertRef {string} { global NAME_file self - set path {} + set path "" if {![catch { set ref $NAME_file([string trim $string]) }]} { if {"$ref.html" ne $self} { set string "<A HREF=\"${path}$ref.html\">$string</A>" @@ -187,13 +188,13 @@ proc insertRef string { # args - Any additional arguments to the macro. proc macro {name args} { - switch $name { + switch -- $name { AP { if {[llength $args] != 3} { puts stderr "Bad .AP macro: .$name [join $args " "]" } setTabs {1.25i 2.5i 3.75i} - TPmacro {} + TPmacro "" font B text "[lindex $args 0] " font I @@ -226,7 +227,7 @@ proc macro {name args} { } DS { global file noFillCount inTable - puts -nonewline $file {<BLOCKQUOTE><TABLE BORDER="0">} + puts -nonewline $file "<BLOCKQUOTE><TABLE BORDER=\"0\">" set noFillCount 10000000 set inTable 1 } @@ -384,7 +385,7 @@ proc macro {name args} { } } PQ { - puts -nonewline $file "(&\#147;" + puts -nonewline $file "\(&\#147;" if {[lindex $args 0] eq {\N'34'}} { puts -nonewline $file \" } else { @@ -394,7 +395,7 @@ proc macro {name args} { if {[llength $args] > 1} { text [lindex $args 1] } - puts -nonewline $file ")" + puts -nonewline $file "\)" if {[llength $args] > 2} { text [lindex $args 2] } @@ -429,9 +430,9 @@ proc macro {name args} { # Arguments: # type - Type of font: R, I, B, or S. -proc font type { +proc font {type} { global textState - switch $type { + switch -- $type { P - R { endFont @@ -465,7 +466,7 @@ proc font type { # Arguments: # text - Text to insert. -proc formattedText text { +proc formattedText {text} { # puts "formattedText: $text" while {$text ne ""} { set index [string first \\ $text] @@ -473,27 +474,27 @@ proc formattedText text { text $text return } - text [string range $text 0 [expr $index-1]] - set c [string index $text [expr $index+1]] + text [string range $text 0 [expr {$index - 1}]] + set c [string index $text [expr {$index + 1}]] switch -- $c { f { - font [string index $text [expr $index+2]] - set text [string range $text [expr $index+3] end] + font [string index $text [expr {$index + 2}]] + set text [string range $text [expr {$index + 3}] end] } e { - text \\ - set text [string range $text [expr $index+2] end] + text "\\" + set text [string range $text [expr {$index + 2}] end] } - { dash - set text [string range $text [expr $index+2] end] + set text [string range $text [expr {$index + 2}] end] } | { - set text [string range $text [expr $index+2] end] + set text [string range $text [expr {$index + 2}] end] } default { puts stderr "Unknown sequence: \\$c" - set text [string range $text [expr $index+2] end] + set text [string range $text [expr {$index + 2}] end] } } } @@ -529,7 +530,7 @@ proc tab {} { global inPRE charCnt tabString file # ? charCnt if {$inPRE == 1} { - set pos [expr $charCnt % [string length $tabString] ] + set pos [expr {$charCnt % [string length $tabString] }] set spaces [string first "1" [string range $tabString $pos end] ] text [format "%*s" [incr spaces] " "] } else { @@ -551,11 +552,11 @@ proc setTabs {tabList} { # puts "setTabs: --$tabList--" set last 0 - set tabString {} + set tabString "" set charsPerInch 14. set numTabs [llength $tabList] foreach arg $tabList { - if {[string match +* $arg]} { + if {[string match "+*" $arg]} { set relative 1 set arg [string range $arg 1 end] } else { @@ -571,7 +572,7 @@ proc setTabs {tabList} { } switch -- $units { c { - set distance [expr {$distance * $charsPerInch / 2.54}] + set distance [expr {($distance * $charsPerInch) / 2.54}] } i { set distance [expr {$distance * $charsPerInch}] @@ -584,10 +585,10 @@ proc setTabs {tabList} { } # ? distance if {$relative} { - append tabString [format "%*s1" [expr {round($distance-1)}] " "] + append tabString [format "%*s1" [expr { round ($distance - 1)}] " "] set last [expr {$last + $distance}] } else { - append tabString [format "%*s1" [expr {round($distance-$last-1)}] " "] + append tabString [format "%*s1" [expr { round ($distance - $last - 1)}] " "] set last $distance } } @@ -621,14 +622,14 @@ proc newline {} { if {$inDT ne ""} { puts $file "\n$inDT" - set inDT {} + set inDT "" } elseif {$inTable} { if {$inTable > 1} { puts $file </tr> set inTable 1 } - } elseif {$noFillCount == 0 || $inPRE == 1} { - puts $file {} + } elseif {($noFillCount == 0) || ($inPRE == 1)} { + puts $file "" } else { lineBreak incr noFillCount -1 @@ -644,19 +645,19 @@ proc newline {} { # Arguments: # name - Special character named in troff \x or \(xx construct. -proc char name { +proc char {name} { global file charCnt incr charCnt # puts "char: $name" - switch -exact $name { + switch -exact -- $name { \\0 { ;# \0 puts -nonewline $file " " } \\\\ { ;# \ puts -nonewline $file "\\" } - \\(+- { ;# +/- + \\\(+- { ;# +/- puts -nonewline $file "±" } \\% {} ;# \% @@ -696,7 +697,7 @@ proc SHmacro {argList {style section}} { set args [join $argList " "] if {[llength $argList] < 1} { - puts stderr "Bad .SH macro: .$name $args" + puts stderr "Bad .SH macro: .$argList" } set noFillCount 0 @@ -714,13 +715,14 @@ proc SHmacro {argList {style section}} { # control what the text proc does with text - switch $args { + switch -- $args { NAME {set textState NAME} DESCRIPTION {set textState INSERT} INTRODUCTION {set textState INSERT} "WIDGET-SPECIFIC OPTIONS" {set textState INSERT} "SEE ALSO" {set textState SEE} KEYWORDS {set textState 0} + default {} } set charCnt 0 } @@ -744,7 +746,7 @@ proc SHmacro {argList {style section}} { # # HTML limitations: 'count' in '.IP text count' is ignored. -proc IPmacro argList { +proc IPmacro {argList} { global file setTabs 0.5i @@ -754,7 +756,7 @@ proc IPmacro argList { return } # Special case for alternative mechanism for declaring bullets - if {[lindex $argList 0] eq "\\(bu"} { + if {[lindex $argList 0] eq "\\\(bu"} { nest para UL LI return } @@ -857,7 +859,7 @@ proc newPara {} { proc nest {op {listStart "NEW"} {listItem ""} } { global file nestStk inDT charCnt # puts "nest: $op $listStart $listItem" - switch $op { + switch -- $op { para { set top [lindex $nestStk end] if {$top eq "NEW"} { @@ -892,8 +894,9 @@ proc nest {op {listStart "NEW"} {listItem ""} } { } init { set nestStk NEW - set inDT {} + set inDT "" } + default {} } set charCnt 0 } @@ -908,14 +911,14 @@ proc nest {op {listStart "NEW"} {listItem ""} } { # Arguments: # fileName - Name of the file to translate. -proc do fileName { +proc do {fileName} { global file self html_dir package footer set self "[file tail $fileName].html" - set file [open "$html_dir/$package/$self" w] + set file [open [file join $html_dir $package $self] w] puts " Pass 2 -- $fileName" flush stdout initGlobals - if {[catch { eval [exec man2tcl [glob $fileName]] } msg]} { + if {[catch { eval [exec man2tcl [glob -- $fileName]] } msg]} { global errorInfo puts stderr $msg puts "in" diff --git a/tools/mkdepend.tcl b/tools/mkdepend.tcl index de5fdba..5f016b9 100644 --- a/tools/mkdepend.tcl +++ b/tools/mkdepend.tcl @@ -28,12 +28,12 @@ #============================================================================== array set mode_data {} -set mode_data(vc32) {cl -nologo -E} +set mode_data(vc32) "cl -nologo -E" set source_extensions [list .c .cpp .cxx .cc] set excludes [list] -if [info exists env(INCLUDE)] { +if {[info exists env(INCLUDE)]} { set rawExcludes [split [string trim $env(INCLUDE) ";"] ";"] foreach exclude $rawExcludes { lappend excludes [file normalize $exclude] @@ -104,7 +104,7 @@ proc readDepends {chan} { } } - set result {} + set result [list] foreach n [array names depends] { set pair [split $n "|"] lappend result [list [lindex $pair 0] [lindex $pair 1]] @@ -159,14 +159,14 @@ proc stringStartsWith {str prefix} { # the processed dependency list. proc filterExcludes {depends excludes} { - set filtered {} + set filtered [list] foreach pair $depends { set excluded 0 set file [lindex $pair 1] foreach dir $excludes { - if [stringStartsWith $file $dir] { + if {[stringStartsWith $file $dir]} { set excluded 1 break; } @@ -195,7 +195,7 @@ proc replacePrefix {file} { global srcPathList srcPathReplaceList foreach was $srcPathList is $srcPathReplaceList { - regsub $was $file $is file + regsub -- $was $file $is file } return $file } @@ -211,7 +211,7 @@ proc replacePrefix {file} { # The processed dependency pair list. proc rebaseFiles {depends} { - set rebased {} + set rebased [list] foreach pair $depends { lappend rebased [list \ [replacePrefix [lindex $pair 0]] \ @@ -336,12 +336,12 @@ proc readInputListFile {objectListFile} { proc main {} { global argc argv mode mode_data srcFileList srcPathList excludes - global remove_prefix target_prefix output env + global remove_prefix target_prefix output env errorCode set srcPathList [list] set srcFileList [list] - if {$argc == 1} {displayUsage} + if {$argc == 1} {displayUsage } # Parse mkdepend input for {set i 0} {$i < [llength $argv]} {incr i} { @@ -363,7 +363,7 @@ proc main {} { } -passthru:* { set passthru [string range $arg 10 end] - regsub -all {"} $passthru {\"} passthru + regsub -all "\"" $passthru {\"} passthru regsub -all {\\} $passthru {/} passthru } -out:* { @@ -396,15 +396,15 @@ proc main {} { set input [open |$command r] set depends [readDepends $input] set status [catch {close $input} result] - if {$status == 1 && [lindex $::errorCode 0] eq "CHILDSTATUS"} { - foreach { - pid code } $::errorCode break + if {($status == 1) && ([lindex $errorCode 0] eq "CHILDSTATUS")} { + lassign $errorCode ___ pid code if {$code == 2} { # preprocessor died a cruel death. error $result } } } err]} { - puts stderr "error ocurred: $err\n" + puts stderr "error occured: $err\n" continue } set depends [filterExcludes $depends $excludes] diff --git a/tools/regexpTestLib.tcl b/tools/regexpTestLib.tcl index d84a012..93b6f9e 100644 --- a/tools/regexpTestLib.tcl +++ b/tools/regexpTestLib.tcl @@ -17,17 +17,17 @@ proc readInputFile {} { set len [string length $line] - if {($len > 0) && ([string index $line [expr $len - 1]] == "\\")} { - if {[info exists lineArray(c$i)] == 0} { + if {($len > 0) && ([string index $line [expr {$len - 1}]] eq "\\")} { + if {![info exists lineArray(c$i)]} { set lineArray(c$i) 1 } else { incr lineArray(c$i) } - set line [string range $line 0 [expr $len - 2]] + set line [string range $line 0 [expr {$len - 2}]] append lineArray($i) $line continue } - if {[info exists lineArray(c$i)] == 0} { + if {![info exists lineArray(c$i)]} { set lineArray(c$i) 1 } else { incr lineArray(c$i) @@ -46,7 +46,7 @@ proc readInputFile {} { # proc removeAts {ls} { set len [llength $ls] - set newLs {} + set newLs [list] foreach item $ls { regsub @.* $item "" newItem lappend newLs $newItem @@ -55,39 +55,30 @@ proc removeAts {ls} { } proc convertErrCode {code} { - - set errMsg "couldn't compile regular expression pattern:" - - if {[string compare $code "INVARG"] == 0} { - return "$errMsg invalid argument to regex routine" - } elseif {[string compare $code "BADRPT"] == 0} { - return "$errMsg ?+* follows nothing" - } elseif {[string compare $code "BADBR"] == 0} { - return "$errMsg invalid repetition count(s)" - } elseif {[string compare $code "BADOPT"] == 0} { - return "$errMsg invalid embedded option" - } elseif {[string compare $code "EPAREN"] == 0} { - return "$errMsg unmatched ()" - } elseif {[string compare $code "EBRACE"] == 0} { - return "$errMsg unmatched {}" - } elseif {[string compare $code "EBRACK"] == 0} { - return "$errMsg unmatched \[\]" - } elseif {[string compare $code "ERANGE"] == 0} { - return "$errMsg invalid character range" - } elseif {[string compare $code "ECTYPE"] == 0} { - return "$errMsg invalid character class" - } elseif {[string compare $code "ECOLLATE"] == 0} { - return "$errMsg invalid collating element" - } elseif {[string compare $code "EESCAPE"] == 0} { - return "$errMsg invalid escape sequence" - } elseif {[string compare $code "BADPAT"] == 0} { - return "$errMsg invalid regular expression" - } elseif {[string compare $code "ESUBREG"] == 0} { - return "$errMsg invalid backreference number" - } elseif {[string compare $code "IMPOSS"] == 0} { - return "$errMsg can never match" - } + array set msgCode { + BADBR "invalid repetition count(s)" + BADOPT "invalid embedded option" + BADPAT "invalid regular expression" + BADRPT "?+* follows nothing" + EBRACE "unmatched {}" + EBRACK "unmatched \[\]" + ECOLLATE "invalid collating element" + ECTYPE "invalid character class" + EESCAPE "invalid escape sequence" + EPAREN "unmatched ()" + ERANGE "invalid character range" + ESUBREG "invalid backreference number" + IMPOSS "can never match" + INVARG "invalid argument to regex routine" + } + + set errMsg "couldn't compile regular expression pattern:" + + if {[info exists msgCode($code)]} { + return "$errMsg $msgCode($code)" + } else { return "$errMsg $code" + } } proc writeOutputFile {numLines fcn} { @@ -165,14 +156,12 @@ proc writeOutputFile {numLines fcn} { proc convertTestLine {currentLine len lineNum srcLineNum} { regsub -all {(?b)\\} $currentLine {\\\\} currentLine - set re [lindex $currentLine 0] - set flags [lindex $currentLine 1] - set str [lindex $currentLine 2] + lassign $currentLine re flags str # based on flags, decide whether to skip the test if {[findSkipFlag $flags]} { - regsub -all {\[|\]|\(|\)|\{|\}|\#} $currentLine {\&} line + regsub -all {\[|\]|\(|\)|\{|\}|#} $currentLine "&" line set msg "\# skipping char mapping test from line $srcLineNum\n" append msg "print \{... skip test from line $srcLineNum: $line\}" return $msg @@ -181,21 +170,21 @@ proc convertTestLine {currentLine len lineNum srcLineNum} { # perform mapping if '=' flag exists set noBraces 0 - if {[regexp {=|>} $flags] == 1} { - regsub -all {_} $currentLine {\\ } currentLine - regsub -all {A} $currentLine {\\007} currentLine - regsub -all {B} $currentLine {\\b} currentLine - regsub -all {E} $currentLine {\\033} currentLine - regsub -all {F} $currentLine {\\f} currentLine - regsub -all {N} $currentLine {\\n} currentLine + if {[regexp "=|>" $flags] == 1} { + regsub -all "_" $currentLine {\\ } currentLine + regsub -all "A" $currentLine {\\007} currentLine + regsub -all "B" $currentLine {\\b} currentLine + regsub -all "E" $currentLine {\\033} currentLine + regsub -all "F" $currentLine {\\f} currentLine + regsub -all "N" $currentLine {\\n} currentLine # if and \r substitutions are made, do not wrap re, flags, # str, and result in braces - set noBraces [regsub -all {R} $currentLine {\\\u000D} currentLine] - regsub -all {T} $currentLine {\\t} currentLine - regsub -all {V} $currentLine {\\v} currentLine - if {[regexp {=} $flags] == 1} { + set noBraces [regsub -all "R" $currentLine {\\\u000D} currentLine] + regsub -all "T" $currentLine {\\t} currentLine + regsub -all "V" $currentLine {\\v} currentLine + if {[regexp "=" $flags] == 1} { set re [lindex $currentLine 0] } set str [lindex $currentLine 2] @@ -204,16 +193,16 @@ proc convertTestLine {currentLine len lineNum srcLineNum} { # find the test result - set numVars [expr $len - 3] - set vars {} - set vals {} + set numVars [expr {$len - 3}] + set vars "" + set vals "" set result 0 set v 0 - if {[regsub {\*} "$flags" "" newFlags] == 1} { + if {[regsub {\*} $flags "" newFlags] == 1} { # an error is expected - if {[string compare $str "EMPTY"] == 0} { + if {$str eq "EMPTY"} { # empty regexp is not an error # skip this test @@ -224,7 +213,7 @@ proc convertTestLine {currentLine len lineNum srcLineNum} { } elseif {$numVars > 0} { # at least 1 match is made - if {[regexp {s} $flags] == 1} { + if {[regexp "s" $flags] == 1} { set result "\{0 1\}" } else { while {$v < $numVars} { diff --git a/tools/tcl.hpj.in b/tools/tcl.hpj.in index 3bdccbe..3ad389f 100644 --- a/tools/tcl.hpj.in +++ b/tools/tcl.hpj.in @@ -1,19 +1,20 @@ -; This file is maintained by HCW. Do not modify this file directly. - -[OPTIONS] -HCW=0 -LCID=0x409 0x0 0x0 ;English (United States) -REPORT=Yes -TITLE=Tcl/Tk Reference Manual -CNT=tcl86.cnt -COPYRIGHT=Copyright © 2000 Ajuba Solutions -HLP=tcl86.hlp - -[FILES] -tcl.rtf - -[WINDOWS] -main="Tcl/Tk Reference Manual",,0 - -[CONFIG] -BrowseButtons() +; This file is maintained by HCW. Do not modify this file directly.
+
+[OPTIONS]
+HCW=0
+LCID=0x409 0x0 0x0 ;English (United States)
+REPORT=Yes
+TITLE=Tcl/Tk Reference Manual
+CNT=tcl86.cnt
+COPYRIGHT=Copyright © 2000 Ajuba Solutions
+HLP=tcl86.hlp
+
+[FILES]
+tcl.rtf
+
+[WINDOWS]
+main="Tcl/Tk Reference Manual",,0
+
+[CONFIG]
+BrowseButtons()
+
diff --git a/tools/tclZIC.tcl b/tools/tclZIC.tcl index 005919a..1c58dd5 100755 --- a/tools/tclZIC.tcl +++ b/tools/tclZIC.tcl @@ -47,15 +47,15 @@ set maxyear 2100 # Determine how big a wide integer is. -set MAXWIDE [expr {wide(1)}] -while 1 { - set next [expr {wide($MAXWIDE + $MAXWIDE + 1)}] +set MAXWIDE [expr { wide (1) }] +while {1} { + set next [expr { wide ($MAXWIDE + $MAXWIDE + 1) }] if {$next < 0} { break } set MAXWIDE $next } -set MINWIDE [expr {-$MAXWIDE-1}] +set MINWIDE [expr {-$MAXWIDE - 1}] #---------------------------------------------------------------------- # @@ -156,7 +156,7 @@ proc loadZIC {fileName} { # Break a line of input into words. - regsub {\s*(\#.*)?$} $line {} line + regsub {\s*(#.*)?$} $line {} line if {$line eq ""} { continue } @@ -358,7 +358,7 @@ proc parseON {on} { # third possibility - lastWeekday - field 5 last([[:alpha:]]+) )$ - } $on -> dom1 wday2 dir2 num2 wday3]} { + } $on ___ dom1 wday2 dir2 num2 wday3]} { error "can't parse ON field \"$on\"" } if {$dom1 ne ""} { @@ -442,6 +442,7 @@ proc onWeekdayInMonth {dayOfWeek relation dayOfMonth year month} { return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \ [expr {[dict get $date julianDay] + 6}]] } + default {} } } @@ -497,20 +498,14 @@ proc onLastWeekdayInMonth {dayOfWeek year month} { #---------------------------------------------------------------------- proc parseTOD {tod} { - if {![regexp -expanded { - ^ - ([[:digit:]]{1,2}) # field 1 - hour - (?: - :([[:digit:]]{2}) # field 2 - minute - (?: - :([[:digit:]]{2}) # field 3 - second - )? - )? - (?: - ([wsugz]) # field 4 - type indicator - )? - } $tod -> hour minute second ind]} { - puts stderr "$fileName:$lno:can't parse time field \"$tod\"" + # field 1 - hour + # field 2 - minute + # field 3 - second + # field 4 - type indicator + if {![regexp -expanded {^([[:digit:]]{1,2})(?::([[:digit:]]{2})(?::([[:digit:]]{2}))?)?(?:([wsugz]))?} $tod ___ hour minute second ind]} { + # Undefined vars 'fileName' and 'lno' !!! + # puts stderr "$fileName:$lno:can't parse time field \"$tod\"" + puts stderr "can't parse time field \"$tod\"" incr errorCount } scan $hour %d hour @@ -527,7 +522,7 @@ proc parseTOD {tod} { if {$ind eq ""} { set ind w } - return [list [expr {($hour * 60 + $minute) * 60 + $second}] $ind] + return [list [expr {((($hour * 60) + $minute) * 60) + $second}] $ind] } #---------------------------------------------------------------------- @@ -558,8 +553,10 @@ proc parseOffsetTime {offset} { :([[:digit:]]{2}) # field 4 - second )? )? - } $offset -> signum hour minute second]} { - puts stderr "$fileName:$lno:can't parse offset time \"$offset\"" + } $offset ___ signum hour minute second]} { + # Undefined vars 'fileName' and 'lno' !!! + # puts stderr "$fileName:$lno:can't parse offset time \"$offset\"" + puts stderr "can't parse offset time \"$offset\"" incr errorCount } append signum 1 @@ -574,7 +571,7 @@ proc parseOffsetTime {offset} { } else { set second 0 } - return [expr {(($hour * 60 + $minute) * 60 + $second) * $signum}] + return [expr {(((($hour * 60) + $minute) * 60) + $second) * $signum}] } @@ -723,7 +720,7 @@ proc parseUntil {words} { if {![string is integer $year]} { error "can't parse UNTIL field \"$words\"" } - if {![info exists firstYear] || $year < $firstYear} { + if {(![info exists firstYear]) || ($year < $firstYear)} { set firstYear $year } } else { @@ -919,8 +916,8 @@ proc applyRules {ruleSet year startSecs stdGMTOffset DSTOffset nextGMTOffset set origStartSecs $startSecs - while {($until ne "" && $startSecs < $untilSecs) - || ($until eq "" && ($nSunsetRules > 0 || $year < $maxyear))} { + while {(($until ne "") && ($startSecs < $untilSecs)) || + (($until eq "") && (($nSunsetRules > 0) || ($year < $maxyear)))} { set remainingRules $currentRules while {[llength $remainingRules] > 0} { @@ -937,14 +934,13 @@ proc applyRules {ruleSet year startSecs stdGMTOffset DSTOffset nextGMTOffset # Test if the rule is in effect. - if { - $earliestSecs > $startSecs && - ($until eq "" || $earliestSecs < $untilSecs) + if {($earliestSecs > $startSecs) && + (($until eq "") || ($earliestSecs < $untilSecs)) } { # Test if the initial transition has been done. # If not, do it now. - if {!$didTransitionIn && $earliestSecs > $origStartSecs} { + if {(!$didTransitionIn) && ($earliestSecs > $origStartSecs)} { set nm [convertNamePattern $namePattern $prevLetter] lappend points \ $origStartSecs \ @@ -1026,16 +1022,16 @@ proc applyRules {ruleSet year startSecs stdGMTOffset DSTOffset nextGMTOffset proc divideRules {ruleSet year} { variable rules - set currentRules {} + set currentRules [list] set nSunsetRules 0 foreach { fromYear toYear yearType monthIn daySpecOn timeAt save letter } $rules($ruleSet) { - if {$toYear ne "maximum" && $year > $toYear} { + if {($toYear ne "maximum") && ($year > $toYear)} { # ignore - rule is in the past } else { - if {$fromYear eq "minimum" || $fromYear <= $year} { + if {($fromYear eq "minimum") || ($fromYear <= $year)} { lappend currentRules $fromYear $toYear $yearType $monthIn \ $daySpecOn $timeAt $save $letter } @@ -1079,7 +1075,7 @@ proc findEarliestRule {remainingRules year stdGMTOffset DSTOffset} { } $remainingRules { lappend daySpecOn $year $monthIn set dayIn [eval $daySpecOn] - set secs [expr {wide(86400) * wide($dayIn) - 210866803200}] + set secs [expr {( ( wide (86400) ) * ( wide ($dayIn) ) ) - 210866803200}] set secs [convertTimeOfDay $secs \ $stdGMTOffset $DSTOffset {*}$timeAt] if {$secs < $earliest} { @@ -1112,7 +1108,7 @@ proc findEarliestRule {remainingRules year stdGMTOffset DSTOffset} { #---------------------------------------------------------------------- proc convertNamePattern {pattern flag} { - if {[regexp {(.*)/(.*)} $pattern -> standard daylight]} { + if {[regexp {(.*)/(.*)} $pattern ___ standard daylight]} { if {$flag ne ""} { set pattern $daylight } else { @@ -1148,7 +1144,7 @@ proc convertNamePattern {pattern flag} { proc convertTimeOfDay {seconds stdGMTOffset DSTOffset timeOfDay flag} { incr seconds $timeOfDay - switch -exact $flag { + switch -exact -- $flag { g - u - z { } w { @@ -1158,6 +1154,7 @@ proc convertTimeOfDay {seconds stdGMTOffset DSTOffset timeOfDay flag} { s { incr seconds [expr {-$stdGMTOffset}] } + default {} } return $seconds } @@ -1205,7 +1202,7 @@ proc processTimeZone {zoneName zoneData} { lassign $startTime year month dayRule timeOfDay lappend dayRule $year $month set startDay [eval $dayRule] - set secs [expr {wide(86400) * wide($startDay) -210866803200}] + set secs [expr { ( wide (86400) * wide ($startDay) ) - 210866803200}] set secs [convertTimeOfDay $secs \ $stdGMTOffset $DSTOffset {*}$timeOfDay] } @@ -1236,7 +1233,7 @@ proc processTimeZone {zoneName zoneData} { #---------------------------------------------------------------------- proc writeZones {outDir} { - variable zones + variable zones argv0 # Walk the zones @@ -1265,8 +1262,8 @@ proc writeZones {outDir} { # Write the data to the information file set f [open $fileName w] - fconfigure $f -translation lf - puts $f "\# created by $::argv0 - do not edit" + chan configure $f -translation lf + puts $f "\# created by $argv0 - do not edit" puts $f "" puts $f [list set TZData(:$zoneName) $data] close $f @@ -1292,7 +1289,7 @@ proc writeZones {outDir} { # Creates a file for each link. proc writeLinks {outDir} { - variable links + variable links argv0 # Walk the links @@ -1318,11 +1315,11 @@ proc writeLinks {outDir} { # Write the file set f [open $fileName w] - fconfigure $f -translation lf - puts $f "\# created by $::argv0 - do not edit" - puts $f $ifCmd - puts $f $setCmd - close $f + chan configure $f -translation lf + chan puts $f "\# created by $argv0 - do not edit" + chan puts $f $ifCmd + chan puts $f $setCmd + chan close $f } return diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl index d02bcb6..bc24f0c 100644 --- a/tools/tcltk-man2html-utils.tcl +++ b/tools/tcltk-man2html-utils.tcl @@ -10,8 +10,8 @@ set ::manual(report-level) 1 proc manerror {msg} { global manual - set name {} - set subj {} + set name "" + set subj "" set procname [lindex [info level -1] 0] if {[info exists manual(name)]} { set name $manual(name) @@ -40,7 +40,7 @@ proc fatal {msg} { ## templating ## proc indexfile {} { - if {[info exists ::TARGET] && $::TARGET eq "devsite"} { + if {[info exists ::TARGET] && ($::TARGET eq "devsite")} { return "index.tml" } else { return "contents.htm" @@ -102,7 +102,7 @@ proc htmlhead {title header args} { ## ## parsing ## -proc unquote arg { +proc unquote {arg} { return [string map [list \" {}] $arg] } @@ -149,7 +149,7 @@ proc process-text {text} { {\fP} {\fR} \ {\.} . \ {\(bu} "•" \ - {\*(qo} "ô" \ + {\*\(qo} "ô" \ ] lappend charmap {\-\|\-} -- ; # two hyphens lappend charmap {\-} - ; # a hyphen @@ -244,15 +244,15 @@ proc next-op-is {op restname} { proc backup-text {n} { global manual - if {$manual(text-pointer)-$n >= 0} { + if {($manual(text-pointer) - $n) >= 0} { incr manual(text-pointer) -$n } } -proc match-text args { +proc match-text {args} { global manual set nargs [llength $args] - if {$manual(text-pointer) + $nargs > $manual(text-length)} { + if {($manual(text-pointer) + $nargs) > $manual(text-length)} { return 0 } set nback 0 @@ -292,7 +292,7 @@ proc match-text args { proc expand-next-text {n} { global manual return [join [lrange $manual(text) $manual(text-pointer) \ - [expr {$manual(text-pointer)+$n-1}]] \n\n] + [expr {($manual(text-pointer) + $n) - 1}]] \n\n] } ## @@ -320,11 +320,11 @@ proc option-toc {name class switch} { global manual # Special case handling, oh we hate it but must do it if {[string match "*OPTIONS" $manual(section)]} { - if {$manual(name) ne "ttk_widget" && ($manual(name) ne "ttk_entry" || - ![string match validate* $name])} { + if {($manual(name) ni "ttk_widget ttk_entry") || + (![string match "validate*" $name])} { # link the defined option into the long table of contents set link [long-toc "$switch, $name, $class"] - regsub -- "$switch, $name, $class" $link "$switch" link + regsub -- "$switch, $name, $class" $link $switch link return $link } } elseif {"$manual(name):$manual(section)" ne "options:DESCRIPTION"} { @@ -406,6 +406,8 @@ proc output-widget-options {rest} { while {[more-text]} { set line [next-text] if {[is-a-directive $line]} { + set code "" + set rest "" split-directive $line code rest switch -exact -- $code { .RE { @@ -435,6 +437,7 @@ proc output-widget-options {rest} { ## proc output-RS-list {} { global manual + set rest "" if {[next-op-is .IP rest]} { output-IP-list .RS .IP $rest if {[match-text .RE .sp .RS @rest .IP @rest2]} { @@ -487,7 +490,7 @@ proc output-IP-list {context code rest} { set line [next-text] if {[is-a-directive $line]} { split-directive $line code rest - if {$code eq ".IP" && $rest eq {}} { + if {($code eq ".IP") && ($rest eq "")} { man-puts "<P>" continue } @@ -504,7 +507,7 @@ proc output-IP-list {context code rest} { man-puts </DL> } else { # labelled list, make contents - if {$context ne ".SH" && $context ne ".SS"} { + if {$context ni ".SH .SS"} { man-puts <P> } set dl "<DL class=\"[string tolower $manual(section)]\">" @@ -535,9 +538,9 @@ proc output-IP-list {context code rest} { } if {$manual(section) eq "ARGUMENTS"} { man-puts "$para<DT>$rest<DD>" - } elseif {[regexp {^\[([\da-f]+)\]$} $rest -> value]} { + } elseif {[regexp {^\[([\da-f]+)\]$} $rest ___ value]} { man-puts "$para<LI value=\"$value\">" - } elseif {[regexp {^\(?([\da-f]+)\)$} $rest -> value]} { + } elseif {[regexp {^\(?([\da-f]+)\)$} $rest ___ value]} { man-puts "$para<LI value=\"$value\">" } elseif {"•" eq $rest} { man-puts "$para<LI>" @@ -576,7 +579,7 @@ proc output-IP-list {context code rest} { if {!$accept_RE} { man-puts "$enddl<P>$rest$dl" backup-text 1 - set para {} + set para "" break } man-puts "<P>$rest" @@ -622,13 +625,13 @@ proc output-IP-list {context code rest} { proc output-name {line} { global manual # split name line into pieces - regexp {^([^-]+) - (.*)$} [regsub -all {[ \n\r\t]+} $line " "] -> head tail + regexp {^([^-]+) - (.*)$} [regsub -all {[ \n\r\t]+} $line " "] ___ head tail # output line to manual page untouched man-puts "$head — $tail" # output line to long table of contents lappend manual(section-toc) "<DL><DD>$head — $tail</DD></DL>" # separate out the names for future reference - foreach name [split $head ,] { + foreach name [split $head ","] { set name [string trim $name] if {[llength $name] > 1} { manerror "name has a space: {$name}\nfrom: $line" @@ -677,11 +680,11 @@ proc cross-reference {ref} { if {![info exists manual(name-$lref)]} { foreach name $ensemble_commands { if { - [regexp "^$name \[a-z0-9]*\$" $lref] && - [info exists manual(name-$name)] && - $mantail ne "$name.n" && - (![info exists exclude_refs_map($mantail)] || - $manual(name-$name) ni $exclude_refs_map($mantail)) + [regexp "^$name \[a-z0-9\]*\$" $lref] && + [info exists manual(name-$name)] && + ($mantail ne "$name.n") && + ((![info exists exclude_refs_map($mantail)]) || + ($manual(name-$name) ni $exclude_refs_map($mantail))) } { return "<A HREF=\"../$manual(name-$name).htm\">$ref</A>" } @@ -705,18 +708,16 @@ proc cross-reference {ref} { ## if {[llength $manref] > 1} { set tcl_i [lsearch -glob $manref *TclCmd*] - if {$tcl_i >= 0 && $manual(wing-file) eq "TclCmd" - || $manual(wing-file) eq "TclLib"} { + if {($tcl_i >= 0) && ($manual(wing-file) in "TclCmd TclLib")} { set tcl_ref [lindex $manref $tcl_i] return "<A HREF=\"../$tcl_ref.htm\">$ref</A>" } set tk_i [lsearch -glob $manref *TkCmd*] - if {$tk_i >= 0 && $manual(wing-file) eq "TkCmd" - || $manual(wing-file) eq "TkLib"} { + if {($tk_i >= 0) && ($manual(wing-file) in "TkCmd TkLib")} { set tk_ref [lindex $manref $tk_i] return "<A HREF=\"../$tk_ref.htm\">$ref</A>" } - if {$lref eq "exit" && $mantail eq "tclsh.1" && $tcl_i >= 0} { + if {($lref eq "exit") && ($mantail eq "tclsh.1") && ($tcl_i >= 0)} { set tcl_ref [lindex $manref $tcl_i] return "<A HREF=\"../$tcl_ref.htm\">$ref</A>" } @@ -731,15 +732,13 @@ proc cross-reference {ref} { set following_word [lindex [regexp -inline {\S+} $tail] 0] foreach {this that} $exclude_when_followed_by_map($mantail) { # only a ref if $this is not followed by $that - if {$lref eq $this && [string match $that* $following_word]} { + if {($lref eq $this) && [string match "$that*" $following_word]} { return $ref } } } - if { - [info exists exclude_refs_map($mantail)] - && $lref in $exclude_refs_map($mantail) - } { + if {[info exists exclude_refs_map($mantail)] && + ($lref in $exclude_refs_map($mantail))} { return $ref } ## @@ -764,7 +763,7 @@ proc insert-cross-references {text} { global manual set result "" - while 1 { + while {1} { ## ## we identify cross references by: ## ``quotation'' @@ -817,7 +816,7 @@ proc insert-cross-references {text} { } append result [string range $text 0 $offset(end-anchor)] set text [string range $text[set text ""] \ - [expr {$offset(end-anchor)+1}] end] + [expr {$offset(end-anchor) + 1}] end] continue } quote { @@ -829,21 +828,22 @@ proc insert-cross-references {text} { } switch -exact -- $invert([lindex $offsets 1]) { end-quote { - append result [string range $text 0 [expr {$offset(quote)-1}]] - set body [string range $text [expr {$offset(quote)+2}] \ - [expr {$offset(end-quote)-1}]] + append result [string range $text 0 [expr {$offset(quote) - 1}]] + set body [string range $text [expr {$offset(quote) + 2}] \ + [expr {$offset(end-quote) - 1}]] set text [string range $text[set text ""] \ - [expr {$offset(end-quote)+2}] end] + [expr {$offset(end-quote) + 2}] end] append result `` [cross-reference $body] '' continue } bold - anchor { append result [string range $text \ - 0 [expr {$offset(end-quote)+1}]] + 0 [expr {$offset(end-quote) + 1}]] set text [string range $text[set text ""] \ - [expr {$offset(end-quote)+2}] end] + [expr {$offset(end-quote) + 2}] end] continue } + default {} } return [reference-error "Uncaught quote case" $text] } @@ -857,20 +857,20 @@ proc insert-cross-references {text} { switch -exact -- $invert([lindex $offsets 1]) { url - end-bold { append result \ - [string range $text 0 [expr {$offset(bold)-1}]] - set body [string range $text [expr {$offset(bold)+3}] \ - [expr {$offset(end-bold)-1}]] + [string range $text 0 [expr {$offset(bold) - 1}]] + set body [string range $text [expr {$offset(bold) + 3}] \ + [expr {$offset(end-bold) - 1}]] set text [string range $text[set text ""] \ - [expr {$offset(end-bold)+4}] end] + [expr {$offset(end-bold) + 4}] end] regsub {http://[\w/.]+} $body {<A HREF="&">&</A>} body append result <B> [cross-reference $body] </B> continue } anchor { append result \ - [string range $text 0 [expr {$offset(end-bold)+3}]] + [string range $text 0 [expr {$offset(end-bold) + 3}]] set text [string range $text[set text ""] \ - [expr {$offset(end-bold)+4}] end] + [expr {$offset(end-bold) + 4}] end] continue } default { @@ -880,34 +880,35 @@ proc insert-cross-references {text} { } c.tk - c.ttk - c.tcl - c.tdbc - c.itcl { append result [string range $text 0 \ - [expr {[lindex $offsets 0]-1}]] + [expr {[lindex $offsets 0] - 1}]] regexp -indices -start [lindex $offsets 0] {\w+} $text range set body [string range $text {*}$range] set text [string range $text[set text ""] \ - [expr {[lindex $range 1]+1}] end] + [expr {[lindex $range 1] + 1}] end] append result [cross-reference $body] continue } Tcl1 - Tcl2 { set off [lindex $offsets 0] - append result [string range $text 0 [expr {$off-1}]] - set text [string range $text[set text ""] [expr {$off+3}] end] + append result [string range $text 0 [expr {$off - 1}]] + set text [string range $text[set text ""] [expr {$off + 3}] end] append result [cross-reference Tcl] continue } url { set off [lindex $offsets 0] - append result [string range $text 0 [expr {$off-1}]] + append result [string range $text 0 [expr {$off - 1}]] regexp -indices -start $off {http://[\w/.]+} $text range set url [string range $text {*}$range] append result "<A HREF=\"$url\">" $url "</A>" set text [string range $text[set text ""] \ - [expr {[lindex $range 1]+1}] end] + [expr {[lindex $range 1] + 1}] end] continue } end-anchor - end-bold - end-quote { return [reference-error "Out of place $invert([lindex $offsets 0])" $text] } + default {} } } } @@ -928,7 +929,7 @@ proc output-directive {line} { # announce the subject set manual(section) $rest # start our own stack of stuff - set manual($manual(name)-$manual(section)) {} + set manual($manual(name)-$manual(section)) "" lappend manual(has-$manual(section)) $manual(name) if {$code ne ".SS"} { man-puts "<H3>[long-toc $manual(section)]</H3>" @@ -939,7 +940,7 @@ proc output-directive {line} { # some sections can be processed in their own loops switch -exact -- [string index $code end]:$manual(section) { H:NAME { - set names {} + set names [list] while {1} { set line [next-text] if {[is-a-directive $line]} { @@ -981,8 +982,8 @@ proc output-directive {line} { backup-text 1 break } - foreach more [split $more \n] { - regexp {^(\s*)(.*)} $more -> spaces more + foreach more [split $more "\n"] { + regexp {^(\s*)(.*)} $more ___ spaces more set spaces [string map {" " " "} $spaces] if {[string length $spaces]} { set spaces <TT>$spaces</TT> @@ -1004,11 +1005,11 @@ proc output-directive {line} { } set more [next-text] if {[is-a-directive $more]} { - manerror "$more" + manerror $more backup-text 1 return } - set nmore {} + set nmore [list] foreach cr [split $more ,] { set cr [string trim $cr] if {![regexp {^<B>.*</B>$} $cr]} { @@ -1031,7 +1032,7 @@ proc output-directive {line} { } set more [next-text] if {[is-a-directive $more]} { - manerror "$more" + manerror $more backup-text 1 return } @@ -1047,6 +1048,7 @@ proc output-directive {line} { } return } + default {} } if {[next-op-is .IP rest]} { output-IP-list $code .IP $rest @@ -1059,8 +1061,8 @@ proc output-directive {line} { } .SO { # When there's a sequence of multiple .SO chunks, process into one - set optslist {} - while 1 { + set optslist [list] + while {1} { if {[match-text @stuff .SE]} { foreach opt [split $stuff \n\t] { lappend optslist [list $opt $rest] @@ -1206,17 +1208,17 @@ proc merge-copyrights {l1 l2} { set re3 {^(\d+)-(\d+) +(?:by +)?(\w.*)$} ;# from to who set re4 {^(\d+), *(\d+) +(?:by +)?(\w.*)$} ;# date1 date2 who foreach copyright [concat $l1 $l2] { - if {[regexp -nocase -- $re1 $copyright -> info]} { + if {[regexp -nocase -- $re1 $copyright ___ info]} { set info [string trimright $info ". "] ; # remove extra period - if {[regexp -- $re2 $info -> date who]} { + if {[regexp -- $re2 $info ___ date who]} { lappend dates($who) $date continue - } elseif {[regexp -- $re3 $info -> from to who]} { + } elseif {[regexp -- $re3 $info ___ from to who]} { for {set date $from} {$date <= $to} {incr date} { lappend dates($who) $date } continue - } elseif {[regexp -- $re3 $info -> date1 date2 who]} { + } elseif {[regexp -- $re3 $info ___ date1 date2 who]} { lappend dates($who) $date1 $date2 continue } @@ -1225,7 +1227,7 @@ proc merge-copyrights {l1 l2} { } foreach who [array names dates] { set list [lsort -dictionary $dates($who)] - if {[llength $list] == 1 || [lindex $list 0] eq [lrange $list end end]} { + if {([llength $list] == 1) || ([lindex $list 0] eq [lrange $list end end])} { lappend merge "Copyright © [lindex $list 0] $who" } else { lappend merge "Copyright © [lindex $list 0]-[lrange $list end end] $who" @@ -1251,13 +1253,13 @@ proc make-manpage-section {outputDir sectionDescriptor} { manual(wing-name) \ manual(wing-file) \ manual(wing-description) - set manual(wing-copyrights) {} + set manual(wing-copyrights) "" makedirhier $outputDir/$manual(wing-file) - set manual(wing-toc-fp) [open $outputDir/$manual(wing-file)/[indexfile] w] + set manual(wing-toc-fp) [open [file join $outputDir $manual(wing-file) [indexfile]] w] # whistle puts stderr "scanning section $manual(wing-name)" # put the entry for this section into the short table of contents - if {[regexp {^(.+), version (.+)$} $manual(wing-name) -> name version]} { + if {[regexp {^(.+), version (.+)$} $manual(wing-name) ___ name version]} { puts $manual(short-toc-fp) "<DT><A HREF=\"$manual(wing-file)/[indexfile]\" TITLE=\"version $version\">$name</A></DT><DD>$manual(wing-description)</DD>" } else { puts $manual(short-toc-fp) "<DT><A HREF=\"$manual(wing-file)/[indexfile]\">$manual(wing-name)</A></DT><DD>$manual(wing-description)</DD>" @@ -1266,13 +1268,13 @@ proc make-manpage-section {outputDir sectionDescriptor} { puts $manual(wing-toc-fp) [htmlhead $manual(wing-name) \ $manual(wing-name) $overall_title "../[indexfile]"] # initialize the short table of contents for this section - set manual(wing-toc) {} + set manual(wing-toc) "" # initialize the man directory for this section makedirhier $outputDir/$manual(wing-file) # initialize the long table of contents for this section set manual(long-toc-n) 1 # get the manual pages for this section - set manual(pages) [lsort -dictionary [glob -nocomplain $manual(wing-glob)]] + set manual(pages) [lsort -dictionary [glob -nocomplain -- $manual(wing-glob)]] # Some pages have to go first so that their links override others foreach pat $process_first_patterns { set n [lsearch -glob $manual(pages) $pat] @@ -1294,7 +1296,7 @@ proc make-manpage-section {outputDir sectionDescriptor} { } set manual(tail) [file tail $manual(page)] set manual(name) [file root $manual(tail)] - set manual(section) {} + set manual(section) "" if {$manual(name) in $excluded_pages} { # obsolete if {!$verbose} { @@ -1304,20 +1306,20 @@ proc make-manpage-section {outputDir sectionDescriptor} { continue } set manual(infp) [open $manual(page)] - set manual(text) {} - set manual(partial-text) {} + set manual(text) "" + set manual(partial-text) "" foreach p {.RS .DS .CS .SO} { set manual($p) 0 } - set manual(stack) {} - set manual(section) {} - set manual(section-toc) {} + set manual(stack) "" + set manual(section) "" + set manual(section-toc) "" set manual(section-toc-n) 1 - set manual(copyrights) {} + set manual(copyrights) "" lappend manual(all-pages) $manual(wing-file)/$manual(tail) lappend manual(all-page-domains) $manual(wing-name) manreport 100 $manual(name) - while {[gets $manual(infp) line] >= 0} { + while {[chan gets $manual(infp) line] >= 0} { manreport 100 $line if {[regexp {^[`'][/\\]} $line]} { if {[regexp {Copyright (?:\(c\)|\\\(co).*$} $line copyright]} { @@ -1326,10 +1328,11 @@ proc make-manpage-section {outputDir sectionDescriptor} { # comment continue } - if {"$line" eq {'}} { + if {$line eq "'"} { # comment continue } + lassign "" code rest if {![parse-directive $line code rest]} { addbuffer $line continue @@ -1340,6 +1343,7 @@ proc make-manpage-section {outputDir sectionDescriptor} { # ignore continue } + default {} } switch -exact -- $code { .SH - .SS { @@ -1562,24 +1566,24 @@ proc make-manpage-section {outputDir sectionDescriptor} { } } set perline [expr {118 / $width}] - set nrows [expr {([llength $manual(wing-toc)]+$perline)/$perline}] + set nrows [expr {([llength $manual(wing-toc)] + $perline) / $perline}] set n 0 - catch {unset rows} + unset -nocomplain rows foreach name [lsort -dictionary $manual(wing-toc)] { set tail $manual(name-$name) if {[llength $tail] > 1} { manerror "$name is defined in more than one file: $tail" - set tail [lindex $tail [expr {[llength $tail]-1}]] + set tail [lindex $tail [expr {[llength $tail] - 1}]] } set tail [file tail $tail] if {[info exists manual(tooltip-$manual(wing-file)/$tail.htm)]} { set tooltip $manual(tooltip-$manual(wing-file)/$tail.htm) set tooltip [string map {[ {\[} ] {\]} $ {\$} \\ \\\\} $tooltip] regsub {^[^-]+-\s*(.)} $tooltip {[string totitle \1]} tooltip - append rows([expr {$n%$nrows}]) \ + append rows([expr {$n % $nrows}]) \ "<td> <a href=\"$tail.htm\" title=\"[subst $tooltip]\">$name</a> </td>" } else { - append rows([expr {$n%$nrows}]) \ + append rows([expr {$n % $nrows}]) \ "<td> <a href=\"$tail.htm\">$name</a> </td>" } incr n diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index f392bce..9772ac4 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -40,8 +40,8 @@ proc parse_command_line {} { # Set defaults based on original code. set tcltkdir ../.. - set tkdir {} - set tcldir {} + set tkdir "" + set tcldir "" set webdir ../html set build_tcl 0 set build_tk 0 @@ -110,8 +110,8 @@ proc parse_command_line {} { } } - if {!$build_tcl && !$build_tk} { - set build_tcl 1; + if {(!$build_tcl) && (!$build_tk)} { + set build_tcl 1 set build_tk 1 } @@ -161,7 +161,7 @@ proc capitalize {string} { ## ## Returns the style sheet. ## -proc css-style args { +proc css-style {args} { upvar 1 style style set body [uplevel 1 [list subst [lindex $args end]]] set tokens [join [lrange $args 0 end-1] ", "] @@ -256,24 +256,24 @@ proc make-man-pages {html args} { global excluded_pages forced_index_pages process_first_patterns makedirhier $html - set cssfd [open $html/$::CSSFILE w] + set cssfd [open [file join $html $::CSSFILE] w] puts $cssfd [css-stylesheet] close $cssfd set manual(short-toc-n) 1 - set manual(short-toc-fp) [open $html/[indexfile] w] + set manual(short-toc-fp) [open [file join $html [indexfile]] w] puts $manual(short-toc-fp) [htmlhead $overall_title $overall_title] puts $manual(short-toc-fp) "<DL class=\"keylist\">" - set manual(merge-copyrights) {} + set manual(merge-copyrights) "" foreach arg $args { # preprocess to set up subheader for the rest of the files if {![llength $arg]} { continue } - lassign $arg -> name file - if {[regexp {(.*)(?: Package)? Commands(?:, version .*)?} $name -> pkg]} { + lassign $arg ___ name file + if {[regexp {(.*)(?: Package)? Commands(?:, version .*)?} $name ___ pkg]} { set name "$pkg Commands" - } elseif {[regexp {(.*)(?: Package)? C API(?:, version .*)?} $name -> pkg]} { + } elseif {[regexp {(.*)(?: Package)? C API(?:, version .*)?} $name ___ pkg]} { set name "$pkg C API" } lappend manual(subheader) $name $file @@ -295,14 +295,14 @@ proc make-man-pages {html args} { if {!$verbose} { puts stderr "Assembling index" } - file delete -force -- $html/Keywords - makedirhier $html/Keywords - set keyfp [open $html/Keywords/[indexfile] w] + file delete -force -- [file join $html Keywords] + makedirhier [file join $html Keywords] + set keyfp [open [file join $html Keywords [indexfile]] w] puts $keyfp [htmlhead "$tcltkdesc Keywords" "$tcltkdesc Keywords" \ $overall_title "../[indexfile]"] - set letters {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} + set letters [list 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] # Create header first - set keyheader {} + set keyheader [list] foreach a $letters { set keys [array names manual "keyword-\[[string totitle $a$a]\]*"] if {[llength $keys]} { @@ -320,7 +320,7 @@ proc make-man-pages {html args} { continue } # Per-keyword page - set afp [open $html/Keywords/$a.htm w] + set afp [open [file join $html Keywords $a.htm] w] puts $afp [htmlhead "$tcltkdesc Keywords - $a" \ "$tcltkdesc Keywords - $a" \ $overall_title "../[indexfile]"] @@ -330,7 +330,7 @@ proc make-man-pages {html args} { set k [string range $k 8 end] puts $afp "<DT><A NAME=\"$k\">$k</A></DT>" puts $afp "<DD>" - set refs {} + set refs [list] foreach man $manual(keyword-$k) { set name [lindex $man 0] set file [lindex $man 1] @@ -428,7 +428,7 @@ proc make-man-pages {html args} { if {!$verbose} { puts stderr "\nDone" } - return {} + return "" } ## @@ -437,11 +437,11 @@ proc make-man-pages {html args} { proc plus-base {var root glob name dir desc} { global tcltkdir if {$var} { - if {[file exists $tcltkdir/$root/README]} { - set f [open $tcltkdir/$root/README] + if {[file exists [file join $tcltkdir $root README]]} { + set f [open [file join $tcltkdir $root README]] set d [read $f] close $f - if {[regexp {This is the \w+ (\S+) source distribution} $d -> version]} { + if {[regexp {This is the \w+ (\S+) source distribution} $d ___ version]} { append name ", version $version" } } @@ -459,18 +459,18 @@ proc plus-pkgs {type args} { error "unknown type \"$type\": must be 3 or n" } if {!$build_tcl} return - set result {} + set result "" set pkgsdir $tcltkdir/$tcldir/pkgs foreach {dir name version} $args { set globpat $pkgsdir/$dir/doc/*.$type - if {![llength [glob -type f -nocomplain $globpat]]} { + if {![llength [glob -type f -nocomplain -- $globpat]]} { # Fallback for manpages generated using doctools set globpat $pkgsdir/$dir/doc/man/*.$type - if {![llength [glob -type f -nocomplain $globpat]]} { + if {![llength [glob -type f -nocomplain -- $globpat]]} { continue } } - switch $type { + switch -- $type { n { set title "$name Package Commands" if {$version ne ""} { @@ -489,6 +489,7 @@ proc plus-pkgs {type args} { set desc \ "The additional C functions provided by the $name package." } + default {} } lappend result [list $globpat $title $dir $desc] } diff --git a/tools/tsdPerf.tcl b/tools/tsdPerf.tcl index 360ca9c..7fdd66c 100644 --- a/tools/tsdPerf.tcl +++ b/tools/tsdPerf.tcl @@ -19,6 +19,6 @@ set curdir [file dirname [info script]] load [file join $curdir tsdPerf[info sharedlibextension]] tsdPerfSet 1234 -while 1 { +while {1} { puts "TIME:[time {set value [tsdPerfGet]} 1000] VALUE:$value" } diff --git a/tools/uniClass.tcl b/tools/uniClass.tcl index 32b40e9..8e8f0cf 100644 --- a/tools/uniClass.tcl +++ b/tools/uniClass.tcl @@ -15,8 +15,8 @@ exec tclsh "$0" ${1+"$@"} proc emitRange {first last} { global ranges numranges chars numchars extchars extranges - if {$first < ($last-1)} { - if {!$extranges && ($first) > 0xffff} { + if {$first < ($last - 1)} { + if {(!$extranges) && ($first > 0xffff)} { set extranges 1 set numranges 0 set ranges [string trimright $ranges " \n\r\t,"] @@ -24,12 +24,12 @@ proc emitRange {first last} { } append ranges [format "{0x%x, 0x%x}, " \ $first $last] - if {[incr numranges] % 4 == 0} { + if {([incr numranges] % 4) == 0} { set ranges [string trimright $ranges] append ranges "\n " } } else { - if {!$extchars && ($first) > 0xffff} { + if {(!$extchars) && ($first > 0xffff)} { set extchars 1 set numchars 0 set chars [string trimright $chars " \n\r\t,"] @@ -37,14 +37,14 @@ proc emitRange {first last} { } append chars [format "0x%x, " $first] incr numchars - if {$numchars % 9 == 0} { + if {($numchars % 9) == 0} { set chars [string trimright $chars] append chars "\n " } if {$first != $last} { append chars [format "0x%x, " $last] incr numchars - if {$numchars % 9 == 0} { + if {($numchars % 9) == 0} { append chars "\n " } } diff --git a/tools/uniParse.tcl b/tools/uniParse.tcl index e33b3c7..44eb460 100644 --- a/tools/uniParse.tcl +++ b/tools/uniParse.tcl @@ -92,11 +92,11 @@ proc uni::addPage {info} { proc uni::buildTables {data} { variable shift - variable pMap {} - variable pages {} - variable groups {{0 0 0 0}} + variable pMap "" + variable pages "" + variable groups [list {0 0 0 0}] variable next 0 - set info {} ;# temporary page info + set info [list] ;# temporary page info set mask [expr {(1 << $shift) - 1}] @@ -107,14 +107,14 @@ proc uni::buildTables {data} { continue } # fill remaining page - set line [format %X [expr {($next-1)|$mask}]] + set line [format %X [expr {($next - 1) | $mask}]] append line ";;Cn;0;ON;;;;;N;;;;;\n" } set items [split $line \;] scan [lindex $items 0] %x index - if {$index > 0x2ffff} then { + if {$index > 0x2ffff} { # Ignore non-BMP characters, as long as Tcl doesn't support them continue } @@ -128,13 +128,13 @@ proc uni::buildTables {data} { # These are indicated as such in the character name. # Enter all unassigned characters up to the current character. - if {($index > $next) \ - && ![regexp "Last>$" [lindex $items 1]]} { + if {($index > $next) && + (![regexp "Last>$" [lindex $items 1]])} { for {} {$next < $index} {incr next} { lappend info 0 if {($next & $mask) == $mask} { addPage $info - set info {} + set info "" } } } @@ -147,7 +147,7 @@ proc uni::buildTables {data} { # If this is the last entry in the page, add the page if {($i & $mask) == $mask} { addPage $info - set info {} + set info "" } } set next [expr {$index + 1}] @@ -173,11 +173,11 @@ proc uni::main {} { buildTables $data puts "X = [llength $pMap] Y= [llength $pages] A= [llength $groups]" - set size [expr {[llength $pMap]*2 + ([llength $pages]<<$shift)}] + set size [expr {([llength $pMap] * 2) + ([llength $pages] << $shift)}] puts "shift = $shift, space = $size" set f [open [file join [lindex $argv 1] tclUniData.c] w] - fconfigure $f -translation lf + chan configure $f -translation lf puts $f "/* * tclUniData.c -- * @@ -203,11 +203,11 @@ proc uni::main {} { * to the same alternate page number. */ -static const unsigned short pageMap\[\] = {" +static const unsigned short pageMap\[\] = \{" set line " " set last [expr {[llength $pMap] - 1}] for {set i 0} {$i <= $last} {incr i} { - if {$i == [expr {0x10000 >> $shift}]} { + if {$i == (0x10000 >> $shift)} { set line [string trimright $line " \t,"] puts $f $line set lastpage [expr {[lindex $line end] >> $shift}] @@ -226,7 +226,7 @@ static const unsigned short pageMap\[\] = {" } puts $f $line puts $f "#endif /* TCL_UTF_MAX > 3 */" - puts $f "}; + puts $f "\}; /* * The groupMap is indexed by combining the alternate page number with @@ -234,7 +234,7 @@ static const unsigned short pageMap\[\] = {" * set of character attributes. */ -static const unsigned char groupMap\[\] = {" +static const unsigned char groupMap\[\] = \{" set line " " set lasti [expr {[llength $pages] - 1}] for {set i 0} {$i <= $lasti} {incr i} { @@ -247,7 +247,7 @@ static const unsigned char groupMap\[\] = {" } for {set j 0} {$j <= $lastj} {incr j} { append line [lindex $page $j] - if {$j != $lastj || $i != $lasti} { + if {($j != $lastj) || ($i != $lasti)} { append line ", " } if {[string length $line] > 70} { @@ -258,7 +258,7 @@ static const unsigned char groupMap\[\] = {" } puts $f $line puts $f "#endif /* TCL_UTF_MAX > 3 */" - puts $f "}; + puts $f "\}; /* * Each group represents a unique set of character attributes. The attributes @@ -277,11 +277,11 @@ static const unsigned char groupMap\[\] = {" * highest field so we can easily sign extend. */ -static const int groups\[\] = {" +static const int groups\[\] = \{" set line " " set last [expr {[llength $groups] - 1}] for {set i 0} {$i <= $last} {incr i} { - foreach {type toupper tolower totitle} [lindex $groups $i] {} + lassign [lindex $groups $i] type toupper tolower totitle # Compute the case conversion type and delta @@ -335,7 +335,7 @@ static const int groups\[\] = {" } } puts $f $line - puts -nonewline $f "}; + puts -nonewline $f "\}; #if TCL_UTF_MAX > 3 # define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1fffff) >= [format 0x%x $next]) |