Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | add selected tcllib upstream changes |
---|---|
Timelines: | family | ancestors | descendants | both | trunk |
Files: | files | file ages | folders |
SHA1: |
17beea27ed24a65114cd3a3e329fbd3e |
User & Date: | chw 2019-06-26 04:11:15.794 |
Context
2019-06-26
| ||
10:47 | improve twv examples check-in: 3ca786aced user: chw tags: trunk | |
04:11 | add selected tcllib upstream changes check-in: 17beea27ed user: chw tags: trunk | |
03:49 | add selected tcl upstream changes check-in: f9c437786a user: chw tags: trunk | |
Changes
Changes to assets/tcllib1.19/fileutil/fileutil.tcl.
︙ | ︙ | |||
622 623 624 625 626 627 628 | } return $path } } # ::fileutil::jail -- # | | | | 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 | } return $path } } # ::fileutil::jail -- # # Ensures that the input path 'filename' stays within the # directory 'jail'. In this way it prevents user-supplied paths # from escaping the jail. # # Arguments: # jail The path to the directory the other must # not escape from. # filename The path to prevent from escaping. # |
︙ | ︙ |
Changes to assets/tcllib1.19/html/html.tcl.
︙ | ︙ | |||
11 12 13 14 15 16 17 | # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Originally by Brent Welch, with help from Dan Kuchler and Melissa Chawla package require Tcl 8.2 package require ncgi | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Originally by Brent Welch, with help from Dan Kuchler and Melissa Chawla package require Tcl 8.2 package require ncgi package provide html 1.5 namespace eval ::html { # State about the current page variable page |
︙ | ︙ | |||
477 478 479 480 481 482 483 484 485 | # # Arguments: # args A name-value list of meta tag names and values. # # Side Effects: # Stores HTML for the <meta> tag for use later by html::head proc ::html::meta {args} { variable page | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > | 477 478 479 480 481 482 483 484 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 | # # Arguments: # args A name-value list of meta tag names and values. # # Side Effects: # Stores HTML for the <meta> tag for use later by html::head # Ref: https://www.w3schools.com/tags/tag_meta.asp proc ::html::meta {args} { # compatibility command variable page append html "" ::foreach {name value} $args { append html "<meta name=\"$name\" content=\"[quoteFormValue $value]\">" } lappend page(meta) $html return "" } proc ::html::meta_name {args} { variable page append html "" ::foreach {name value} $args { append html "<meta name=\"$name\" content=\"[quoteFormValue $value]\">" } lappend page(meta) $html return "" } proc ::html::meta_charset {charset} { variable page append html "<meta charset=\"[quoteFormValue $charset]\">" lappend page(meta) $html return "" } proc ::html::meta_equiv {args} { variable page append html "" ::foreach {name value} $args { append html "<meta http-equiv=\"$name\" content=\"[quoteFormValue $value]\">" } lappend page(meta) $html return "" } # ::html::refresh # # Generate a meta refresh tag. This tag gets bundled into the <head> |
︙ | ︙ | |||
579 580 581 582 583 584 585 | return "" } # ::html::tagParam # # Return a name, value string for the tag parameters. # The values come from "hard-wired" values in the | | | 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 | return "" } # ::html::tagParam # # Return a name, value string for the tag parameters. # The values come from "hard-wired" values in the # param argument, or from the defaults set with html::init. # # Arguments: # tag Name of the HTML tag (case insensitive). # param pname=value info that overrides any default values # # Results # A string of the form: |
︙ | ︙ | |||
920 921 922 923 924 925 926 | # ::html::submit -- # # Format a submit button. # # Arguments: # label The string to appear in the submit button. | | > > < | | > > | 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 | # ::html::submit -- # # Format a submit button. # # Arguments: # label The string to appear in the submit button. # name The name for the submit button element. # title The string to appear on the submit button. # Optional. If not specified no title is shown. # # Results: # The html fragment proc ::html::submit {label {name submit} {title {}}} { ::set html "<input type=\"submit\" name=\"$name\" value=\"$label\"" ::if {$title != ""} { append html " title=\"$title\"" } append html ">\n" } # ::html::varEmpty -- # # Return true if the variable doesn't exist or is an empty string # # Arguments: |
︙ | ︙ | |||
1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 | } proc ::html::h6 {string {param {}}} { html::h 6 $string $param } proc ::html::h {level string {param {}}} { return "<[string trimright "h$level [tagParam h$level $param]"]>$string</h$level>\n" } # ::html::openTag # Remember that a tag is opened so it can be closed later. # This is used to automatically clean up at the end of a page. # # Arguments: # tag The HTML tag name | > > > > > > > > > > > > > > > > > > > > > > > > | 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 | } proc ::html::h6 {string {param {}}} { html::h 6 $string $param } proc ::html::h {level string {param {}}} { return "<[string trimright "h$level [tagParam h$level $param]"]>$string</h$level>\n" } # ::html::wrapTag # Takes an optional text and wraps it in a tag pair, along with # optional attributes for the tag # # Arguments: # tag The HTML tag name # text Optional text to insert between open/close tag # args List of optional attributes and values to use for the tag # # Results: # String with the text wrapped in the open/close tag proc ::html::wrapTag {tag {text ""} args} { ::set html "" ::set params "" ::foreach {i j} $args { append params "$i=\"[quoteFormValue $j]\" " } append html [openTag $tag [string trimright $params]] append html $text append html [closeTag] return $html } # ::html::openTag # Remember that a tag is opened so it can be closed later. # This is used to automatically clean up at the end of a page. # # Arguments: # tag The HTML tag name |
︙ | ︙ |
Changes to assets/tcllib1.19/html/pkgIndex.tcl.
1 | if {![package vsatisfies [package provide Tcl] 8.2]} {return} | | | 1 2 | if {![package vsatisfies [package provide Tcl] 8.2]} {return} package ifneeded html 1.5 [list source [file join $dir html.tcl]] |
Changes to assets/tcllib1.19/log/loggerAppender.tcl.
1 2 | ##Library Header # | < | 1 2 3 4 5 6 7 8 9 | ##Library Header # # Copyright (c) 2005 Cisco Systems, Inc. # # Name: # ::logger::appender # # Purpose: # collection of appenders for tcllib logger |
︙ | ︙ | |||
69 70 71 72 73 74 75 | emergency red-bold } } ##Procedure Header | < | 68 69 70 71 72 73 74 75 76 77 78 79 80 81 | emergency red-bold } } ##Procedure Header # Copyright (c) 2005 Cisco Systems, Inc. # # Name: # ::logger::appender::console # # Purpose: # |
︙ | ︙ | |||
172 173 174 175 176 177 178 | set myProcNameVar $procName return $procText } ##Procedure Header | < | 170 171 172 173 174 175 176 177 178 179 180 181 182 183 | set myProcNameVar $procName return $procText } ##Procedure Header # Copyright (c) 2005 Cisco Systems, Inc. # # Name: # ::logger::appender::colorConsole # # Purpose: # |
︙ | ︙ | |||
279 280 281 282 283 284 285 | -category $service \ -priority $level ] set myProcNameVar $procName return $procText } ##Procedure Header | < | 276 277 278 279 280 281 282 283 284 285 286 287 288 289 | -category $service \ -priority $level ] set myProcNameVar $procName return $procText } ##Procedure Header # Copyright (c) 2005 Cisco Systems, Inc. # # Name: # ::logger::appender::fileAppend # # Purpose: # |
︙ | ︙ | |||
391 392 393 394 395 396 397 | return $procText } ##Internal Procedure Header | < | 387 388 389 390 391 392 393 394 395 396 397 398 399 400 | return $procText } ##Internal Procedure Header # Copyright (c) 2005 Cisco Systems, Inc. # # Name: # ::logger::appender::genProcName # # Purpose: # |
︙ | ︙ |
Changes to assets/tcllib1.19/log/loggerUtils.tcl.
1 2 | ##Library Header # | < | 1 2 3 4 5 6 7 8 9 | ##Library Header # # Copyright (c) 2005 Cisco Systems, Inc. # # Name: # ::logger::utils:: # # Purpose: # an extension to the tcllib logger module |
︙ | ︙ | |||
55 56 57 58 59 60 61 | logger::import -force -namespace log logger::utils # @mdgen OWNER: msgs/*.msg ::msgcat::mcload [file join $packageDir msgs] } ##Internal Procedure Header | < | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | logger::import -force -namespace log logger::utils # @mdgen OWNER: msgs/*.msg ::msgcat::mcload [file join $packageDir msgs] } ##Internal Procedure Header # Copyright (c) 2005 Cisco Systems, Inc. # # Name: # ::logger::utils::createFormatCmd # # Purpose: # |
︙ | ︙ | |||
160 161 162 163 164 165 166 | return $text } ##Procedure Header | < | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 | return $text } ##Procedure Header # Copyright (c) 2005 Cisco Systems, Inc. # # Name: # ::logger::utils::createLogProc # # Purpose: # |
︙ | ︙ | |||
266 267 268 269 270 271 272 273 274 275 | } if {[regexp {%M} $text]} { set methodText { if {[info level] < 2} { set method "global" } else { set method [lindex [info level -1] 0] } | > > > < | 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 | } if {[regexp {%M} $text]} { set methodText { if {[info level] < 2} { set method "global" } elseif {[uplevel 1 {namespace which self}] == "::oo::Helpers::self"} { set method [uplevel 1 {self class}] append method :: [uplevel 1 {self method}] } else { set method [lindex [info level -1] 0] } } regsub -all -- \ {%M} \ $text \ {$method} \ text |
︙ | ︙ | |||
315 316 317 318 319 320 321 | set procText [subst $procText] return $procText } ##Procedure Header | < | 314 315 316 317 318 319 320 321 322 323 324 325 326 327 | set procText [subst $procText] return $procText } ##Procedure Header # Copyright (c) 2005 Cisco Systems, Inc. # # Name: # ::logger::utils::applyAppender # # Purpose: # |
︙ | ︙ | |||
450 451 452 453 454 455 456 | ${srvCmd}::logproc $lvl $procName } } } ##Internal Procedure Header | < | 448 449 450 451 452 453 454 455 456 457 458 459 460 461 | ${srvCmd}::logproc $lvl $procName } } } ##Internal Procedure Header # Copyright (c) 2005 Cisco Systems, Inc. # # Name: # ::logger::utils::autoApplyAppender # # Purpose: # |
︙ | ︙ | |||
530 531 532 533 534 535 536 | } logger::utils::applyAppender -appender $appender -serviceCmd $log \ -levels $levels -appenderArgs $appenderArgs return $log } | | | 527 528 529 530 531 532 533 534 535 536 537 538 | } logger::utils::applyAppender -appender $appender -serviceCmd $log \ -levels $levels -appenderArgs $appenderArgs return $log } package provide logger::utils 1.3.1 # ;;; Local Variables: *** # ;;; mode: tcl *** # ;;; End: *** |
Changes to assets/tcllib1.19/log/pkgIndex.tcl.
1 2 3 4 5 6 7 8 | if {![package vsatisfies [package provide Tcl] 8]} {return} package ifneeded log 1.4 [list source [file join $dir log.tcl]] if {![package vsatisfies [package provide Tcl] 8.2]} {return} package ifneeded logger 0.9.4 [list source [file join $dir logger.tcl]] package ifneeded logger::appender 1.3 [list source [file join $dir loggerAppender.tcl]] if {![package vsatisfies [package provide Tcl] 8.4]} {return} | | | 1 2 3 4 5 6 7 8 9 | if {![package vsatisfies [package provide Tcl] 8]} {return} package ifneeded log 1.4 [list source [file join $dir log.tcl]] if {![package vsatisfies [package provide Tcl] 8.2]} {return} package ifneeded logger 0.9.4 [list source [file join $dir logger.tcl]] package ifneeded logger::appender 1.3 [list source [file join $dir loggerAppender.tcl]] if {![package vsatisfies [package provide Tcl] 8.4]} {return} package ifneeded logger::utils 1.3.1 [list source [file join $dir loggerUtils.tcl]] |
Changes to assets/tcllib1.19/math/pdf_stat.tcl.
︙ | ︙ | |||
11 12 13 14 15 16 17 | # ::math::statistics -- # Namespace holding the procedures and variables # namespace eval ::math::statistics { namespace export pdf-normal pdf-uniform pdf-lognormal \ | | | | | | 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 | # ::math::statistics -- # Namespace holding the procedures and variables # namespace eval ::math::statistics { namespace export pdf-normal pdf-uniform pdf-lognormal \ pdf-exponential pdf-triangular pdf-symmetric-triangular \ cdf-normal cdf-uniform cdf-lognormal \ cdf-exponential cdf-triangular cdf-symmetric-triangular \ cdf-students-t \ random-normal random-uniform random-lognormal \ random-exponential random-triangular \ histogram-uniform \ pdf-gamma pdf-poisson pdf-chisquare pdf-students-t pdf-beta \ pdf-weibull pdf-gumbel pdf-pareto pdf-cauchy \ cdf-gamma cdf-poisson cdf-chisquare cdf-beta cdf-F \ cdf-weibull cdf-gumbel cdf-pareto cdf-cauchy \ random-gamma random-poisson random-chisquare random-students-t random-beta \ random-weibull random-gumbel random-pareto random-cauchy \ incompleteGamma incompleteBeta \ estimate-pareto empirical-distribution bootstrap estimate-exponential variable cdf_normal_prob {} variable cdf_normal_x {} variable cdf_toms322_cached {} variable initialised_cdf 0 variable twopi [expr {2.0*acos(-1.0)}] variable pi [expr {acos(-1.0)}] |
︙ | ︙ | |||
116 117 118 119 120 121 122 123 124 125 126 127 128 129 | "Wrong order or zero range" } set prob [expr {1.0/($pmax-$pmin)}] if { $x < $pmin || $x > $pmax } { return 0.0 } return $prob } # pdf-exponential -- # Return the probabilities belonging to an exponential # distribution | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 | "Wrong order or zero range" } set prob [expr {1.0/($pmax-$pmin)}] if { $x < $pmin || $x > $pmax } { return 0.0 } return $prob } # pdf-triangular -- # Return the probabilities belonging to a triangular distribution # (parameters as minimum/maximum) # # Arguments: # pmin Minimum of the distribution # pmax Maximum of the distribution # x Value for which the probability must be determined # # Result: # Probability of value x under the given distribution # # Note: # If pmin > pmax, the main weight will be at the larger # values. # proc ::math::statistics::pdf-triangular { pmin pmax x } { if { $pmin == $pmax } { return -code error -errorcode ARG \ -errorinfo "Zero range" \ "Zero range" } if { $pmin < $pmax } { if { $x < $pmin || $x > $pmax } { return 0.0 } } else { if { $x < $pmax || $x > $pmin } { return 0.0 } } set prob [expr {2.0*(1.0-($x-$pmin)/($pmax-$pmin))}] return $prob } # pdf-symmetric-triangular -- # Return the probabilities belonging to a symmetric triangular distribution # (parameters as minimum/maximum) # # Arguments: # pmin Minimum of the distribution # pmax Maximum of the distribution # x Value for which the probability must be determined # # Result: # Probability of value x under the given distribution # proc ::math::statistics::pdf-symmetric-triangular { pmin pmax x } { if { $pmin == $pmax } { return -code error -errorcode ARG \ -errorinfo "Zero range" \ "Zero range" } if { $pmin < $pmax } { if { $x < $pmin || $x > $pmax } { return 0.0 } } else { if { $x < $pmax || $x > $pmin } { return 0.0 } } set diff [expr {abs($pmax-$pmin)}] set centre [expr {($pmax+$pmin)/2.0}] set prob [expr {2./$diff * (1.0 - 2.*abs($x-$centre)/$diff)}] return $prob } # pdf-exponential -- # Return the probabilities belonging to an exponential # distribution |
︙ | ︙ | |||
263 264 265 266 267 268 269 270 271 272 273 274 275 276 | -errorinfo "Wrong order or zero range" \ } set prob [expr {($x-$pmin)/double($pmax-$pmin)}] if { $x < $pmin } { return 0.0 } if { $x > $pmax } { return 1.0 } return $prob } # cdf-exponential -- # Return the cumulative probabilities belonging to an exponential | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 335 336 337 338 339 340 341 342 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 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 | -errorinfo "Wrong order or zero range" \ } set prob [expr {($x-$pmin)/double($pmax-$pmin)}] if { $x < $pmin } { return 0.0 } if { $x > $pmax } { return 1.0 } return $prob } # cdf-triangular -- # Return the cumulative probabilities belonging to a triangular distribution # (parameters as minimum/maximum) # # Arguments: # pmin Minimum of the distribution # pmax Maximum of the distribution # x Value for which the probability must be determined # # Result: # Probability of value x under the given distribution # # Note: # If pmin > pmax, the main weight will be at the larger # values. # proc ::math::statistics::cdf-triangular { pmin pmax x } { if { $pmin == $pmax } { return -code error -errorcode ARG \ -errorinfo "Zero range" \ "Zero range" } if { $pmin < $pmax } { if { $x < $pmin } { return 0.0 } if { $x > $pmax } { return 1.0 } set xm [expr {($x - $pmin) / ($pmax - $pmin)}] set prob [expr {2.0*$xm - $xm**2}] } else { if { $x < $pmax } { return 0.0 } if { $x > $pmin } { return 1.0 } set xm [expr {($x - $pmax) / ($pmin - $pmax)}] set prob [expr {$xm**2}] } return $prob } # cdf-symmetric-triangular -- # Return the cumulative probabilities belonging to a symmetric triangular distribution # (parameters as minimum/maximum) # # Arguments: # pmin Minimum of the distribution # pmax Maximum of the distribution # x Value for which the probability must be determined # # Result: # Probability of value x under the given distribution # proc ::math::statistics::cdf-symmetric-triangular { pmin pmax x } { if { $pmin == $pmax } { return -code error -errorcode ARG \ -errorinfo "Zero range" \ "Zero range" } set diff [expr {abs($pmax-$pmin)/2.0}] set centre [expr {($pmax+$pmin)/2.0}] if { $pmin < $pmax } { if { $x < $pmin } { return 0.0 } if { $x > $pmax } { return 1.0 } } else { if { $x < $pmax } { return 0.0 } if { $x > $pmin } { return 1.0 } } if { $x < $centre } { set xm [expr {($x - $centre + $diff) / $diff}] set prob [expr {0.5 * $xm**2}] } else { set xm [expr {($x - $centre - $diff) / $diff}] set prob [expr {1.0 - 0.5 * $xm**2}] } return $prob } # cdf-exponential -- # Return the cumulative probabilities belonging to an exponential |
︙ | ︙ | |||
479 480 481 482 483 484 485 486 487 488 489 490 491 492 | "Wrong order or zero range" } set result {} for { set i 0 } {$i < $number } { incr i } { lappend result [Inverse-cdf-uniform $pmin $pmax [expr {rand()}]] } return $result } # random-exponential -- # Return a list of random numbers satisfying an exponential | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 | "Wrong order or zero range" } set result {} for { set i 0 } {$i < $number } { incr i } { lappend result [Inverse-cdf-uniform $pmin $pmax [expr {rand()}]] } return $result } # random-triangular -- # Return a list of random numbers satisfying a triangular # distribution (parameters as minimum/maximum) # # Arguments: # pmin Minimum of the distribution # pmax Maximum of the distribution # number Number of values to generate # # Result: # List of random numbers # proc ::math::statistics::random-triangular { pmin pmax number } { if { $pmin == $pmax } { return -code error -errorcode ARG \ -errorinfo "Zero range" \ "Zero range" } set diff [expr {$pmax - $pmin}] if { $pmin < $pmax } { set result {} for { set i 0 } {$i < $number } { incr i } { set r [expr {1.0 - sqrt(1.0 - rand())}] lappend result [expr {$pmin + $r * $diff}] } } else { set result {} for { set i 0 } {$i < $number } { incr i } { lappend result [expr {$pmax - sqrt(rand()) * $diff}] } } return $result } # random-symmetric-triangular -- # Return a list of random numbers satisfying a symmetric triangular # distribution (parameters as minimum/maximum) # # Arguments: # pmin Minimum of the distribution # pmax Maximum of the distribution # number Number of values to generate # # Result: # List of random numbers # proc ::math::statistics::random-symmetric-triangular { pmin pmax number } { if { $pmin == $pmax } { return -code error -errorcode ARG \ -errorinfo "Zero range" \ "Zero range" } set diff2 [expr {0.5 * ($pmax - $pmin)}] set result {} for { set i 0 } {$i < $number } { incr i } { lappend result [expr {$pmin + $diff2 * (rand() + rand())}] } return $result } # random-exponential -- # Return a list of random numbers satisfying an exponential |
︙ | ︙ | |||
1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 | set sum [expr {$sum + log($v) - log($scale)}] } set shape [expr {$n / $sum}] return [list $scale $shape [expr {$shape/sqrt($n)}]] } # empirical-distribution -- # Determine the empirical distribution # # Arguments: # values Values that are to be examined # | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 | set sum [expr {$sum + log($v) - log($scale)}] } set shape [expr {$n / $sum}] return [list $scale $shape [expr {$shape/sqrt($n)}]] } # estimate-exponential -- # Estimate the parameter of an exponential distribution # # Arguments: # values Values that are supposed to be exponentially distributed # # Result: # Estimate of the one parameter of the exponential distribution # as well as the asymptotic standard deviation # (See https://www.statlect.com/fundamentals-of-statistics/exponential-distribution-maximum-likelihood) # proc ::math::statistics::estimate-exponential { values } { set sum 0.0 set count 0 foreach v $values { if { $v != "" } { set sum [expr {$sum + $v}] incr count } } set parameter [expr {$sum/double($count)}] set stdev [expr {$parameter / sqrt($count)}] return [list $parameter $stdev] } # empirical-distribution -- # Determine the empirical distribution # # Arguments: # values Values that are to be examined # |
︙ | ︙ |
Changes to assets/tcllib1.19/math/pkgIndex.tcl.
︙ | ︙ | |||
18 19 20 21 22 23 24 | package ifneeded math::bigfloat 1.2.2 [list source [file join $dir bigfloat.tcl]] package ifneeded math::machineparameters 0.1 [list source [file join $dir machineparameters.tcl]] if {![package vsatisfies [package provide Tcl] 8.5]} {return} package ifneeded math::calculus 0.8.1 [list source [file join $dir calculus.tcl]] # statistics depends on linearalgebra (for multi-variate linear regression). # statistics depends on optimize (for logistic regression). | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | package ifneeded math::bigfloat 1.2.2 [list source [file join $dir bigfloat.tcl]] package ifneeded math::machineparameters 0.1 [list source [file join $dir machineparameters.tcl]] if {![package vsatisfies [package provide Tcl] 8.5]} {return} package ifneeded math::calculus 0.8.1 [list source [file join $dir calculus.tcl]] # statistics depends on linearalgebra (for multi-variate linear regression). # statistics depends on optimize (for logistic regression). package ifneeded math::statistics 1.3.1 [list source [file join $dir statistics.tcl]] package ifneeded math::linearalgebra 1.1.6 [list source [file join $dir linalg.tcl]] package ifneeded math::calculus::symdiff 1.0.1 [list source [file join $dir symdiff.tcl]] package ifneeded math::bigfloat 2.0.2 [list source [file join $dir bigfloat2.tcl]] package ifneeded math::numtheory 1.1.1 [list source [file join $dir numtheory.tcl]] package ifneeded math::decimal 1.0.3 [list source [file join $dir decimal.tcl]] package ifneeded math::geometry 1.3.0 [list source [file join $dir geometry.tcl]] package ifneeded math::trig 1.0 [list source [file join $dir trig.tcl]] |
︙ | ︙ |
Changes to assets/tcllib1.19/math/statistics.tcl.
︙ | ︙ | |||
19 20 21 22 23 24 25 | # version 0.9: added kernel density estimation # version 0.9.3: added histogram-alt, corrected test-normal # version 1.0: added test-anova-F # version 1.0.1: correction in pdf-lognormal and cdf-lognormal # version 1.1: added test-Tukey-range and test-Dunnett # version 1.3: added wasserstein-distance, kl-divergence and logit regression | | | | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | # version 0.9: added kernel density estimation # version 0.9.3: added histogram-alt, corrected test-normal # version 1.0: added test-anova-F # version 1.0.1: correction in pdf-lognormal and cdf-lognormal # version 1.1: added test-Tukey-range and test-Dunnett # version 1.3: added wasserstein-distance, kl-divergence and logit regression package require Tcl 8.5 ; # 8.5+ feature in test-anova-F and others: **-operator package provide math::statistics 1.3.1 package require math if {![llength [info commands ::lrepeat]]} { # Forward portability, emulate lrepeat proc ::lrepeat {n args} { if {$n < 1} { return -code error "must have a count of at least 1" |
︙ | ︙ |
Changes to assets/tcllib1.19/mime/mime.tcl.
︙ | ︙ | |||
19 20 21 22 23 24 25 | # Influenced by Borenstein's/Rose's safe-tcl (circa 1993) and Darren New's # unpublished package of 1999. # # new string features and inline scan are used, requiring 8.3. package require Tcl 8.5 | | | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | # Influenced by Borenstein's/Rose's safe-tcl (circa 1993) and Darren New's # unpublished package of 1999. # # new string features and inline scan are used, requiring 8.3. package require Tcl 8.5 package provide mime 1.6.2 if {[catch {package require Trf 2.0}]} { # Fall-back to tcl-based procedures of base64 and quoted-printable encoders # Warning! # These are a fragile emulations of the more general calling sequence # that appears to work with this code here. |
︙ | ︙ | |||
326 327 328 329 330 331 332 | shiftjis MS_Kanji utf-8 UTF8 } namespace export initialize finalize getproperty \ getheader setheader \ getbody \ | | | 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 | shiftjis MS_Kanji utf-8 UTF8 } namespace export initialize finalize getproperty \ getheader setheader \ getbody \ buildmessage copymessage \ mapencoding \ reversemapencoding \ parseaddress \ parsedatetime \ uniqueID } |
︙ | ︙ | |||
2168 2169 2170 2171 2172 2173 2174 | # the boundary delimiter line rather than part of # the preceding part. # # - The above means that the CRLF before $boundary # is needed per the RFC, and the parts must not # have a closing CRLF of their own. See Tcllib bug # 1213527, and patch 1254934 for the problems when | | | 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 | # the boundary delimiter line rather than part of # the preceding part. # # - The above means that the CRLF before $boundary # is needed per the RFC, and the parts must not # have a closing CRLF of their own. See Tcllib bug # 1213527, and patch 1254934 for the problems when # both file/string branches added CRLF after the # body parts. foreach part $state(parts) { append result "\r\n--$boundary\r\n" append result [buildmessage $part] } append result "\r\n--$boundary--\r\n" |
︙ | ︙ | |||
2523 2524 2525 2526 2527 2528 2529 | } # ::mime::qp_decode -- # # Tcl version of quote-printable decode # # Arguments: | | | 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 | } # ::mime::qp_decode -- # # Tcl version of quote-printable decode # # Arguments: # string The quoted-printable string to decode. # encoded_word Boolean value to determine whether or not encoded words # (RFC 2047) should be handled or not. (optional) # # Results: # The decoded string is returned. proc ::mime::qp_decode {string {encoded_word 0}} { |
︙ | ︙ |
Changes to assets/tcllib1.19/mime/pkgIndex.tcl.
1 2 3 | if {![package vsatisfies [package provide Tcl] 8.3]} {return} package ifneeded smtp 1.5 [list source [file join $dir smtp.tcl]] if {![package vsatisfies [package provide Tcl] 8.5]} {return} | | | 1 2 3 4 | if {![package vsatisfies [package provide Tcl] 8.3]} {return} package ifneeded smtp 1.5 [list source [file join $dir smtp.tcl]] if {![package vsatisfies [package provide Tcl] 8.5]} {return} package ifneeded mime 1.6.2 [list source [file join $dir mime.tcl]] |
Changes to assets/tcllib1.19/ncgi/ncgi.tcl.
︙ | ︙ | |||
26 27 28 29 30 31 32 | # of decoding them. # We use newer string routines package require Tcl 8.4 package require fileutil ; # Required by importFile. package require uri | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | # of decoding them. # We use newer string routines package require Tcl 8.4 package require fileutil ; # Required by importFile. package require uri package provide ncgi 1.4.4 namespace eval ::ncgi { # "query" holds the raw query (i.e., form) data # This is treated as a cache, too, so you can call ncgi::query more than # once |
︙ | ︙ | |||
267 268 269 270 271 272 273 | proc ::ncgi::decode {str} { # rewrite "+" back to space # protect \ from quoting another '\' set str [string map [list + { } "\\" "\\\\" \[ \\\[ \] \\\]] $str] # prepare to process all %-escapes | | | | | 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 | proc ::ncgi::decode {str} { # rewrite "+" back to space # protect \ from quoting another '\' set str [string map [list + { } "\\" "\\\\" \[ \\\[ \] \\\]] $str] # prepare to process all %-escapes regsub -all -nocase -- {%([E][A-F0-9])%([89AB][A-F0-9])%([89AB][A-F0-9])} \ $str {[encoding convertfrom utf-8 [DecodeHex \1\2\3]]} str regsub -all -nocase -- {%([CDcd][A-F0-9])%([89AB][A-F0-9])} \ $str {[encoding convertfrom utf-8 [DecodeHex \1\2]]} str regsub -all -nocase -- {%([A-F0-9][A-F0-9])} $str {\\u00\1} str # process \u unicode mapped chars return [subst -novar $str] } # ::ncgi::encode # |
︙ | ︙ |
Changes to assets/tcllib1.19/ncgi/pkgIndex.tcl.
1 | if {![package vsatisfies [package provide Tcl] 8.4]} {return} | | | 1 2 | if {![package vsatisfies [package provide Tcl] 8.4]} {return} package ifneeded ncgi 1.4.4 [list source [file join $dir ncgi.tcl]] |
Changes to assets/tcllib1.19/profiler/pkgIndex.tcl.
1 | if {![package vsatisfies [package provide Tcl] 8.3]} {return} | | | 1 2 | if {![package vsatisfies [package provide Tcl] 8.3]} {return} package ifneeded profiler 0.4 [list source [file join $dir profiler.tcl]] |
Changes to assets/tcllib1.19/profiler/profiler.tcl.
1 2 3 4 5 6 7 8 | # profiler.tcl -- # # Tcl code profiler. # # Copyright (c) 1998-2000 by Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | | < < | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # profiler.tcl -- # # Tcl code profiler. # # Copyright (c) 1998-2000 by Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package require Tcl 8.3 ;# uses [clock clicks -milliseconds] package provide profiler 0.4 namespace eval ::profiler {} # ::profiler::tZero -- # # Start a named timer instance # # Arguments: # tag name for the timer instance; if none is given, defaults to "" |
︙ | ︙ | |||
226 227 228 229 230 231 232 233 | # # Results: # None proc ::profiler::leaveHandler {name caller} { variable enabled if { !$enabled($name) } { | > > > | > > | 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 249 250 251 252 253 254 255 256 257 258 | # # Results: # None proc ::profiler::leaveHandler {name caller} { variable enabled # Tkt [0dd4b31bb8] Note that the result is pulled from the # caller's context as it is not passed into leaveHandler if { !$enabled($name) } { return [uplevel 1 {lindex $args 1}] ;# RETURN RESULT! } set t [::profiler::tMark $name.$caller] lappend ::profiler::statTime($name) $t if { [incr ::profiler::callCount($name)] == 1 } { set ::profiler::compileTime($name) $t } incr ::profiler::totalRuntime($name) $t if { [catch {incr ::profiler::descendantTime($caller) $t}] } { set ::profiler::descendantTime($caller) $t } if { [catch {incr ::profiler::descendants($caller,$name)}] } { set ::profiler::descendants($caller,$name) 1 } return [uplevel 1 {lindex $args 1}] ;# RETURN RESULT! } # ::profiler::profProc -- # # Replacement for the proc command that adds rudimentary profiling # capabilities to Tcl. # |
︙ | ︙ | |||
631 632 633 634 635 636 637 | set paused 0 foreach name [array names callCount $pattern] { set enabled($name) 1 } return } | < | 633 634 635 636 637 638 639 | set paused 0 foreach name [array names callCount $pattern] { set enabled($name) 1 } return } |
Changes to assets/tcllib1.19/simulation/pkgIndex.tcl.
|
| | | 1 2 3 | package ifneeded simulation::random 0.4.0 [list source [file join $dir random.tcl]] package ifneeded simulation::montecarlo 0.1 [list source [file join $dir montecarlo.tcl]] package ifneeded simulation::annealing 0.2 [list source [file join $dir annealing.tcl]] |
Changes to assets/tcllib1.19/simulation/random.tcl.
︙ | ︙ | |||
428 429 430 431 432 433 434 435 436 | set z [expr {DEPTH*rand()}] return [list $x $y $z] }] return $name } # Announce the package # | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 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 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 | set z [expr {DEPTH*rand()}] return [list $x $y $z] }] return $name } # prng_Triangle -- # Create a PRNG with a triangular distribution of points on an interval. # If the argument min is lower than the argument max, then smaller # values have higher probability and vice versa. # # Arguments: # min Minimum value # max Maximum value # # Result: # Name of a procedure that returns the random point # proc ::simulation::random::prng_Triangle {min max} { variable count incr count set name ::simulation::random::PRNG_$count set diff [expr {$max-$min}] if { $diff > 0.0 } { proc $name {} [string map [list MIN $min DIFF $diff] \ { set r [expr {1.0 - sqrt(1.0 - rand())}] set x [expr {MIN + DIFF*$r}] return $x }] } else { proc $name {} [string map [list MAX $max DIFF $diff] \ { set x [expr {MAX - DIFF*sqrt(rand())}] return $x }] } return $name } # prng_SymmetricTriangle -- # Create a PRNG with a symmetric triangular distribution of points on an interval. # # Arguments: # min Minimum value # max Maximum value # # Result: # Name of a procedure that returns the random point # proc ::simulation::random::prng_SymmetricTriangle {min max} { variable count incr count set name ::simulation::random::PRNG_$count set diff2 [expr {0.5 *($max-$min)}] proc $name {} [string map [list MIN $min DIFF2 $diff2] \ { return [expr {MIN + DIFF2 * (rand() + rand())}] }] return $name } # Announce the package # package provide simulation::random 0.4.0 # main -- # Test code # if { 0 } { set bin [::simulation::random::prng_Bernoulli 0.2] |
︙ | ︙ |
Changes to assets/tcllib1.19/struct/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 | if {![package vsatisfies [package provide Tcl] 8.2]} {return} package ifneeded struct 2.1 [list source [file join $dir struct.tcl]] package ifneeded struct 1.4 [list source [file join $dir struct1.tcl]] package ifneeded struct::queue 1.4.5 [list source [file join $dir queue.tcl]] package ifneeded struct::stack 1.5.3 [list source [file join $dir stack.tcl]] package ifneeded struct::tree 2.1.2 [list source [file join $dir tree.tcl]] package ifneeded struct::matrix 2.0.3 [list source [file join $dir matrix.tcl]] package ifneeded struct::pool 1.2.3 [list source [file join $dir pool.tcl]] | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | if {![package vsatisfies [package provide Tcl] 8.2]} {return} package ifneeded struct 2.1 [list source [file join $dir struct.tcl]] package ifneeded struct 1.4 [list source [file join $dir struct1.tcl]] package ifneeded struct::queue 1.4.5 [list source [file join $dir queue.tcl]] package ifneeded struct::stack 1.5.3 [list source [file join $dir stack.tcl]] package ifneeded struct::tree 2.1.2 [list source [file join $dir tree.tcl]] package ifneeded struct::matrix 2.0.3 [list source [file join $dir matrix.tcl]] package ifneeded struct::pool 1.2.3 [list source [file join $dir pool.tcl]] package ifneeded struct::record 1.2.2 [list source [file join $dir record.tcl]] package ifneeded struct::set 2.2.3 [list source [file join $dir sets.tcl]] package ifneeded struct::prioqueue 1.4 [list source [file join $dir prioqueue.tcl]] package ifneeded struct::skiplist 1.3 [list source [file join $dir skiplist.tcl]] package ifneeded struct::graph 1.2.1 [list source [file join $dir graph1.tcl]] package ifneeded struct::tree 1.2.2 [list source [file join $dir tree1.tcl]] package ifneeded struct::matrix 1.2.1 [list source [file join $dir matrix1.tcl]] |
︙ | ︙ |
Changes to assets/tcllib1.19/struct/record.tcl.
1 2 3 | #============================================================ # ::struct::record -- # | | | | < < | < | < | < | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | #============================================================ # ::struct::record -- # # Implements a container data structure similar to a 'C' # structure. It hides the ugly details about keeping the # data organized by using a combination of arrays, lists # and namespaces. # # Each record definition is kept in a master array # (_recorddefn) under the ::struct::record namespace. Each # instance of a record is kept within a separate namespace # for each record definition. Hence, instances of # the same record definition are managed under the # same namespace. This avoids possible collisions, and # also limits one big global array mechanism. # # Copyright (c) 2002 by Brett Schwarz # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # This code may be distributed under the same terms as Tcl. # #============================================================ # #### FIX ERROR MESSAGES SO THEY MAKE SENSE (Wrong args) namespace eval ::struct {} namespace eval ::struct::record { ## ## array of lists that holds the definition (variables) for each ## record ## ## _recorddefn(some_record) var1 var2 var3 ... ## variable _recorddefn ## ## holds the count for each record in cases where the instance is ## automatically generated ## ## _count(some_record) 0 ## ## This is not a count, but an id generator. Its value has to ## increase monotonicaly. variable _count ## ## array that holds the defining record's name for each instances ## ## _defn(some_instances) name_of_defining_record ## variable _defn array set _defn {} ## ## This holds the defaults for a record definition. If no ## default is given for a member of a record, then the value is ## assigned to the empty string ## variable _defaults ## ## These are the possible sub commands ## variable commands set commands [list define delete exists show] ## ## This keeps track of the level that we are in when handling ## nested records. This is kind of a hack, and probably can be ## handled better ## set _level 0 namespace export record } #------------------------------------------------------------ |
︙ | ︙ | |||
123 124 125 126 127 128 129 | # # Results: # Returns the name of the definition during successful # creation. #------------------------------------------------------------ # proc ::struct::record::Define {defn_ vars_ args} { | < > > < < < > | | < < < < < > > > < | < < | > > > | | | > > > > > > < > < > > < | 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 | # # Results: # Returns the name of the definition during successful # creation. #------------------------------------------------------------ # proc ::struct::record::Define {defn_ vars_ args} { variable _recorddefn variable _count variable _defaults # puts .([info level 0])... set defn_ [Qualify $defn_] if {[info exists _recorddefn($defn_)]} { error "Record definition $defn_ already exists" } if {[lsearch [info commands] $defn_] >= 0} { error "Structure definition name can not be a Tcl command name" } set _defaults($defn_) [list] set _recorddefn($defn_) [list] ## ## Loop through the members of the record ## definition ## foreach V $vars_ { set len [llength $V] set D "" if {$len == 2} { ## 2 --> there is a default value ## assigned to the member set D [lindex $V 1] set V [lindex $V 0] } elseif {$len == 3} { ## 3 --> there is a nested record ## definition given as a member ## V = ('record' record-name field-name) if {![string match "record" "[lindex $V 0]"]} { Delete record $defn_ error "$V is a Bad member for record definition. Definition creation aborted." } set new [lindex $V 1] set new [Qualify $new] # puts .\tchild=$new ## ## Right now, there can not be circular records ## so, we abort the creation ## if {[string match "$defn_" "$new"]} { # puts .\tabort Delete record $defn_ error "Can not have circular records. Structure was not created." } ## ## Will take care of the nested record later ## We just join by :: because this is how it ## use to be declared, so the parsing code ## is already there. ## set V [join [lrange $V 1 2] "::"] } # puts .\tfield($V)=default($D) lappend _recorddefn($defn_) $V lappend _defaults($defn_) $D } # Create class command as alias to instance creator. uplevel #0 [list interp alias \ {} $defn_ \ {} ::struct::record::Create $defn_] set _count($defn_) 0 # Create class namespace. This will hold all the instance information. namespace eval ::struct::record${defn_} { variable values variable instances variable record set instances [list] } set ::struct::record${defn_}::record $defn_ ## ## If there were args given (instances), then ## create them now ## foreach A $args { uplevel 1 [list ::struct::record::Create $defn_ $A] } # puts .=>${defn_} return $defn_ }; # end proc ::struct::record::Define #------------------------------------------------------------ # ::struct::record::Create -- # # Creates an instance of a record definition # # Arguments: # defn_ the name of the record definition # inst_ the name of the instances to create # args values to set to the record's members # # Results: # Returns the name of the instance for a successful creation #------------------------------------------------------------ # proc ::struct::record::Create {defn_ inst_ args} { variable _recorddefn variable _count variable _defn variable _defaults variable _level # puts .([info level 0])... set inst_ [Qualify "$inst_"] ## ## test to see if the record ## definition has been defined yet ## if {![info exists _recorddefn($defn_)]} { error "Structure $defn_ does not exist" } ## ## if there was no argument given, ## then assume that the record ## variable is automatically ## generated ## |
︙ | ︙ | |||
282 283 284 285 286 287 288 | incr _count($defn_) -1 error "Instances $inst_ already exists" } set _defn($inst_) $defn_ ## | | < > > > > > > > > > > > | | | < | < < | < | | < | | | < | > > > | > | > > < > | > < < > | 280 281 282 283 284 285 286 287 288 289 290 291 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 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 | incr _count($defn_) -1 error "Instances $inst_ already exists" } set _defn($inst_) $defn_ ## ## Initialize record variables to defaults ## # Create instance command as alias of instance dispatcher. uplevel #0 [list interp alias {} ${inst_} {} ::struct::record::Cmd $inst_] # Locate manager namespace, i.e. class namespace for new instance set nsi [Ns $inst_] # puts .\tnsi=$nsi # Import the state of the manager namespace upvar 0 ${nsi}values __values upvar 0 ${nsi}instances __instances set cnt 0 foreach V $_recorddefn($defn_) D $_defaults($defn_) { # puts .\tfield($V)=default($D) set __values($inst_,$V) $D ## ## Test to see if there is a nested record ## if {[regexp -- {([\w]*)::([\w]*)} $V -> def inst]} { if {$_level == 0} { set _level 2 } ## ## This is to guard against if the creation had failed, ## that there isn't any lingering variables/alias around ## set def [Qualify $def $_level] if {![info exists _recorddefn($def)]} { Delete inst "$inst_" return } ## ## evaluate the nested record. If there were values for ## the variables passed in, then we assume that the ## value for this nested record is a list corresponding ## the the nested list's variables, and so we pass that ## to the nested record's instantiation. We then get ## rid of those args for later processing. ## set cnt_plus [expr {$cnt + 1}] set mem [lindex $args $cnt] if {![string match "" "$mem"]} { if {![string match "-$inst" "$mem"]} { Delete inst "$inst_" error "$inst is not a member of $defn_" } } incr _level set narg [lindex $args $cnt_plus] # Create instance of the nested record. eval [linsert $narg 0 Create $def ${inst_}.${inst}] set args [lreplace $args $cnt $cnt_plus] incr _level -1 } else { # Regular field, not a nested record. Create alias for # field access. uplevel #0 [list interp alias \ {} ${inst_}.$V \ {} ::struct::record::Access $defn_ $inst_ $V] incr cnt 2 } }; # end foreach variable # Remember new instance. lappend __instances $inst_ # Apply field values handed to the instance constructor. foreach {k v} $args { Access $defn_ $inst_ [string trimleft "$k" -] $v }; # end foreach arg {} if {$_level == 2} { set _level 0 } # puts .=>${inst_} return $inst_ }; # end proc ::struct::record::Create #------------------------------------------------------------ # ::struct::record::Access -- |
︙ | ︙ | |||
390 391 392 393 394 395 396 | variable _recorddefn variable _defn set i [lsearch $_recorddefn($defn_) $var_] if {$i < 0} { | | | | > > > > > > | | | | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 | variable _recorddefn variable _defn set i [lsearch $_recorddefn($defn_) $var_] if {$i < 0} { error "$var_ does not exist in record $defn_" } if {![info exists _defn($inst_)]} { error "$inst_ does not exist" } if {[set idx [lsearch $args "="]] >= 0} { set args [lreplace $args $idx $idx] } set nsi [Ns $inst_] # puts .\tnsi=$nsi # Import the state of the manager namespace upvar 0 ${nsi}values __values ## ## If a value was given, then set it ## if {[llength $args] != 0} { set val_ [lindex $args 0] set __values($inst_,$var_) $val_ } return $__values($inst_,$var_) }; # end proc ::struct::record::Access #------------------------------------------------------------ # ::struct::record::Cmd -- # # Used to process the set/get requests. |
︙ | ︙ | |||
446 447 448 449 450 451 452 | set len [llength $args] if {$len <= 1} {return [Show values "$inst_"]} set cmd [lindex $args 0] if {[string match "cget" "$cmd"]} { | | | | | | | | | | | | | | | | | 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 489 490 491 492 493 494 | set len [llength $args] if {$len <= 1} {return [Show values "$inst_"]} set cmd [lindex $args 0] if {[string match "cget" "$cmd"]} { set cnt 0 foreach k [lrange $args 1 end] { if {[catch {set r [${inst_}.[string trimleft ${k} -]]} err]} { error "Bad option \"$k\"" } lappend result $r incr cnt } if {$cnt == 1} {set result [lindex $result 0]} return $result } elseif {[string match "config*" "$cmd"]} { set L [lrange $args 1 end] foreach {k v} $L { ${inst_}.[string trimleft ${k} -] $v } } else { error "Wrong argument. must be \"object cget|configure args\"" } return [list] }; # end proc ::struct::record::Cmd |
︙ | ︙ | |||
522 523 524 525 526 527 528 | # if what_ = instance, then return a list of instances # with record definition of record_ # if what_ = values, then it will return the values # for a particular instance #------------------------------------------------------------ # proc ::struct::record::Show {what_ {record_ ""}} { | < > > | > > > > | > | | | | | | | | | | | | | | | | | | > | > | | | > > | > > > > > > > | > | > > > | > | | | | < | | | | | | | > | 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 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 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 | # if what_ = instance, then return a list of instances # with record definition of record_ # if what_ = values, then it will return the values # for a particular instance #------------------------------------------------------------ # proc ::struct::record::Show {what_ {record_ ""}} { variable _recorddefn variable _defn variable _defaults set record_ [Qualify $record_] ## ## We just prepend :: to the record_ argument ## #if {![string match "::*" "$record_"]} {set record_ "::$record_"} if {[string match "record*" "$what_"]} { # Show record return [lsort [array names _recorddefn]] } if {[string match "mem*" "$what_"]} { # Show members if {[string match "" "$record_"] || ![info exists _recorddefn($record_)]} { error "Bad arguments while accessing members. Bad record name" } set res [list] set cnt 0 foreach m $_recorddefn($record_) { set def [lindex $_defaults($record_) $cnt] if {[regexp -- {([\w]+)::([\w]+)} $m m d i]} { lappend res [list record $d $i] } elseif {![string match "" "$def"]} { lappend res [list $m $def] } else { lappend res $m } incr cnt } return $res } if {[string match "inst*" "$what_"]} { # Show instances if {![namespace exists ::struct::record${record_}]} { return [list] } # Import the state of the manager namespace upvar 0 ::struct::record${record_}::instances __instances if {![info exists __instances]} { return [list] } return [lsort $__instances] } if {[string match "val*" "$what_"]} { # Show values set nsi [Ns $record_] upvar 0 ${nsi}::instances __instances upvar 0 ${nsi}::values __values upvar 0 ${nsi}::record __record if {[string match "" "$record_"] || ([lsearch $__instances $record_] < 0)} { error "Wrong arguments to values. Bad instance name" } set ret [list] foreach k $_recorddefn($__record) { set v $__values($record_,$k) if {[regexp -- {([\w]*)::([\w]*)} $k m def inst]} { set v [::struct::record::Show values ${record_}.${inst}] } lappend ret -[namespace tail $k] $v } return $ret } # Bogus submethod return [list] }; # end proc ::struct::record::Show #------------------------------------------------------------ # ::struct::record::Delete -- |
︙ | ︙ | |||
609 610 611 612 613 614 615 | # # Returns: # none # #------------------------------------------------------------ # proc ::struct::record::Delete {sub_ item_} { | < | | < | < | > | > > | > | > > | > > | > > > > | > | | > | > > > > > > | > | | < | | | | < > > > | > < < > > > | > > > | | < | < < | < | | < | < < < < | < | > | > | 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 | # # Returns: # none # #------------------------------------------------------------ # proc ::struct::record::Delete {sub_ item_} { variable _recorddefn variable _defn variable _count variable _defaults # puts .([info level 0])... set item_ [Qualify $item_] switch -- $sub_ { instance - instances - inst { # puts .instance # puts .is-instance=[Exists instance $item_] if {[Exists instance $item_]} { # Locate manager namespace, i.e. class namespace for # instance to remove set nsi [Ns $item_] # puts .\tnsi=$nsi # Import the state of the manager namespace upvar 0 ${nsi}values __values upvar 0 ${nsi}instances __instances upvar 0 ${nsi}record __record # puts .\trecord=$__record # Remove instance from state set i [lsearch $__instances $item_] set __instances [lreplace $__instances $i $i] unset _defn($item_) # Process instance fields. foreach V $_recorddefn($__record) { # puts .\tfield($V)=/clear if {[regexp -- {([\w]*)::([\w]*)} $V m def inst]} { # Nested record detected. # Determine associated instance and delete recursively. Delete inst ${item_}.${inst} } else { # Delete field accessor alias # puts .de-alias\t($item_.$V) uplevel #0 [list interp alias {} ${item_}.$V {}] } unset __values($item_,$V) } # Auto-generated id numbers increase monotonically. # Reverting here causes the next auto to fail, claiming # that the instance exists. # incr _count($ns) -1 } else { #error "$item_ is not a instance" } } record - records { # puts .record ## ## Delete the instances for this ## record ## # puts .get-instances foreach I [Show instance "$item_"] { catch { # puts .di/$I Delete instance "$I" } } catch { unset _recorddefn($item_) unset _defaults($item_) unset _count($item_) namespace delete ::struct::record${item_} } } default { error "Wrong arguments to delete" } }; # end switch # Remove alias associated with instance or record (class) # puts .de-alias\t($item_) catch { uplevel #0 [list interp alias {} $item_ {}]} # puts ./ return }; # end proc ::struct::record::Delete #------------------------------------------------------------ # ::struct::record::Exists -- # # Tests whether a record definition or record # instance exists. # # Arguments: # sub_ what to test. Either 'instance' or 'record' # item_ the specific record instance or definition # that needs to be tested. # # Tests to see if a particular instance exists # #------------------------------------------------------------ # proc ::struct::record::Exists {sub_ item_} { # puts .([info level 0])... set item_ [Qualify $item_] switch -glob -- $sub_ { inst* { variable _defn return [info exists _defn($item_)] } record { variable _recorddefn return [info exists _recorddefn($item_)] } default { error "Wrong arguments. Must be exists record|instance target" } }; # end switch }; # end proc ::struct::record::Exists #------------------------------------------------------------ # ::struct::record::Qualify -- # # Contructs the qualified name of the calling scope. This # defaults to 2 levels since there is an extra proc call in # between. # # Arguments: # item_ the command that needs to be qualified # level_ how many levels to go up (default = 2) # # Results: # the item_ passed in fully qualified # #------------------------------------------------------------ # proc ::struct::record::Qualify {item_ {level_ 2}} { if {![string match "::*" "$item_"]} { set ns [uplevel $level_ [list namespace current]] if {![string match "::" "$ns"]} { append ns "::" } set item_ "$ns${item_}" } return "$item_" }; # end proc ::struct::record::Qualify # ### ### ### ######### ######### ######### ## Ready namespace eval ::struct { # Get 'record::record' into the general structure namespace. namespace import -force record::record namespace export record } package provide struct::record 1.2.2 return |
jni/tcl/library/msgs/ja.msg became executable.
︙ | ︙ |