Check-in [17beea27ed]
Not logged in
Home Downloads Timeline Branches Tags Tickets Wiki Login

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: 17beea27ed24a65114cd3a3e329fbd3eba7f1f31
User & Date: chw 2019-06-26 04:11:15
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
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to assets/tcllib1.19/fileutil/fileutil.tcl. 

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 the
#	directory 'jail'. In this way it preventsuser-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.
#








|
|








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
18
19
20
21
22
23
24
25
...
477
478
479
480
481
482
483


484

485
486
487
488
489



























490
491
492
493
494
495
496
...
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
...
920
921
922
923
924
925
926
927


928
929
930
931
932
933
934


935
936
937
938
939
940
941
....
1009
1010
1011
1012
1013
1014
1015
























1016
1017
1018
1019
1020
1021
1022

# 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.4.5

namespace eval ::html {

    # State about the current page

    variable page

................................................................................
#
# 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
    ::set html ""
    ::foreach {name value} $args {
	append html "<meta name=\"$name\" content=\"[quoteFormValue $value]\">"
    }



























    lappend page(meta) $html
    return ""
}

# ::html::refresh
#
#	Generate a meta refresh tag.  This tag gets bundled into the <head>
................................................................................
    return ""
}

# ::html::tagParam
#
#	Return a name, value string for the tag parameters.
#	The values come from "hard-wired" values in the
#	param agrument, 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:
................................................................................

# ::html::submit --
#
#	Format a submit button.
#
# Arguments:
#	label		The string to appear in the submit button.
#	name		The name for the submit button element


#
# Results:
#	The html fragment


proc ::html::submit {label {name submit}} {
    ::set html "<input type=\"submit\" name=\"$name\" value=\"$label\">\n"


}

# ::html::varEmpty --
#
#	Return true if the variable doesn't exist or is an empty string
#
# Arguments:
................................................................................
}
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








|







 







>
>

>

|



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|







 







|
>
>




<
|
|
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
...
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
...
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
...
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
....
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

# 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

................................................................................
#
# 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>
................................................................................
    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:
................................................................................

# ::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:
................................................................................
}
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
2

if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded html 1.4.5 [list source [file join $dir html.tcl]]


|

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
3
4
5
6
7
8
9
10
..
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
...
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
...
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
...
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405

##Library Header
#
# $Id: loggerAppender.tcl,v 1.4 2007/02/08 22:09:54 mic42 Exp $
# Copyright (c) 2005 Cisco Systems, Inc.
#
# Name:
#	::logger::appender
#
# Purpose:
#	collection of appenders for tcllib logger
................................................................................
	emergency red-bold
    }
}



##Procedure Header
# $Id: loggerAppender.tcl,v 1.4 2007/02/08 22:09:54 mic42 Exp $
# Copyright (c) 2005 Cisco Systems, Inc.
#
# Name:
#	::logger::appender::console
#
# Purpose:
#	 
................................................................................
    set myProcNameVar $procName
    return $procText
}



##Procedure Header
# $Id: loggerAppender.tcl,v 1.4 2007/02/08 22:09:54 mic42 Exp $
# Copyright (c) 2005 Cisco Systems, Inc.
#
# Name:
#	::logger::appender::colorConsole
#
# Purpose:
#	 
................................................................................
	      -category $service \
	      -priority $level ]
    set myProcNameVar $procName
    return $procText
}

##Procedure Header
# $Id: loggerAppender.tcl,v 1.4 2007/02/08 22:09:54 mic42 Exp $
# Copyright (c) 2005 Cisco Systems, Inc.
#
# Name:
#       ::logger::appender::fileAppend
#
# Purpose:
#
................................................................................
    return $procText
}
  	 



##Internal Procedure Header
# $Id: loggerAppender.tcl,v 1.4 2007/02/08 22:09:54 mic42 Exp $
# Copyright (c) 2005 Cisco Systems, Inc.
#
# Name:
#       ::logger::appender::genProcName
#
# Purpose:
#        



<







 







<







 







<







 







<







 







<








1
2

3
4
5
6
7
8
9
..
68
69
70
71
72
73
74

75
76
77
78
79
80
81
...
170
171
172
173
174
175
176

177
178
179
180
181
182
183
...
276
277
278
279
280
281
282

283
284
285
286
287
288
289
...
387
388
389
390
391
392
393

394
395
396
397
398
399
400

##Library Header
#

# Copyright (c) 2005 Cisco Systems, Inc.
#
# Name:
#	::logger::appender
#
# Purpose:
#	collection of appenders for tcllib logger
................................................................................
	emergency red-bold
    }
}



##Procedure Header

# Copyright (c) 2005 Cisco Systems, Inc.
#
# Name:
#	::logger::appender::console
#
# Purpose:
#	 
................................................................................
    set myProcNameVar $procName
    return $procText
}



##Procedure Header

# Copyright (c) 2005 Cisco Systems, Inc.
#
# Name:
#	::logger::appender::colorConsole
#
# Purpose:
#	 
................................................................................
	      -category $service \
	      -priority $level ]
    set myProcNameVar $procName
    return $procText
}

##Procedure Header

# Copyright (c) 2005 Cisco Systems, Inc.
#
# Name:
#       ::logger::appender::fileAppend
#
# Purpose:
#
................................................................................
    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
3
4
5
6
7
8
9
10
..
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
...
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
...
266
267
268
269
270
271
272



273
274
275
276
277
278
279
280
281
282
283
...
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
...
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
...
530
531
532
533
534
535
536
537
538
539
540
541

##Library Header
#
# $Id: loggerUtils.tcl,v 1.6 2007/03/20 16:22:16 andreas_kupries Exp $
# Copyright (c) 2005 Cisco Systems, Inc.
#
# Name:
#	::logger::utils::
#
# Purpose:
#	an extension to the tcllib logger module
................................................................................
    logger::import -force -namespace log logger::utils

    # @mdgen OWNER: msgs/*.msg
    ::msgcat::mcload [file join $packageDir msgs]
}

##Internal Procedure Header
# $Id: loggerUtils.tcl,v 1.6 2007/03/20 16:22:16 andreas_kupries Exp $
# Copyright (c) 2005 Cisco Systems, Inc.
#
# Name:
#	::logger::utils::createFormatCmd
#
# Purpose:
#
................................................................................

    return $text
}



##Procedure Header
# $Id: loggerUtils.tcl,v 1.6 2007/03/20 16:22:16 andreas_kupries Exp $
# Copyright (c) 2005 Cisco Systems, Inc.
#
# Name:
#	::logger::utils::createLogProc
#
# Purpose:
#
................................................................................
	}


	if {[regexp {%M} $text]} {
	    set methodText {
		if {[info level] < 2} {
		    set method "global"



		} else {
		    set method [lindex [info level -1] 0]
		}

	    }

	    regsub -all -- \
		{%M} \
		$text \
		{$method} \
		text
................................................................................

    set procText [subst $procText]
    return $procText
}


##Procedure Header
# $Id: loggerUtils.tcl,v 1.6 2007/03/20 16:22:16 andreas_kupries Exp $
# Copyright (c) 2005 Cisco Systems, Inc.
#
# Name:
#	::logger::utils::applyAppender
#
# Purpose:
#
................................................................................
	    ${srvCmd}::logproc $lvl $procName
	}
    }
}


##Internal Procedure Header
# $Id: loggerUtils.tcl,v 1.6 2007/03/20 16:22:16 andreas_kupries Exp $
# Copyright (c) 2005 Cisco Systems, Inc.
#
# Name:
#	::logger::utils::autoApplyAppender
#
# Purpose:
#
................................................................................
    }
    logger::utils::applyAppender -appender $appender -serviceCmd $log \
	-levels $levels -appenderArgs $appenderArgs
    return $log
}


package provide logger::utils 1.3

# ;;; Local Variables: ***
# ;;; mode: tcl ***
# ;;; End: ***



<







 







<







 







<







 







>
>
>



<







 







<







 







<







 







|





1
2

3
4
5
6
7
8
9
..
54
55
56
57
58
59
60

61
62
63
64
65
66
67
...
158
159
160
161
162
163
164

165
166
167
168
169
170
171
...
263
264
265
266
267
268
269
270
271
272
273
274
275

276
277
278
279
280
281
282
...
314
315
316
317
318
319
320

321
322
323
324
325
326
327
...
448
449
450
451
452
453
454

455
456
457
458
459
460
461
...
527
528
529
530
531
532
533
534
535
536
537
538

##Library Header
#

# Copyright (c) 2005 Cisco Systems, Inc.
#
# Name:
#	::logger::utils::
#
# Purpose:
#	an extension to the tcllib logger module
................................................................................
    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:
#
................................................................................

    return $text
}



##Procedure Header

# Copyright (c) 2005 Cisco Systems, Inc.
#
# Name:
#	::logger::utils::createLogProc
#
# Purpose:
#
................................................................................
	}


	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
................................................................................

    set procText [subst $procText]
    return $procText
}


##Procedure Header

# Copyright (c) 2005 Cisco Systems, Inc.
#
# Name:
#	::logger::utils::applyAppender
#
# Purpose:
#
................................................................................
	    ${srvCmd}::logproc $lvl $procName
	}
    }
}


##Internal Procedure Header

# Copyright (c) 2005 Cisco Systems, Inc.
#
# Name:
#	::logger::utils::autoApplyAppender
#
# Purpose:
#
................................................................................
    }
    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. 

2
3
4
5
6
7
8
9

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   [list source [file join $dir loggerUtils.tcl]]








|

2
3
4
5
6
7
8
9

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
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
...
116
117
118
119
120
121
122








































































123
124
125
126
127
128
129
...
263
264
265
266
267
268
269





















































































270
271
272
273
274
275
276
...
479
480
481
482
483
484
485





































































486
487
488
489
490
491
492
....
1946
1947
1948
1949
1950
1951
1952





























1953
1954
1955
1956
1957
1958
1959


# ::math::statistics --
#   Namespace holding the procedures and variables
#
namespace eval ::math::statistics {

    namespace export pdf-normal pdf-uniform pdf-lognormal \
	    pdf-exponential \
	    cdf-normal cdf-uniform cdf-lognormal \
	    cdf-exponential \
	    cdf-students-t \
	    random-normal random-uniform random-lognormal \
	    random-exponential \
	    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

    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)}]
................................................................................
		"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
................................................................................
		-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
................................................................................
		"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
................................................................................
        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
#








|

|


|








|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>








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
...
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
...
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
...
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
....
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


# ::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)}]
................................................................................
		"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
................................................................................
		-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
................................................................................
		"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
................................................................................
        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
25
26
27
28
29
30
31
32
33
34
35
36
37

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.0 [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]]
package ifneeded math::quasirandom       1.0   [list source [file join $dir quasirandom.tcl]]

if {![package vsatisfies [package require Tcl] 8.6]} {return}
package ifneeded math::exact             1.0.1 [list source [file join $dir exact.tcl]]
package ifneeded math::PCA               1.0   [list source [file join $dir pca.tcl]]








|













18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37

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]]
package ifneeded math::quasirandom       1.0   [list source [file join $dir quasirandom.tcl]]

if {![package vsatisfies [package require Tcl] 8.6]} {return}
package ifneeded math::exact             1.0.1 [list source [file join $dir exact.tcl]]
package ifneeded math::PCA               1.0   [list source [file join $dir pca.tcl]]

Changes to assets/tcllib1.19/math/statistics.tcl. 

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-anovo-F: **-operator
package provide math::statistics 1.3.0
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"








|
|








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
26
27
28
29
30
31
32
33
...
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
....
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
....
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537

# 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.1

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.
................................................................................
        shiftjis MS_Kanji
        utf-8 UTF8
    }

    namespace export initialize finalize getproperty \
                     getheader setheader \
                     getbody \
                     copymessage \
                     mapencoding \
                     reversemapencoding \
                     parseaddress \
                     parsedatetime \
                     uniqueID
}

................................................................................
                    # 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 brnaches 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"
................................................................................
}

# ::mime::qp_decode --
#
#    Tcl version of quote-printable decode
#
# Arguments:
#    string        The quoted-prinatble 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}} {








|







 







|







 







|







 







|








19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
...
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
....
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
....
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537

# 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.
................................................................................
        shiftjis MS_Kanji
        utf-8 UTF8
    }

    namespace export initialize finalize getproperty \
                     getheader setheader \
                     getbody \
                     buildmessage copymessage \
                     mapencoding \
                     reversemapencoding \
                     parseaddress \
                     parsedatetime \
                     uniqueID
}

................................................................................
                    # 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"
................................................................................
}

# ::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
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.1 [list source [file join $dir mime.tcl]]




|

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
33
34
35
36
37
38
39
40
...
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285

# 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.3

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

................................................................................

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 -- {%([Ee][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])} \
	$str {[encoding convertfrom utf-8 [DecodeHex \1\2\3]]} str
    regsub -all -- {%([CDcd][A-Fa-f0-9])%([89ABab][A-Fa-f0-9])}                     \
	$str {[encoding convertfrom utf-8 [DecodeHex \1\2]]} str
    regsub -all -- {%([0-7][A-Fa-f0-9])} $str {\\u00\1} str

    # process \u unicode mapped chars
    return [subst -novar $str]
}

# ::ncgi::encode
#








|







 







|

|

|








26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
...
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285

# 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

................................................................................

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
2

if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded ncgi 1.4.3 [list source [file join $dir ncgi.tcl]]


|

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
2

if {![package vsatisfies [package provide Tcl] 8.3]} {return}
package ifneeded profiler 0.3 [list source [file join $dir profiler.tcl]]


|

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. 

2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
...
226
227
228
229
230
231
232



233
234

235
236
237
238
239
240
241
...
243
244
245
246
247
248
249


250
251
252
253
254
255
256
...
631
632
633
634
635
636
637
638

#
#	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.
# 
# RCS: @(#) $Id: profiler.tcl,v 1.29 2006/09/19 23:36:17 andreas_kupries Exp $

package require Tcl 8.3		;# uses [clock clicks -milliseconds]
package provide profiler 0.3

namespace eval ::profiler {
}

# ::profiler::tZero --
#
#	Start a named timer instance
#
# Arguments:
#	tag	name for the timer instance; if none is given, defaults to ""
................................................................................
#
# Results:
#	None

proc ::profiler::leaveHandler {name caller} {
    variable enabled




    if { !$enabled($name) } {
        return

    }

    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
    }


}

# ::profiler::profProc --
#
#	Replacement for the proc command that adds rudimentary profiling
#	capabilities to Tcl.
#
................................................................................
    set paused 0
    foreach name [array names callCount $pattern] {
        set enabled($name) 1
    }

    return
}









|
<
<

|

|
<







 







>
>
>

<
>







 







>
>







 







<

2
3
4
5
6
7
8
9


10
11
12
13

14
15
16
17
18
19
20
...
223
224
225
226
227
228
229
230
231
232
233

234
235
236
237
238
239
240
241
...
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
...
633
634
635
636
637
638
639


#
#	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 ""
................................................................................
#
# 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.
#
................................................................................
    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.3.1 [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]]

|



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
437
438
439
440
441
442
443
444

         set z [expr {DEPTH*rand()}]
         return [list $x $y $z]
    }]

    return $name
}





































































# Announce the package
#
package provide simulation::random 0.3.1


# main --
#     Test code
#
if { 0 } {
set bin [::simulation::random::prng_Bernoulli 0.2]








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


|








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. 

3
4
5
6
7
8
9
10
11
12
13
14
15
16
17

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.1 [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]]








|








3
4
5
6
7
8
9
10
11
12
13
14
15
16
17

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
4
5
6
7
8
9
10
11
12
13
14
15
16
..
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
...
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
...
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
...
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
...
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
...
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
...
522
523
524
525
526
527
528
529
530
531
532


533
534
535
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
...
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
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
...
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
...
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
...
771
772
773
774
775
776
777

778


#============================================================
# ::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.
#
# $Id: record.tcl,v 1.10 2004/09/29 20:56:18 andreas_kupries Exp $
#
#============================================================
#
####  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
}
 
#------------------------------------------------------------
................................................................................
#
# Results:
#   Returns the name of the definition during successful
#   creation.
#------------------------------------------------------------
#
proc ::struct::record::Define {defn_ vars_ args} {

    variable _recorddefn
    variable _count
    variable _defaults



    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 ""

        ##

        ##  2 --> there is a default value
        ##        assigned to the member
        ##
        ##  3 --> there is a nested record
        ##        definition given as a member
        ##
        if {$len == 2} {

            set D [lindex $V 1]
            set V [lindex $V 0]

        } elseif {$len == 3} {




            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]


            ##
            ##  Right now, there can not be circular records
            ##  so, we abort the creation
            ##
            if {[string match "$defn_" "$new"]} {

                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] "::"]
        }



        lappend _recorddefn($defn_) $V
        lappend _defaults($defn_)   $D
    }
    




    uplevel #0 [list interp alias {} $defn_ {} ::struct::record::Create $defn_]

    set _count($defn_) 0


    namespace eval ::struct::record${defn_} {
        variable values
        variable instances


        set instances [list]
    }



    ##
    ##    If there were args given (instances), then
    ##    create them now
    ##
    foreach A $args {

        uplevel 1 [list ::struct::record::Create $defn_ $A]
    }


    return $defn_

}; # end proc ::struct::record::Define

 
#------------------------------------------------------------
# ::struct::record::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



    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
    ##
................................................................................
        incr _count($defn_) -1
        error "Instances $inst_ already exists"
    }

    set _defn($inst_) $defn_

    ##
    ##    Initialize record variables to
    ##    defaults
    ##


    uplevel #0 [list interp alias {} ${inst_} {} ::struct::record::Cmd $inst_]









    set cnt 0
    foreach V $_recorddefn($defn_) D $_defaults($defn_) {



        set [Ns $inst_]values($inst_,$V) $D

        ##
        ##  Test to see if there is a nested record
        ##
        if {[regexp -- {([\w]*)::([\w]*)} $V m 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]


            eval [linsert $narg 0 Create $def ${inst_}.${inst}]

            set args [lreplace $args $cnt $cnt_plus]

            incr _level -1
        } else {





            uplevel #0 [list interp alias {} ${inst_}.$V {} ::struct::record::Access $defn_ $inst_ $V]
            incr cnt 2
        }

    }; # end foreach variable


    lappend [Ns $inst_]instances $inst_


    foreach {k v} $args {

        Access $defn_ $inst_ [string trimleft "$k" -] $v

    }; # end foreach arg {}

    if {$_level == 2} {
	set _level 0
    }


    return $inst_

}; # end proc ::struct::record::Create

 
#------------------------------------------------------------
# ::struct::record::Access --
................................................................................

    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]
    } 







    ##
    ##    If a value was given, then set it
    ##
    if {[llength $args] != 0} {

        set val_ [lindex $args 0]

        set [Ns $inst_]values($inst_,$var_) $val_
    }

    return [set [Ns $inst_]values($inst_,$var_)]
     
}; # end proc ::struct::record::Access

 
#------------------------------------------------------------
# ::struct::record::Cmd --
#
#    Used to process the set/get requests.
................................................................................
    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

................................................................................
#    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



    ##
    ## We just prepend :: to the record_ argument
    ##
    if {![string match "::*" "$record_"]} {set record_ "::$record_"}

    if {[string match "record*" "$what_"]} {


        return [lsort [array names _recorddefn]]


    } elseif {[string match "mem*" "$what_"]} {


       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


    } elseif {[string match "inst*" "$what_"]} {


        if {![info exists ::struct::record${record_}::instances]} {
            return [list]
        }


        return [lsort [set ::struct::record${record_}::instances]]








    } elseif {[string match "val*" "$what_"]} {


           set ns $_defn($record_)




           if {[string match "" "$record_"] || ([lsearch [set [Ns $record_]instances] $record_] < 0)} {


               error "Wrong arguments to values. Bad instance name"
           }

           set ret [list]
           foreach k $_recorddefn($ns) {

              set v [set [Ns $record_]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

    }


    return [list]

}; # end proc ::struct::record::Show

 
#------------------------------------------------------------
# ::struct::record::Delete --
................................................................................
#
# Returns:
#    none
#
#------------------------------------------------------------
#
proc ::struct::record::Delete {sub_ item_} {

    variable _recorddefn
    variable _defn
    variable _count
    variable _defaults

    ##
    ## We just semi-blindly prepend :: to the record_ argument
    ##
    if {![string match "::*" "$item_"]} {set item_ "::$item_"}

    switch -- $sub_ {



        instance -
        instances -
        inst    {






            if {[Exists instance $item_]} {


        









		set ns $_defn($item_)
                foreach A [info commands ${item_}.*] {
		    Delete inst $A
                }

        
                catch {
                    foreach {k v} [array get [Ns $item_]values $item_,*] {


                        
                        unset [Ns $item_]values($k)








                    }
                    set i [lsearch [set [Ns $item_]instances] $item_]
                    set [Ns $item_]instances [lreplace [set [Ns $item_]instances] $i $i]
                    unset _defn($item_)
                }



		# 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   {


            ##
            ##  Delete the instances for this
            ##  record
            ##

            foreach I [Show instance "$item_"] {


                catch {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



    catch { uplevel #0 [list interp alias {} $item_ {}]}


    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_} {





    switch -glob -- $sub_ {
        inst*    {
    
            if {([lsearch ::[Ns $item_]instances $item_] >=0) || [llength [info commands ::${item_}.*]]} {
                return 1
            } else {
                return 0
            }
        }
        record  {
    
            set item_ "::$item_"

            if {[info exists _recorddefn($item_)] || [llength [info commands ${item_}]]} {
                return 1
            } else {
                return 0
            }
        }
        default  {
            error "Wrong arguments. Must be exists record|instance target"
        }
    }; # end switch

}; # end proc ::struct::record::Exists
................................................................................
#    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.1





|



|
|







 







<
<









|
<







|
<











|
<







|
|
|










|
|
|







 







<



>
>







 







<





<



<
>
|
|
<
<
<
<
<





>
>
>


<

|
<



<

<
>





>












>
>




|
<
>
>
>
|



>



>



>
>






<



>







 







<





>
>










<







 







|
<


>

>
>
>
>
>
>
>
>




>
>
|




|






|
<
|




<

<




|
<
|
|
<
|
|
|
<




|






>
>

>




<
>
>
>
>
|


<


>
|

>

<

<






>







 







|




|




|
>
>
>
>
>
>








|


|
|







 







|
|
|
|
|

|
|
|
|
|



|
|
|
|


|







 







<



>
>




|


>
>

>
>
|
>

|
|
|

|
|
|
|
|
|
|
|
|
|
|

|
|

|
|
>
|
>

|
|
|
>
>
|

>
>
>
>
>
>
>
|
>

|
>
>
>

|
>

|
|

|
|
<
|

|
|
|

|
|
|



>







 







<





|
<
<
<

<
>

>



>
>

>

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




|






|
<




>

>
>
|
>








<
<







>
>


>







 







|






>

>
>

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







 







|






<






|







 







>
|
>

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
...
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
...
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
...
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
...
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
...
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
...
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
...
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
...
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
...
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
...
821
822
823
824
825
826
827
828
829
830

#============================================================
# ::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
}
 
#------------------------------------------------------------
................................................................................
#
# 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 --
................................................................................
#    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
    ##
................................................................................
        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 --
................................................................................

    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.
................................................................................
    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

................................................................................
#    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 --
................................................................................
#
# 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
................................................................................
#    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.

Fossil version [cad57db96e] 2019-12-02 13:45:47