Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | Whitespace reduction in Tcl scripts. No functional change. |
---|---|
Downloads: | Tarball | ZIP archive | SQL archive |
Timelines: | family | ancestors | descendants | both | trunk |
Files: | files | file ages | folders |
SHA1: |
401a39ba9a2f9c335fcc2c6041483a1d |
User & Date: | jan.nijtmans 2015-09-01 15:15:46 |
Context
2015-09-01
| ||
18:54 | Various Unicode handling enhancements, when building with TCL_UTF_MAX > 3, inspired by androwish. No... check-in: e2278643dc user: jan.nijtmans tags: trunk | |
15:15 | Whitespace reduction in Tcl scripts. No functional change. check-in: 401a39ba9a user: jan.nijtmans tags: trunk | |
2015-08-31
| ||
10:18 | Some Unicode encoding fixes, only having effect if TCL_UTF_MAX > 4. Backported from androwish check-in: d8764f73dd user: jan.nijtmans tags: trunk | |
Changes
Changes to library/init.tcl.
︙ | ︙ | |||
8 9 10 11 12 13 14 | # Copyright (c) 1998-1999 Scriptics Corporation. # Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # Copyright (c) 1998-1999 Scriptics Corporation. # Copyright (c) 2004 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # This test intentionally written in pre-7.5 Tcl if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } package require -exact Tcl 8.6.4 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: |
︙ | ︙ | |||
328 329 330 331 332 333 334 | } else { dict incr opts -level return -options $opts $msg } } } | | | 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 | } else { dict incr opts -level return -options $opts $msg } } } if {([info level] == 1) && ([info script] eq "") && [info exists tcl_interactive] && $tcl_interactive} { if {![info exists auto_noexec]} { set new [auto_execok $name] if {$new ne ""} { set redir "" if {[namespace which -command console] eq ""} { set redir ">&@stdout <@stdin" |
︙ | ︙ |
Changes to library/msgcat/msgcat.tcl.
︙ | ︙ | |||
258 259 260 261 262 263 264 | return -code error "wrong # args: should be\ \"[lindex [info level 0] 0] ?-exactnamespace?\ ?-exactlocale? src\"" } } } set src [lindex $args 0] | | | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 | return -code error "wrong # args: should be\ \"[lindex [info level 0] 0] ?-exactnamespace?\ ?-exactlocale? src\"" } } } set src [lindex $args 0] while {$ns ne ""} { foreach loc $loclist { if {[dict exists $Msgs $ns $loc $src]} { return 1 } } if {[info exists exactnamespace]} {return 0} |
︙ | ︙ | |||
301 302 303 304 305 306 307 | set newLocale [string tolower [lindex $args 0]] if {$newLocale ne [file tail $newLocale]} { return -code error "invalid newLocale value \"$newLocale\":\ could be path to unsafe code." } if {[lindex $Loclist 0] ne $newLocale} { set Loclist [GetPreferences $newLocale] | | | 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 | set newLocale [string tolower [lindex $args 0]] if {$newLocale ne [file tail $newLocale]} { return -code error "invalid newLocale value \"$newLocale\":\ could be path to unsafe code." } if {[lindex $Loclist 0] ne $newLocale} { set Loclist [GetPreferences $newLocale] # locale not loaded jet LoadAll $Loclist # Invoke callback Invoke changecmd $Loclist } } return [lindex $Loclist 0] |
︙ | ︙ | |||
459 460 461 462 463 464 465 | {"get" "isset" "unset" "preferences" "loaded" "clear"} } { return -code error "wrong # args: should be\ \"[lrange [info level 0] 0 1]\"" } set locale [string tolower $locale] } set ns [uplevel 1 {::namespace current}] | | | 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 | {"get" "isset" "unset" "preferences" "loaded" "clear"} } { return -code error "wrong # args: should be\ \"[lrange [info level 0] 0 1]\"" } set locale [string tolower $locale] } set ns [uplevel 1 {::namespace current}] switch -exact -- $subcommand { get { return [lindex [PackagePreferences $ns] 0] } preferences { return [PackagePreferences $ns] } loaded { return [PackageLocales $ns] } present { return [expr {$locale in [PackageLocales $ns]} ]} isset { return [dict exists $PackageConfig loclist $ns] } set { # set a package locale or add a package locale |
︙ | ︙ | |||
642 643 644 645 646 647 648 | return -code error "package option \"$option\" not set" } return [dict get $PackageConfig $option $ns] } isset { return [dict exists $PackageConfig $option $ns] } unset { dict unset PackageConfig $option $ns } set { # Set option | | | 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 | return -code error "package option \"$option\" not set" } return [dict get $PackageConfig $option $ns] } isset { return [dict exists $PackageConfig $option $ns] } unset { dict unset PackageConfig $option $ns } set { # Set option if {$option eq "mcfolder"} { set value [file normalize $value] } # Check if changed if { [dict exists $PackageConfig $option $ns] && $value eq [dict get $PackageConfig $option $ns] } { return 0 |
︙ | ︙ | |||
775 776 777 778 779 780 781 | variable PackageConfig variable LoadedLocales if {0 == [llength $locales]} { return {} } # filter jet unloaded locales set locales [ListComplement $LoadedLocales $locales] if {0 == [llength $locales]} { return {} } lappend LoadedLocales {*}$locales | | | 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 | variable PackageConfig variable LoadedLocales if {0 == [llength $locales]} { return {} } # filter jet unloaded locales set locales [ListComplement $LoadedLocales $locales] if {0 == [llength $locales]} { return {} } lappend LoadedLocales {*}$locales set packages [lsort -unique [concat\ [dict keys [dict get $PackageConfig loadcmd]]\ [dict keys [dict get $PackageConfig mcfolder]]]] foreach ns $packages { if {! [dict exists $PackageConfig loclist $ns] } { Load $ns $locales } |
︙ | ︙ | |||
808 809 810 811 812 813 814 | variable PackageConfig variable LoadedLocals if {0 == [llength $locales]} { return 0 } # Invoke callback Invoke loadcmd $locales $ns | | | | 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 | variable PackageConfig variable LoadedLocals if {0 == [llength $locales]} { return 0 } # Invoke callback Invoke loadcmd $locales $ns if {$callbackonly || ![dict exists $PackageConfig mcfolder $ns]} { return 0 } # Invoke file load set langdir [dict get $PackageConfig mcfolder $ns] # Save the file locale if we are recursively called if {[info exists FileLocale]} { set nestedFileLocale $FileLocale } set x 0 foreach p $locales { if {$p eq {}} { |
︙ | ︙ |
Changes to library/opt/optparse.tcl.
︙ | ︙ | |||
431 432 433 434 435 436 437 | if {$state == "flags"} { # no argument and no flags : we're done # puts "returning to previous (sub)prg (no more args)" return -code return } elseif {$state == "optValue"} { set state next; # not used, for debug only # go to next state | | | 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 | if {$state == "flags"} { # no argument and no flags : we're done # puts "returning to previous (sub)prg (no more args)" return -code return } elseif {$state == "optValue"} { set state next; # not used, for debug only # go to next state return } else { return -code error [OptMissingValue $descriptions] } } else { set arg [OptCurrentArg $arguments] } |
︙ | ︙ | |||
534 535 536 537 538 539 540 | if {![Lempty $arglist]} { return -code error [OptTooManyArgs $desc $arglist] } # Analyse the result # Walk through the tree: | | | 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 | if {![Lempty $arglist]} { return -code error [OptTooManyArgs $desc $arglist] } # Analyse the result # Walk through the tree: OptTreeVars $desc "#[expr {[info level]-1}]" } # determine string length for nice tabulated output proc OptTreeVars {desc level {vnamesLst {}}} { foreach item $desc { if {[OptIsCounter $item]} continue if {[OptIsPrg $item]} { |
︙ | ︙ |
Changes to library/package.tcl.
︙ | ︙ | |||
722 723 724 725 726 727 728 | set cmdList {} set lazyFileList {} # Handle -load and -source specs foreach key {load source} { foreach filespec $opts(-$key) { lassign $filespec filename proclist | | | 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 | set cmdList {} set lazyFileList {} # Handle -load and -source specs foreach key {load source} { foreach filespec $opts(-$key) { lassign $filespec filename proclist if { [llength $proclist] == 0 } { set cmd "\[list $key \[file join \$dir [list $filename]\]\]" lappend cmdList $cmd } else { lappend lazyFileList [list $filename $key $proclist] } } |
︙ | ︙ |
Changes to library/platform/platform.tcl.
︙ | ︙ | |||
319 320 321 322 323 324 325 | macosx-x86_64 { lappend res macosx-i386-x86_64 } macosx-ix86 { lappend res macosx-universal macosx-i386-x86_64 } macosx*-* { | | | 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 | macosx-x86_64 { lappend res macosx-i386-x86_64 } macosx-ix86 { lappend res macosx-universal macosx-i386-x86_64 } macosx*-* { # 10.5+ if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} { switch -exact -- $cpu { ix86 { lappend alt i386-x86_64 lappend alt universal } |
︙ | ︙ |
Changes to library/safe.tcl.
︙ | ︙ | |||
849 850 851 852 853 854 855 | } if {$argc != 1} { set msg "wrong # args: should be \"source ?-encoding E? fileName\"" Log $slave "$msg ($args)" return -code error $msg } set file [lindex $args $at] | | | | 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 | } if {$argc != 1} { set msg "wrong # args: should be \"source ?-encoding E? fileName\"" Log $slave "$msg ($args)" return -code error $msg } set file [lindex $args $at] # get the real path from the virtual one. if {[catch { set realfile [TranslatePath $slave $file] } msg]} { Log $slave $msg return -code error "permission denied" } # check that the path is in the access path of that slave if {[catch { FileInAccessPath $slave $realfile } msg]} { Log $slave $msg return -code error "permission denied" } |
︙ | ︙ |
Changes to library/tcltest/tcltest.tcl.
︙ | ︙ | |||
343 344 345 346 347 348 349 | proc outputChannel { {filename ""} } { variable outputChannel variable ChannelsWeOpened # This is very subtle and tricky, so let me try to explain. # (Hopefully this longer comment will be clear when I come # back in a few months, unlike its predecessor :) ) | | | | | 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 | proc outputChannel { {filename ""} } { variable outputChannel variable ChannelsWeOpened # This is very subtle and tricky, so let me try to explain. # (Hopefully this longer comment will be clear when I come # back in a few months, unlike its predecessor :) ) # # The [outputChannel] command (and underlying variable) have to # be kept in sync with the [configure -outfile] configuration # option ( and underlying variable Option(-outfile) ). This is # accomplished with a write trace on Option(-outfile) that will # update [outputChannel] whenver a new value is written. That # much is easy. # # The trick is that in order to maintain compatibility with # version 1 of tcltest, we must allow every configuration option # to get its inital value from command line arguments. This is # accomplished by setting initial read traces on all the # configuration options to parse the command line option the first # time they are read. These traces are cancelled whenever the # program itself calls [configure]. # # OK, then so to support tcltest 1 compatibility, it seems we want # to get the return from [outputFile] to trigger the read traces, # just in case. # # BUT! A little known feature of Tcl variable traces is that # traces are disabled during the handling of other traces. So, # if we trigger read traces on Option(-outfile) and that triggers # command line parsing which turns around and sets an initial # value for Option(-outfile) -- <whew!> -- the write trace that # would keep [outputChannel] in sync with that new initial value # would not fire! # |
︙ | ︙ | |||
604 605 606 607 608 609 610 | proc configure args { if {[llength $args] > 1} { RemoveAutoConfigureTraces } set code [catch {Configure {*}$args} msg] return -code $code $msg } | | | 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 | proc configure args { if {[llength $args] > 1} { RemoveAutoConfigureTraces } set code [catch {Configure {*}$args} msg] return -code $code $msg } proc AcceptVerbose { level } { set level [AcceptList $level] if {[llength $level] == 1} { if {![regexp {^(pass|body|skip|start|error|line)$} $level]} { # translate single characters abbreviations to expanded list set level [string map {p pass b body s skip t start e error l line} \ [split $level {}]] |
︙ | ︙ | |||
635 636 637 638 639 640 641 | # Default verbosity is to show bodies of failed tests Option -verbose {body error} { Takes any combination of the values 'p', 's', 'b', 't', 'e' and 'l'. Test suite will display all passed tests if 'p' is specified, all skipped tests if 's' is specified, the bodies of failed tests if 'b' is specified, and when tests start if 't' is specified. ErrorInfo is displayed if 'e' is specified. Source file line | | | 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 | # Default verbosity is to show bodies of failed tests Option -verbose {body error} { Takes any combination of the values 'p', 's', 'b', 't', 'e' and 'l'. Test suite will display all passed tests if 'p' is specified, all skipped tests if 's' is specified, the bodies of failed tests if 'b' is specified, and when tests start if 't' is specified. ErrorInfo is displayed if 'e' is specified. Source file line information of failed tests is displayed if 'l' is specified. } AcceptVerbose verbose # Match and skip patterns default to the empty list, except for # matchFiles, which defaults to all .test files in the # testsDirectory and matchDirectories, which defaults to all # directories. Option -match * { |
︙ | ︙ | |||
683 684 685 686 687 688 689 | # debug output doesn't get printed by default; debug level 1 spits # up only the tests that were skipped because they didn't match or # were specifically skipped. A debug level of 2 would spit up the # tcltest variables and flags provided; a debug level of 3 causes # some additional output regarding operations of the test harness. # The tcltest package currently implements only up to debug level 3. Option -debug 0 { | | | 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 | # debug output doesn't get printed by default; debug level 1 spits # up only the tests that were skipped because they didn't match or # were specifically skipped. A debug level of 2 would spit up the # tcltest variables and flags provided; a debug level of 3 causes # some additional output regarding operations of the test harness. # The tcltest package currently implements only up to debug level 3. Option -debug 0 { Internal debug level } AcceptInteger debug proc SetSelectedConstraints args { variable Option foreach c $Option(-constraints) { testConstraint $c 1 } |
︙ | ︙ | |||
711 712 713 714 715 716 717 | if {$c ni $Option(-constraints)} { testConstraint $c 0 } } } Option -limitconstraints 0 { whether to run only tests with the constraints | | | | 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 | if {$c ni $Option(-constraints)} { testConstraint $c 0 } } } Option -limitconstraints 0 { whether to run only tests with the constraints } AcceptBoolean limitConstraints trace add variable Option(-limitconstraints) write \ [namespace code {ClearUnselectedConstraints ;#}] # A test application has to know how to load the tested commands # into the interpreter. Option -load {} { Specifies the script to load the tested commands. } AcceptScript loadScript # Default is to run each test file in a separate process Option -singleproc 0 { whether to run all tests in one process } AcceptBoolean singleProcess proc AcceptTemporaryDirectory { directory } { set directory [AcceptAbsolutePath $directory] if {![file exists $directory]} { file mkdir $directory } set directory [AcceptDirectory $directory] |
︙ | ︙ | |||
1253 1254 1255 1256 1257 1258 1259 | ($::tcl_platform(user) in {root {}})}} ConstraintInitializer notRoot {expr {![testConstraint root]}} # Set nonBlockFiles constraint: 1 means this platform supports # setting files into nonblocking mode. ConstraintInitializer nonBlockFiles { | | | | 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 | ($::tcl_platform(user) in {root {}})}} ConstraintInitializer notRoot {expr {![testConstraint root]}} # Set nonBlockFiles constraint: 1 means this platform supports # setting files into nonblocking mode. ConstraintInitializer nonBlockFiles { set code [expr {[catch {set f [open defs r]}] || [catch {chan configure $f -blocking off}]}] catch {close $f} set code } # Set asyncPipeClose constraint: 1 means this platform supports # async flush and async close on a pipe. # # Test for SCO Unix - cannot run async flushing tests because a # potential problem with select is apparently interfering. # (Mark Diekhans). ConstraintInitializer asyncPipeClose {expr { !([string equal unix $::tcl_platform(platform)] && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}} # Test to see if we have a broken version of sprintf with respect # to the "e" format of floating-point numbers. ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05} |
︙ | ︙ | |||
1950 1951 1952 1953 1954 1955 1956 | } if {[Skipped $name $constraints]} { incr testLevel -1 return } | | | 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 | } if {[Skipped $name $constraints]} { incr testLevel -1 return } # Save information about the core file. if {[preserveCore]} { if {[file exists [file join [workingDirectory] core]]} { set coreModTime [file mtime [file join [workingDirectory] core]] } } # First, run the setup script |
︙ | ︙ | |||
2056 2057 2058 2059 2060 2061 2062 | if {$coreModTime != [file mtime \ [file join [workingDirectory] core]]} { set coreFailure 1 } } else { set coreFailure 1 } | | | 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 | if {$coreModTime != [file mtime \ [file join [workingDirectory] core]]} { set coreFailure 1 } } else { set coreFailure 1 } if {([preserveCore] > 1) && ($coreFailure)} { append coreMsg "\nMoving file to:\ [file join [temporaryDirectory] core-$name]" catch {file rename -force -- \ [file join [workingDirectory] core] \ [file join [temporaryDirectory] core-$name] } msg |
︙ | ︙ | |||
2096 2097 2098 2099 2100 2101 2102 | incr numTests(Failed) } # ... then report according to the type of failure variable currentFailure true if {![IsVerbose body]} { set body "" | | | | 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 | incr numTests(Failed) } # ... then report according to the type of failure variable currentFailure true if {![IsVerbose body]} { set body "" } puts [outputChannel] "\n" if {[IsVerbose line]} { if {![catch {set testFrame [info frame -1]}] && [dict get $testFrame type] eq "source"} { set testFile [dict get $testFrame file] set testLine [dict get $testFrame line] } else { set testFile [file normalize [uplevel 1 {info script}]] if {[file readable $testFile]} { set testFd [open $testFile r] set testLine [expr {[lsearch -regexp \ [split [read $testFd] "\n"] \ "^\[ \t\]*test [string map {. \\.} $name] "] + 1}] close $testFd } } if {[info exists testLine]} { puts [outputChannel] "$testFile:$testLine: error: test failed:\ $name [string trim $description]" } } puts [outputChannel] "==== $name\ [string trim $description] FAILED" if {[string length $body]} { puts [outputChannel] "==== Contents of test case:" puts [outputChannel] $body } if {$setupFailure} { |
︙ | ︙ | |||
2273 2274 2275 2276 2277 2278 2279 | # store the constraint that kept the test from # running set constraints $constraint break } } } | | | 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 | # store the constraint that kept the test from # running set constraints $constraint break } } } if {!$doTest} { if {[IsVerbose skip]} { puts [outputChannel] "++++ $name SKIPPED: $constraints" } if {$testLevel == 1} { incr numTests(Skipped) |
︙ | ︙ | |||
2830 2831 2832 2833 2834 2835 2836 | } # Checking for subdirectories in which to run tests foreach directory [GetMatchingDirectories [testsDirectory]] { set dir [file tail $directory] puts [outputChannel] [string repeat ~ 44] puts [outputChannel] "$dir test began at [eval $timeCmd]\n" | | | | 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 | } # Checking for subdirectories in which to run tests foreach directory [GetMatchingDirectories [testsDirectory]] { set dir [file tail $directory] puts [outputChannel] [string repeat ~ 44] puts [outputChannel] "$dir test began at [eval $timeCmd]\n" uplevel 1 [list ::source [file join $directory all.tcl]] set endTime [eval $timeCmd] puts [outputChannel] "\n$dir test ended at $endTime" puts [outputChannel] "" puts [outputChannel] [string repeat ~ 44] } return } |
︙ | ︙ | |||
3015 3016 3017 3018 3019 3020 3021 | DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName" set idx [lsearch -exact $filesMade $fullName] set filesMade [lreplace $filesMade $idx $idx] if {$idx == -1} { DebugDo 1 { Warn "removeFile removing \"$fullName\":\n not created by makeFile" } | | | 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 | DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName" set idx [lsearch -exact $filesMade $fullName] set filesMade [lreplace $filesMade $idx $idx] if {$idx == -1} { DebugDo 1 { Warn "removeFile removing \"$fullName\":\n not created by makeFile" } } if {![file isfile $fullName]} { DebugDo 1 { Warn "removeFile removing \"$fullName\":\n not a file" } } return [file delete -- $fullName] } |
︙ | ︙ | |||
3086 3087 3088 3089 3090 3091 3092 | set idx [lsearch -exact $filesMade $fullName] set filesMade [lreplace $filesMade $idx $idx] if {$idx == -1} { DebugDo 1 { Warn "removeDirectory removing \"$fullName\":\n not created\ by makeDirectory" } | | | 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 | set idx [lsearch -exact $filesMade $fullName] set filesMade [lreplace $filesMade $idx $idx] if {$idx == -1} { DebugDo 1 { Warn "removeDirectory removing \"$fullName\":\n not created\ by makeDirectory" } } if {![file isdirectory $fullName]} { DebugDo 1 { Warn "removeDirectory removing \"$fullName\":\n not a directory" } } return [file delete -force -- $fullName] } |
︙ | ︙ | |||
3281 3282 3283 3284 3285 3286 3287 | ## room to kill themselves off, otherwise the end up with a ## massive queue of repeated events after 1 } testthread errorproc ThreadError return [llength [testthread names]] } elseif {[info commands thread::id] ne {}} { | | | 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 | ## room to kill themselves off, otherwise the end up with a ## massive queue of repeated events after 1 } testthread errorproc ThreadError return [llength [testthread names]] } elseif {[info commands thread::id] ne {}} { # Thread extension thread::errorproc ThreadNullError while {[llength [thread::names]] > 1} { foreach tid [thread::names] { if {$tid != [mainThread]} { catch {thread::send -async $tid {thread::exit}} |
︙ | ︙ |
Changes to tests/httpd11.tcl.
︙ | ︙ | |||
40 41 42 43 44 45 46 | proc get-chunks {data {compression gzip}} { switch -exact -- $compression { gzip { set data [zlib gzip $data] } deflate { set data [zlib deflate $data] } compress { set data [zlib compress $data] } } | | | | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | proc get-chunks {data {compression gzip}} { switch -exact -- $compression { gzip { set data [zlib gzip $data] } deflate { set data [zlib deflate $data] } compress { set data [zlib compress $data] } } set data "" set chunker [make-chunk-generator $data 512] while {[string length [set chunk [$chunker]]]} { append data $chunk } return $data } proc blow-chunks {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] } } set chunker [make-chunk-generator $data 512] while {[string length [set chunk [$chunker]]]} { puts -nonewline $ochan $chunk } return } |
︙ | ︙ | |||
152 153 154 155 156 157 158 | set f [open $path r] if {$what eq "binary"} {chan configure $f -translation binary} set data [read $f] close $f set code "200 OK" set close [expr {[dict get? $meta connection] eq "close"}] } | | | | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 | set f [open $path r] if {$what eq "binary"} {chan configure $f -translation binary} set data [read $f] close $f set code "200 OK" set close [expr {[dict get? $meta connection] eq "close"}] } if {$protocol eq "HTTP/1.1"} { foreach enc [split [dict get? $meta accept-encoding] ,] { set enc [string trim $enc] if {$enc in {deflate gzip compress}} { set encoding $enc break } } set transfer chunked } else { set close 1 } foreach pair [split $query &] { if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""} switch -exact -- $key { close {set close 1 ; set transfer 0} transfer {set transfer $val} content-type {set type $val} } |
︙ | ︙ | |||
205 206 207 208 209 210 211 | if {$transfer eq "chunked"} { blow-chunks $data $chan $encoding } elseif {$encoding ne "identity"} { puts -nonewline $chan [zlib $encoding $data] } else { puts -nonewline $chan $data } | | | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 | if {$transfer eq "chunked"} { blow-chunks $data $chan $encoding } elseif {$encoding ne "identity"} { puts -nonewline $chan [zlib $encoding $data] } else { puts -nonewline $chan $data } if {$close} { chan event $chan readable {} close $chan puts "close $chan" return } else { flush $chan |
︙ | ︙ |
Changes to tools/findBadExternals.tcl.
1 | # findBadExternals.tcl -- | | | 1 2 3 4 5 6 7 8 9 | # findBadExternals.tcl -- # # This script scans the Tcl load library for exported symbols # that do not begin with 'Tcl' or 'tcl'. It reports them on the # standard output. It is used to make sure that the library does # not inadvertently export externals that may be in conflict with # other code. # # Usage: |
︙ | ︙ | |||
25 26 27 28 29 30 31 | switch -exact -- $::tcl_platform(platform) { unix - macosx { set status [catch { exec nm --extern-only --defined-only [lindex $argv 0] | | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | switch -exact -- $::tcl_platform(platform) { unix - macosx { set status [catch { exec nm --extern-only --defined-only [lindex $argv 0] } result] } windows { set status [catch { exec dumpbin /exports [lindex $argv 0] } result] } } |
︙ | ︙ |
Changes to tools/loadICU.tcl.
︙ | ︙ | |||
428 429 430 431 432 433 434 | if { [info exists format($localeName,TIME_FORMAT)] || [info exists items(DateTimePatterns)] } { # Find the shortest time pattern that includes the seconds if { ![info exists format($localeName,TIME_FORMAT)] } { for { set i 3 } { $i >= 0 } { incr i -1 } { | | | 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 | if { [info exists format($localeName,TIME_FORMAT)] || [info exists items(DateTimePatterns)] } { # Find the shortest time pattern that includes the seconds if { ![info exists format($localeName,TIME_FORMAT)] } { for { set i 3 } { $i >= 0 } { incr i -1 } { if { [regexp H [lindex $items(DateTimePatterns) $i]] && [regexp s [lindex $items(DateTimePatterns) $i]] } { break } } if { $i >= 0 } { set fmt \ [backslashify \ |
︙ | ︙ | |||
460 461 462 463 464 465 466 | if { [info exists format($localeName,TIME_FORMAT_12)] || [info exists items(DateTimePatterns)] } { # Shortest patterm with 12-hour time that includes seconds if { ![info exists format($localeName,TIME_FORMAT_12)] } { for { set i 3 } { $i >= 0 } { incr i -1 } { | | | 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 | if { [info exists format($localeName,TIME_FORMAT_12)] || [info exists items(DateTimePatterns)] } { # Shortest patterm with 12-hour time that includes seconds if { ![info exists format($localeName,TIME_FORMAT_12)] } { for { set i 3 } { $i >= 0 } { incr i -1 } { if { [regexp h [lindex $items(DateTimePatterns) $i]] && [regexp s [lindex $items(DateTimePatterns) $i]] } { break } } if { $i >= 0 } { set fmt \ [backslashify \ |
︙ | ︙ | |||
485 486 487 488 489 490 491 | $format($localeName,TIME_FORMAT_12) "\"" puts $f $cmd } } # Date and time... Prefer 24-hour format to 12-hour format. | | | | | 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 | $format($localeName,TIME_FORMAT_12) "\"" puts $f $cmd } } # 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)]} { 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)]} { set format($localeName,DATE_TIME_FORMAT) \ $format($localeName,DATE_FORMAT) append format($localeName,DATE_TIME_FORMAT) \ " " $format($localeName,TIME_FORMAT_12) " %z" } # Write date/time format to the file if { [info exists format($localeName,DATE_TIME_FORMAT)] } { set cmd " ::msgcat::mcset " append cmd $localeName " DATE_TIME_FORMAT \"" \ $format($localeName,DATE_TIME_FORMAT) "\"" puts $f $cmd } # Write the string sets to the file. foreach key { LOCALE_NUMERALS LOCALE_DATE_FORMAT LOCALE_TIME_FORMAT LOCALE_DATE_TIME_FORMAT LOCALE_ERAS LOCALE_YEAR_FORMAT } { if { [info exists format($localeName,$key)] } { set cmd " ::msgcat::mcset " append cmd $localeName " " $key " \"" \ [backslashify $format($localeName,$key)] "\"" |
︙ | ︙ | |||
584 585 586 587 588 589 590 | #---------------------------------------------------------------------- proc backslashify { string } { set retval {} foreach char [split $string {}] { scan $char %c ccode | | | 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 | #---------------------------------------------------------------------- proc backslashify { 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 "\$" } { append retval $char } else { append retval \\u [format %04x $ccode] } } |
︙ | ︙ |
Changes to tools/makeTestCases.tcl.
︙ | ︙ | |||
36 37 38 39 40 41 42 | x xi xii xiii xiv xv xvi xvii xviii xix xx xxi xxii xxiii xxiv xxv xxvi xxvii xxviii xxix xxx xxxi xxxii xxxiii xxxiv xxxv xxxvi xxxvii xxxviii xxxix xl xli xlii xliii xliv xlv xlvi xlvii xlviii xlix l li lii liii liv lv lvi lvii lviii lix lx lxi lxii lxiii lxiv lxv lxvi lxvii lxviii lxix lxx lxxi lxxii lxxiii lxxiv lxxv lxxvi lxxvii lxxviii lxxix | | | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | x xi xii xiii xiv xv xvi xvii xviii xix xx xxi xxii xxiii xxiv xxv xxvi xxvii xxviii xxix xxx xxxi xxxii xxxiii xxxiv xxxv xxxvi xxxvii xxxviii xxxix xl xli xlii xliii xliv xlv xlvi xlvii xlviii xlix l li lii liii liv lv lvi lvii lviii lix lx lxi lxii lxiii lxiv lxv lxvi lxvii lxviii lxix lxx lxxi lxxii lxxiii lxxiv lxxv lxxvi lxxvii lxxviii lxxix lxxx lxxxi lxxxii lxxxiii lxxxiv lxxxv lxxxvi lxxxvii lxxxviii lxxxix xc xci xcii xciii xciv xcv xcvi xcvii xcviii xcix c } DATE_FORMAT {%m/%d/%Y} TIME_FORMAT {%H:%M:%S} DATE_TIME_FORMAT {%x %X} |
︙ | ︙ | |||
58 59 60 61 62 63 64 | # # listYears -- # # List the years to test in the common clock test cases. # # Parameters: # startOfYearArray - Name of an array in caller's scope that will | | | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | # # listYears -- # # List the years to test in the common clock test cases. # # Parameters: # startOfYearArray - Name of an array in caller's scope that will # be initialized as # Results: # None # # Side effects: # Determines the year numbers of one common year, one leap year, one year # following a common year, and one year following a leap year -- starting # on each day of the week -- in the XIXth, XXth and XXIth centuries. |
︙ | ︙ | |||
102 103 104 105 106 107 108 | set do($x$c$dw$l) $y set startOfYear($y) $s set startOfYear([expr {$y + 1}]) $s2 } set s $s2 incr y } | | | 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | set do($x$c$dw$l) $y set startOfYear($y) $s set startOfYear([expr {$y + 1}]) $s2 } set s $s2 incr y } # List years before 1970 set y 1970 set s 0 set dw 4; # Thursday while { $y >= 1801 } { set s0 $s |
︙ | ︙ | |||
134 135 136 137 138 139 140 | } } } #---------------------------------------------------------------------- # | | | | | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 | } } } #---------------------------------------------------------------------- # # processFile - # # Processes the 'clock.test' file, updating the test cases in it. # # Parameters: # None. # # Side effects: # Replaces the file with a new copy, constructing needed test cases. # #---------------------------------------------------------------------- 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] # Copy leading portion of the test file set state {} while { [gets $f1 line] >= 0 } { switch -exact -- $state { {} { puts $f2 $line if { [regexp "^\# BEGIN (.*)" $line -> cases] && [string compare {} [info commands $cases]] } { set state inCaseSet $cases $f2 } } inCaseSet { if { [regexp "^\#\ END $cases\$" $line] } { |
︙ | ︙ | |||
209 210 211 212 213 214 215 | #---------------------------------------------------------------------- proc testcases2 { f2 } { listYears startOfYear # Define the roman numerals | | | 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 | #---------------------------------------------------------------------- proc testcases2 { f2 } { listYears startOfYear # Define the roman numerals set roman { ? i ii iii iv v vi vii viii ix x xi xii xiii xiv xv xvi xvii xviii xix xx xxi xxii xxiii xxiv xxv xxvi xxvii xxviii xxix xxx xxxi xxxii xxxiii xxxiv xxxv xxxvi xxxvii xxxviii xxxix xl xli xlii xliii xliv xlv xlvi xlvii xlviii xlix l li lii liii liv lv lvi lvii lviii lix |
︙ | ︙ | |||
231 232 233 234 235 236 237 | ? c cc ccc cd d dc dcc dccc cm m mc mcc mccc mcd md mdc mdcc mdccc mcm mm mmc mmcc mmccc mmcd mmd mmdc mmdcc mmdccc mmcm mmm mmmc mmmcc mmmccc mmmcd mmmd mmmdc mmmdcc mmmdccc mmmcm } # Names of the months | | | | | | | | | 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 | ? c cc ccc cd d dc dcc dccc cm m mc mcc mccc mcd md mdc mdcc mdccc mcm mm mmc mmcc mmccc mmcd mmd mmdc mmdcc mmdccc mmcm mmm mmmc mmmcc mmmccc mmmcd mmmd mmmdc mmmdcc mmmdccc mmmcm } # Names of the months 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 October November December } # Put out a header describing the tests puts $f2 "" puts $f2 "\# Test formatting of Gregorian year, month, day, all formats" puts $f2 "\# Formats tested: %b %B %c %Ec %C %EC %d %Od %e %Oe %h %j %J %m %Om %N %x %Ex %y %Oy %Y %EY" puts $f2 "" # Generate the test cases for the first and last day of every month # 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) }] 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 ) } { incr hath } set b [lindex $short $m] set B [lindex $long $m] set C [format %02d [expr { $y / 100 }]] set h $b set j [format %03d $yd] set mm [format %02d $m] set N [format %2d $m] set yy [format %02d [expr { $y % 100 }]] set J [expr { ( $s / 86400 ) + 2440588 }] set dt $y-$mm-01 set result "" append result $b " " $B " " \ $mm /01/ $y " 12:34:56 " \ "die i mensis " [lindex $roman $m] " annoque " \ [lindex $romanc [expr { $y / 100 }]] \ [lindex $roman [expr { $y % 100 }]] " " \ |
︙ | ︙ | |||
292 293 294 295 296 297 298 | [lindex $roman [expr { $y % 100 }]] \ " " $yy " " [lindex $roman [expr { $y % 100 }]] " " $y 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}" | | | | | | 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 | [lindex $roman [expr { $y % 100 }]] \ " " $yy " " [lindex $roman [expr { $y % 100 }]] " " $y 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}" set hm1 [expr { $hath - 1 }] incr s [expr { 86400 * ( $hath - 1 ) }] incr yd $hm1 set dd [format %02d $hath] set ee [format %2d $hath] set j [format %03d $yd] set J [expr { ( $s / 86400 ) + 2440588 }] set dt $y-$mm-$dd set result "" append result $b " " $B " " \ $mm / $dd / $y " 12:34:56 " \ "die " [lindex $roman $hath] " mensis " [lindex $roman $m] \ " annoque " \ [lindex $romanc [expr { $y / 100 }]] \ |
︙ | ︙ | |||
328 329 330 331 332 333 334 | [lindex $roman [expr { $y % 100 }]] \ " " $yy " " [lindex $roman [expr { $y % 100 }]] " " $y 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}" | | | 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 | [lindex $roman [expr { $y % 100 }]] \ " " $yy " " [lindex $roman [expr { $y % 100 }]] " " $y 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}" incr s 86400 incr yd } } puts "testcases2: $n test cases" } |
︙ | ︙ | |||
447 448 449 450 451 452 453 | 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 6 $secs testISO $f2 $ym1 52 7 [expr { $secs + 86400 }] | | | | | | 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 | 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 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 }] } } } puts "testcases3: $case test cases." } 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} 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]\ [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]}" } #---------------------------------------------------------------------- # # testcases4 -- # # Makes the test cases that test formatting of time of day. |
︙ | ︙ | |||
500 501 502 503 504 505 506 | proc testcases4 { 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 {} | | | | | | | | | 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 | proc testcases4 { 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 {} set i 0 set fmt "%H %OH %I %OI %k %Ok %l %Ol %M %OM %p %P %r %R %S %OS %T %X %EX %+" foreach { h romanH I romanI am } { 0 ? 12 xii AM 1 i 1 i AM 11 xi 11 xi AM 12 xii 12 xii PM 13 xiii 1 i PM 23 xxiii 11 xi PM } { set hh [format %02d $h] set II [format %02d $I] set hs [format %2d $h] set Is [format %2d $I] foreach { m romanM } { 0 ? 1 i 58 lviii 59 lix } { |
︙ | ︙ | |||
543 544 545 546 547 548 549 | puts $f2 "} {$result}" } } } puts "testcases4: $i test cases." } | | | 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 | puts $f2 "} {$result}" } } } puts "testcases4: $i test cases." } #---------------------------------------------------------------------- # # testcases5 -- # # Generates the test cases for Daylight Saving Time # # Parameters: |
︙ | ︙ | |||
568 569 570 571 572 573 574 | proc testcases5 { f2 } { variable TZData puts $f2 {} puts $f2 "\# Test formatting of Daylight Saving Time" puts $f2 {} | | | | | 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 | proc testcases5 { f2 } { variable TZData puts $f2 {} puts $f2 "\# Test formatting of Daylight Saving Time" puts $f2 {} 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 " 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" foreach row $TZData(:America/Detroit) { foreach { t offset isdst tzname } $row break if { $t > -4000000000000 } { set conds [list detroit] if { $t > wide(0x7fffffff) } { set conds [list detroit y2038] } |
︙ | ︙ | |||
644 645 646 647 648 649 650 | # output file. # #---------------------------------------------------------------------- proc testcases8 { f2 } { # Put out a header describing the tests | | | | | | 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 | # output file. # #---------------------------------------------------------------------- proc testcases8 { f2 } { # Put out a header describing the tests puts $f2 "" puts $f2 "\# Test parsing of ccyymmdd" puts $f2 "" set n 0 foreach year {1970 1971 2000 2001} { foreach month {01 12} { foreach day {02 31} { set scanned [clock scan $year$month$day -gmt true] foreach ccyy {%C%y %Y} { foreach mm {%b %B %h %m %Om %N} { foreach dd {%d %Od %e %Oe} { set string [clock format $scanned \ -format "$ccyy $mm $dd" \ -locale en_US_roman \ -gmt true] 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" } } } foreach fmt {%x %D} { set string [clock format $scanned \ -format $fmt \ -locale en_US_roman \ -gmt true] puts $f2 "test clock-8.[incr n] {parse ccyymmdd} {" puts $f2 " [list clock scan $string -format $fmt -locale en_US_roman -gmt 1]" |
︙ | ︙ | |||
704 705 706 707 708 709 710 | # to f2. # #---------------------------------------------------------------------- proc testcases11 { f2 } { # Put out a header describing the tests | | | | 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 | # to f2. # #---------------------------------------------------------------------- proc testcases11 { f2 } { # Put out a header describing the tests puts $f2 "" puts $f2 "\# Test precedence among yyyymmdd and yyyyddd" puts $f2 "" array set v { Y 1970 m 01 d 01 j 002 } |
︙ | ︙ | |||
767 768 769 770 771 772 773 | # output file. # #---------------------------------------------------------------------- proc testcases12 { f2 } { # Put out a header describing the tests | | | | | 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 | # output file. # #---------------------------------------------------------------------- proc testcases12 { f2 } { # Put out a header describing the tests puts $f2 "" puts $f2 "\# Test parsing of ccyyWwwd" puts $f2 "" set n 0 foreach year {1970 1971 2000 2001} { foreach month {01 12} { foreach day {02 31} { set scanned [clock scan $year$month$day -gmt true] foreach d {%a %A %u %w %Ou %Ow} { set string [clock format $scanned \ -format "%G W%V $d" \ |
︙ | ︙ | |||
813 814 815 816 817 818 819 | # Test cases for parsing yymmdd dates are output. # #---------------------------------------------------------------------- proc testcases14 { f2 } { # Put out a header describing the tests | | | | | | 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 | # Test cases for parsing yymmdd dates are output. # #---------------------------------------------------------------------- proc testcases14 { f2 } { # Put out a header describing the tests puts $f2 "" puts $f2 "\# Test parsing of yymmdd" puts $f2 "" set n 0 foreach year {1938 1970 2000 2037} { foreach month {01 12} { foreach day {02 31} { set scanned [clock scan $year$month$day -gmt true] foreach yy {%y %Oy} { foreach mm {%b %B %h %m %Om %N} { foreach dd {%d %Od %e %Oe} { set string [clock format $scanned \ -format "$yy $mm $dd" \ -locale en_US_roman \ -gmt true] 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 "testcases14: $n test cases" } |
︙ | ︙ | |||
864 865 866 867 868 869 870 | # output file. # #---------------------------------------------------------------------- proc testcases17 { f2 } { # Put out a header describing the tests | | | | | 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 | # output file. # #---------------------------------------------------------------------- proc testcases17 { f2 } { # Put out a header describing the tests puts $f2 "" puts $f2 "\# Test parsing of yyWwwd" puts $f2 "" set n 0 foreach year {1970 1971 2000 2001} { foreach month {01 12} { foreach day {02 31} { set scanned [clock scan $year$month$day -gmt true] foreach d {%a %A %u %w %Ou %Ow} { set string [clock format $scanned \ -format "%g W%V $d" \ |
︙ | ︙ | |||
910 911 912 913 914 915 916 | # Test cases for parsing mmdd dates are output. # #---------------------------------------------------------------------- proc testcases19 { f2 } { # Put out a header describing the tests | | | | | | 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 | # Test cases for parsing mmdd dates are output. # #---------------------------------------------------------------------- proc testcases19 { f2 } { # Put out a header describing the tests puts $f2 "" puts $f2 "\# Test parsing of mmdd" puts $f2 "" set n 0 foreach year {1938 1970 2000 2037} { set base [clock scan ${year}0101 -gmt true] foreach month {01 12} { foreach day {02 31} { set scanned [clock scan $year$month$day -gmt true] foreach mm {%b %B %h %m %Om %N} { foreach dd {%d %Od %e %Oe} { set string [clock format $scanned \ -format "$mm $dd" \ -locale en_US_roman \ -gmt true] 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 "testcases19: $n test cases" } |
︙ | ︙ | |||
960 961 962 963 964 965 966 | # output file. # #---------------------------------------------------------------------- proc testcases22 { f2 } { # Put out a header describing the tests | | | | | 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 | # output file. # #---------------------------------------------------------------------- proc testcases22 { f2 } { # Put out a header describing the tests puts $f2 "" puts $f2 "\# Test parsing of Wwwd" puts $f2 "" set n 0 foreach year {1970 1971 2000 2001} { set base [clock scan ${year}0104 -gmt true] foreach month {03 10} { foreach day {01 31} { set scanned [clock scan $year$month$day -gmt true] foreach d {%a %A %u %w %Ou %Ow} { set string [clock format $scanned \ |
︙ | ︙ | |||
1007 1008 1009 1010 1011 1012 1013 | # Test cases for parsing naked day of the month are output. # #---------------------------------------------------------------------- proc testcases24 { f2 } { # Put out a header describing the tests | | | | | | 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 | # Test cases for parsing naked day of the month are output. # #---------------------------------------------------------------------- proc testcases24 { f2 } { # Put out a header describing the tests puts $f2 "" puts $f2 "\# Test parsing of naked day-of-month" puts $f2 "" set n 0 foreach year {1970 2000} { foreach month {01 12} { set base [clock scan ${year}${month}01 -gmt true] foreach day {02 28} { set scanned [clock scan $year$month$day -gmt true] foreach dd {%d %Od %e %Oe} { set string [clock format $scanned \ -format "$dd" \ -locale en_US_roman \ -gmt true] 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 "testcases24: $n test cases" } |
︙ | ︙ | |||
1055 1056 1057 1058 1059 1060 1061 | # output file. # #---------------------------------------------------------------------- proc testcases26 { f2 } { # Put out a header describing the tests | | | | | 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 | # output file. # #---------------------------------------------------------------------- proc testcases26 { f2 } { # Put out a header describing the tests puts $f2 "" puts $f2 "\# Test parsing of naked day of week" puts $f2 "" set n 0 foreach year {1970 2001} { foreach week {01 52} { set base [clock scan ${year}W${week}4 \ -format %GW%V%u -gmt true] foreach day {1 7} { set scanned [clock scan ${year}W${week}${day} \ -format %GW%V%u -gmt true] |
︙ | ︙ | |||
1104 1105 1106 1107 1108 1109 1110 | # Writes the tests. # #---------------------------------------------------------------------- proc testcases29 { f2 } { # Put out a header describing the tests | | | 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 | # Writes the tests. # #---------------------------------------------------------------------- proc testcases29 { f2 } { # Put out a header describing the tests puts $f2 "" puts $f2 "\# Test parsing of time of day" puts $f2 "" set n 0 foreach hour {0 1 11 12 13 23} \ hampm {12 1 11 12 1 11} \ |
︙ | ︙ | |||
1168 1169 1170 1171 1172 1173 1174 | 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" } } } | | | 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 | 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 "testcases29: $n test cases" } processFile $d |
Changes to tools/man2help.tcl.
︙ | ︙ | |||
32 33 34 35 36 37 38 | if {[string compare $lastSection $section]} { puts $fd "1 $section" } set lastSection $section set lastTopic {} foreach topic [getTopics $package $section] { if {[string compare $lastTopic $topic]} { | | | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | if {[string compare $lastSection $section]} { puts $fd "1 $section" } set lastSection $section set lastTopic {} foreach topic [getTopics $package $section] { if {[string compare $lastTopic $topic]} { set id $topics($package,$section,$topic) puts $fd "2 $topic=$id" set lastTopic $topic } } } } close $fd |
︙ | ︙ |
Changes to tools/man2html.tcl.
︙ | ︙ | |||
23 24 25 26 27 28 29 | proc sarray {file args} { set file [open $file w] foreach a $args { upvar $a array if {![array exists array]} { puts "sarray: \"$a\" isn't an array" break | | | | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | proc sarray {file args} { set file [open $file w] foreach a $args { upvar $a array if {![array exists array]} { puts "sarray: \"$a\" isn't an array" break } foreach name [lsort [array names array]] { regsub -all " " $name "\\ " name1 puts $file "set ${a}($name1) \{$array($name)\}" } } close $file } |
︙ | ︙ | |||
137 138 139 140 141 142 143 | set footer [footer $packages] # make the hyperlink arrays and contents.html for all packages foreach package $packages { file mkdir $html_dir/$package | | | | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 | set footer [footer $packages] # make the hyperlink arrays and contents.html for all packages foreach package $packages { file mkdir $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] doDir $tcl_dir/$package/doc # clean up the NAME_file and KEY_file database arrays # catch {unset KEY_file()} foreach name [lsort [array names NAME_file]] { set file_name $NAME_file($name) |
︙ | ︙ |
Changes to tools/man2html1.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 | # man2html1.tcl -- # # This file defines procedures that are used during the first pass of the # man page to html conversion process. It is sourced by h.tcl. # # Copyright (c) 1996 by Sun Microsystems, Inc. package require Tcl 8.4 # Global variables used by these scripts: # # state - state variable that controls action of text proc. | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | # man2html1.tcl -- # # This file defines procedures that are used during the first pass of the # man page to html conversion process. It is sourced by h.tcl. # # Copyright (c) 1996 by Sun Microsystems, Inc. package require Tcl 8.4 # Global variables used by these scripts: # # state - state variable that controls action of text proc. # # curFile - tail of current man page. # # file - file pointer; for both xref.tcl and contents.html # # NAME_file - array indexed by NAME and containing file names used # for hyperlinks. # # KEY_file - array indexed by KEYWORD and containing file names used # for hyperlinks. # # lib - contains package name. Used to label section in contents.html # # inDT - in dictionary term. # text -- # # This procedure adds entries to the hypertext arrays NAME_file # and KEY_file. # # DT: might do this: if first word of $dt matches $name and [llength $name==1] # and [llength $dt > 1], then add to NAME_file. # # Arguments: # string - Text to index. proc text string { global state curFile NAME_file KEY_file inDT |
︙ | ︙ | |||
82 83 84 85 86 87 88 | } } DESCRIPTION {set state DT} INTRODUCTION {set state DT} KEYWORDS {set state KEY} default {set state OFF} } | | | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 | } } DESCRIPTION {set state DT} INTRODUCTION {set state DT} KEYWORDS {set state KEY} default {set state OFF} } } TP { global inDT set inDT 1 } TH { global lib state inDT |
︙ | ︙ | |||
134 135 136 137 138 139 140 | global inDT set inDT 0 } # initGlobals, tab, font, char, macro2 -- # | | | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 | global inDT set inDT 0 } # initGlobals, tab, font, char, macro2 -- # # These procedures do nothing during the first pass. # # Arguments: # None. proc initGlobals {} {} proc tab {} {} proc font type {} |
︙ | ︙ | |||
210 211 212 213 214 215 216 | # file - name of the contents file. # packageName - string used in the title and sub-heads of the HTML # page. Normally name of the package without version # numbers. proc doContents {file packageName} { global footer | | | | | | 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 | # file - name of the contents file. # packageName - string used in the title and sub-heads of the HTML # page. Normally name of the package without version # numbers. proc doContents {file packageName} { global footer set file [open $file w] puts $file "<HTML><HEAD><TITLE>$packageName Manual</TITLE></HEAD><BODY>" puts $file "<H3>$packageName</H3>" doListing $file "*.1" puts $file "<HR><H3>$packageName Commands</H3>" doListing $file "*.n" puts $file "<HR><H3>$packageName Library</H3>" doListing $file "*.3" puts $file $footer puts $file "</BODY></HTML>" close $file } # do -- # # This is the toplevel procedure that searches a man page # for hypertext links. It builds a data base consisting of # two arrays: NAME_file and KEY file. It runs the man2tcl # program to turn the man page into a script, then it evals # that script. # # Arguments: # fileName - Name of the file to scan. proc do fileName { global curFile |
︙ | ︙ |
Changes to tools/mkdepend.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 | #============================================================================== # # mkdepend : generate dependency information from C/C++ files # # Copyright (c) 1998, Nat Pryce # # Permission is hereby granted, without written agreement and without # license or royalty fees, to use, copy, modify, and distribute this # software and its documentation for any purpose, provided that the # above copyright notice and the following two paragraphs appear in # all copies of this software. # | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | #============================================================================== # # mkdepend : generate dependency information from C/C++ files # # Copyright (c) 1998, Nat Pryce # # Permission is hereby granted, without written agreement and without # license or royalty fees, to use, copy, modify, and distribute this # software and its documentation for any purpose, provided that the # above copyright notice and the following two paragraphs appear in # all copies of this software. # # IN NO EVENT SHALL THE AUTHOR BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, # SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF # THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE AUTHOR HAS BEEN ADVISED # OF THE POSSIBILITY OF SUCH DAMAGE. # # THE AUTHOR SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING, BUT NOT # LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A # PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS" # BASIS, AND THE AUTHOR HAS NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, # UPDATES, ENHANCEMENTS, OR MODIFICATIONS. #============================================================================== # # Modified heavily by David Gravereaux <[email protected]> about 9/17/2006. # Original can be found @ # http://web.archive.org/web/20070616205924/http://www.doc.ic.ac.uk/~np2/software/mkdepend.html #============================================================================== array set mode_data {} set mode_data(vc32) {cl -nologo -E} set source_extensions [list .c .cpp .cxx .cc] |
︙ | ︙ |