summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2018-09-05 14:54:26 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2018-09-05 14:54:26 (GMT)
commit21113a4394193d8f0da6497e2fc016929551f5cc (patch)
tree64f95fb6a26926f8b326e5b2f348598408223b9f
parentba417d3ce6d273a724c772efed9f3fbca65b94a8 (diff)
parent1f6ac7f87e3a127645d7839916f0bc2a6143b9b9 (diff)
downloadtcl-21113a4394193d8f0da6497e2fc016929551f5cc.zip
tcl-21113a4394193d8f0da6497e2fc016929551f5cc.tar.gz
tcl-21113a4394193d8f0da6497e2fc016929551f5cc.tar.bz2
Merge trunk. Also rename TCL_NO_LENGTH -> TCL_AUTO_LENGTH
-rw-r--r--doc/abstract.n77
-rw-r--r--doc/callback.n88
-rw-r--r--doc/classvariable.n78
-rw-r--r--doc/define.n110
-rw-r--r--doc/link.n124
-rw-r--r--doc/my.n60
-rw-r--r--doc/singleton.n99
-rw-r--r--generic/tcl.h2
-rw-r--r--generic/tclBasic.c59
-rw-r--r--generic/tclBinary.c35
-rw-r--r--generic/tclCmdAH.c8
-rw-r--r--generic/tclInt.decls8
-rw-r--r--generic/tclInt.h2
-rw-r--r--generic/tclIntDecls.h8
-rw-r--r--generic/tclIntPlatDecls.h10
-rw-r--r--generic/tclOO.c148
-rw-r--r--generic/tclOOBasic.c32
-rw-r--r--generic/tclOOInt.h2
-rw-r--r--generic/tclOOScript.h240
-rw-r--r--generic/tclOOScript.tcl422
-rw-r--r--generic/tclObj.c72
-rw-r--r--generic/tclProcess.c6
-rw-r--r--generic/tclStringObj.c26
-rw-r--r--generic/tclStubInit.c6
-rw-r--r--generic/tclTest.c22
-rw-r--r--tests/binary.test41
-rw-r--r--tests/compExpr-old.test4
-rw-r--r--tests/execute.test2
-rw-r--r--tests/expr-old.test3
-rw-r--r--tests/expr.test7
-rw-r--r--tests/format.test12
-rw-r--r--tests/get.test4
-rw-r--r--tests/obj.test14
-rw-r--r--tests/oo.test73
-rw-r--r--tests/ooUtil.test563
-rw-r--r--tests/platform.test14
-rw-r--r--tests/scan.test3
-rw-r--r--tools/makeHeader.tcl182
-rw-r--r--unix/Makefile.in18
-rw-r--r--unix/tclUnixTime.c16
-rw-r--r--win/tclWinNotify.c4
-rw-r--r--win/tclWinPipe.c22
-rw-r--r--win/tclWinTime.c6
43 files changed, 2449 insertions, 283 deletions
diff --git a/doc/abstract.n b/doc/abstract.n
new file mode 100644
index 0000000..022c24b
--- /dev/null
+++ b/doc/abstract.n
@@ -0,0 +1,77 @@
+'\"
+'\" Copyright (c) 2018 Donal K. Fellows
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH abstract n 0.3 TclOO "TclOO Commands"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+oo::abstract \- a class that does not allow direct instances of itself
+.SH SYNOPSIS
+.nf
+package require TclOO
+
+\fBoo::abstract\fI method \fR?\fIarg ...\fR?
+.fi
+.SH "CLASS HIERARCHY"
+.nf
+\fBoo::object\fR
+ \(-> \fBoo::class\fR
+ \(-> \fBoo::abstract\fR
+.fi
+.BE
+.SH DESCRIPTION
+Abstract classes are classes that can contain definitions, but which cannot be
+directly manufactured; they are intended to only ever be inherited from and
+instantiated indirectly. The characteristic methods of \fBoo::class\fR
+(\fBcreate\fR and \fBnew\fR) are not exported by an instance of
+\fBoo::abstract\fR.
+.PP
+Note that \fBoo::abstract\fR is not itself an instance of \fBoo::abstract\fR.
+.SS CONSTRUCTOR
+The \fBoo::abstract\fR class does not define an explicit constructor; this
+means that it is effectively the same as the constructor of the
+\fBoo::class\fR class.
+.SS DESTRUCTOR
+The \fBoo::abstract\fR class does not define an explicit destructor;
+destroying an instance of it is just like destroying an ordinary class (and
+will destroy all its subclasses).
+.SS "EXPORTED METHODS"
+The \fBoo::abstract\fR class defines no new exported methods.
+.SS "NON-EXPORTED METHODS"
+The \fBoo::abstract\fR class explicitly states that \fBcreate\fR,
+\fBcreateWithNamespace\fR, and \fBnew\fR are unexported.
+.SH EXAMPLES
+.PP
+This example defines a simple class hierarchy and creates a new instance of
+it. It then invokes a method of the object before destroying the hierarchy and
+showing that the destruction is transitive.
+.PP
+.CS
+\fBoo::abstract\fR create fruit {
+ method eat {} {
+ puts "yummy!"
+ }
+}
+oo::class create banana {
+ superclass fruit
+ method peel {} {
+ puts "skin now off"
+ }
+}
+set b [banana \fBnew\fR]
+$b peel \fI\(-> prints 'skin now off'\fR
+$b eat \fI\(-> prints 'yummy!'\fR
+set f [fruit new] \fI\(-> error 'unknown method "new"...'\fR
+.CE
+.SH "SEE ALSO"
+oo::define(n), oo::object(n)
+.SH KEYWORDS
+abstract class, class, metaclass, object
+.\" Local variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:
diff --git a/doc/callback.n b/doc/callback.n
new file mode 100644
index 0000000..95838a9
--- /dev/null
+++ b/doc/callback.n
@@ -0,0 +1,88 @@
+'\"
+'\" Copyright (c) 2018 Donal K. Fellows
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH callback n 0.3 TclOO "TclOO Commands"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+callback, mymethod \- generate callbacks to methods
+.SH SYNOPSIS
+.nf
+package require TclOO
+
+\fBcallback\fR \fImethodName\fR ?\fIarg ...\fR?
+\fBmymethod\fR \fImethodName\fR ?\fIarg ...\fR?
+.fi
+.BE
+.SH DESCRIPTION
+The \fBcallback\fR command,
+'\" Based on notes in the tcllib docs, we know the provenance of mymethod
+also called \fBmymethod\fR for compatibility with the ooutil and snit packages
+of Tcllib,
+and which should only be used from within the context of a call to a method
+(i.e. inside a method, constructor or destructor body) is used to generate a
+script fragment that will invoke the method, \fImethodName\fR, on the current
+object (as reported by \fBself\fR) when executed. Any additional arguments
+provided will be provided as leading arguments to the callback. The resulting
+script fragment shall be a proper list.
+.PP
+Note that it is up to the caller to ensure that the current object is able to
+handle the call of \fImethodName\fR; this command does not check that.
+\fImethodName\fR may refer to any exported or unexported method, but may not
+refer to a private method as those can only be invoked directly from within
+methods. If there is no such method present at the point when the callback is
+invoked, the standard \fBunknown\fR method handler will be called.
+.SH EXAMPLE
+This is a simple echo server class. The \fBcallback\fR command is used in two
+places, to arrange for the incoming socket connections to be handled by the
+\fIAccept\fR method, and to arrange for the incoming bytes on those
+connections to be handled by the \fIReceive\fR method.
+.PP
+.CS
+oo::class create EchoServer {
+ variable server clients
+ constructor {port} {
+ set server [socket -server [\fBcallback\fR Accept] $port]
+ set clients {}
+ }
+ destructor {
+ chan close $server
+ foreach client [dict keys $clients] {
+ chan close $client
+ }
+ }
+
+ method Accept {channel clientAddress clientPort} {
+ dict set clients $channel [dict create \e
+ address $clientAddress port $clientPort]
+ chan event $channel readable [\fBcallback\fR Receive $channel]
+ }
+ method Receive {channel} {
+ if {[chan gets $channel line] >= 0} {
+ my echo $channel $line
+ } else {
+ chan close $channel
+ dict unset clients $channel
+ }
+ }
+
+ method echo {channel line} {
+ dict with clients $channel {
+ chan puts $channel \e
+ [format {[%s:%d] %s} $address $port $line]
+ }
+ }
+}
+.CE
+.SH "SEE ALSO"
+chan(n), fileevent(n), my(n), self(n), socket(n), trace(n)
+.SH KEYWORDS
+callback, object
+.\" Local Variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:
diff --git a/doc/classvariable.n b/doc/classvariable.n
new file mode 100644
index 0000000..0798bb2
--- /dev/null
+++ b/doc/classvariable.n
@@ -0,0 +1,78 @@
+'\"
+'\" Copyright (c) 2011-2015 Andreas Kupries
+'\" Copyright (c) 2018 Donal K. Fellows
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH classvariable n 0.3 TclOO "TclOO Commands"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+classvariable \- create link from local variable to variable in class
+.SH SYNOPSIS
+.nf
+package require TclOO
+
+\fBclassvariable\fR \fIvariableName\fR ?\fI...\fR?
+.fi
+.BE
+.SH DESCRIPTION
+The \fBclassvariable\fR command is available within methods. It takes a series
+of one or more variable names and makes them available in the method's scope;
+those variable names must not be qualified and must not refer to array
+elements. The originating scope for the variables is the namespace of the
+class that the method was defined by. In other words, the referenced variables
+are shared between all instances of that class.
+.PP
+Note: This command is equivalent to the command \fBtypevariable\fR provided by
+the snit package in tcllib for approximately the same purpose. If used in a
+method defined directly on a class instance (e.g., through the
+\fBoo::objdefine\fR \fBmethod\fR definition) this is very much like just
+using:
+.PP
+.CS
+namespace upvar [namespace current] $var $var
+.CE
+.PP
+for each variable listed to \fBclassvariable\fR.
+.SH EXAMPLE
+This class counts how many instances of it have been made.
+.PP
+.CS
+oo::class create Counted {
+ initialise {
+ variable count 0
+ }
+
+ variable number
+ constructor {} {
+ \fBclassvariable\fR count
+ set number [incr count]
+ }
+
+ method report {} {
+ \fBclassvariable\fR count
+ puts "This is instance $number of $count"
+ }
+}
+
+set a [Counted new]
+set b [Counted new]
+$a report
+ \fI\(-> This is instance 1 of 2\fR
+set c [Counted new]
+$b report
+ \fI\(-> This is instance 2 of 3\fR
+$c report
+ \fI\(-> This is instance 3 of 3\fR
+.CE
+.SH "SEE ALSO"
+global(n), namespace(n), oo::class(n), oo::define(n), upvar(n), variable(n)
+.SH KEYWORDS
+class, class variable, variable
+.\" Local Variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:
diff --git a/doc/define.n b/doc/define.n
index 56d1d7c..f611bcd 100644
--- a/doc/define.n
+++ b/doc/define.n
@@ -1,5 +1,5 @@
'\"
-'\" Copyright (c) 2007 Donal K. Fellows
+'\" Copyright (c) 2007-2018 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -39,6 +39,27 @@ used as the \fIdefScript\fR argument.
The following commands are supported in the \fIdefScript\fR for
\fBoo::define\fR, each of which may also be used in the \fIsubcommand\fR form:
.TP
+\fBclassmethod\fI name\fR ?\fIargList bodyScrip\fR?
+.VS TIP478
+This creates a class method, or (if \fIargList\fR and \fIbodyScript\fR are
+omitted) promotes an existing method on the class object to be a class
+method. The \fIname\fR, \fIargList\fR and \fIbodyScript\fR arguments are as in
+the \fBmethod\fR definition, below.
+.RS
+.PP
+Class methods can be called on either the class itself or on the instances of
+that class. When they are called, the current object (see the \fBself\R and
+\fBmy\fR commands) is the class on which they are called or the class of the
+instance on which they are called, depending on whether they are called on the
+class or an instance of the class, respectively. If called on a subclass or
+instance of the subclass, the current object is the subclass.
+.PP
+In a private definition context, the methods as invoked on classes are
+\fInot\fR private, but the methods as invoked on instances of classes are
+private.
+.RE
+.VE TIP478
+.TP
\fBconstructor\fI argList bodyScript\fR
.
This creates or updates the constructor for a class. The formal arguments to
@@ -110,6 +131,15 @@ below), this command creates private forwarded methods.
.VE TIP500
.RE
.TP
+\fBinitialise\fI script\fR
+.TP
+\fBinitialize\fI script\fR
+.VS TIP478
+This evaluates \fIscript\fR in a context which supports local variables and
+where the current namespace is the instance namespace of the class object
+itself. This is useful for setting up, e.g., class-scoped variables.
+.VE TIP478
+.TP
\fBmethod\fI name argList bodyScript\fR
.
This creates or updates a method that is implemented as a procedure-like
@@ -496,6 +526,84 @@ oo::class create B {
inst m1 \fI\(-> prints "red brick"\fR
inst m2 \fI\(-> prints "blue brick"\fR
.CE
+.PP
+.VS TIP478
+This example shows how to create and use class variables. It is a class that
+counts how many instances of itself have been made.
+.PP
+.CS
+oo::class create Counted
+\fBoo::define\fR Counted {
+ \fBinitialise\fR {
+ variable count 0
+ }
+
+ \fBvariable\fR number
+ \fBconstructor\fR {} {
+ classvariable count
+ set number [incr count]
+ }
+
+ \fBmethod\fR report {} {
+ classvariable count
+ puts "This is instance $number of $count"
+ }
+}
+
+set a [Counted new]
+set b [Counted new]
+$a report
+ \fI\(-> This is instance 1 of 2\fR
+set c [Counted new]
+$b report
+ \fI\(-> This is instance 2 of 3\fR
+$c report
+ \fI\(-> This is instance 3 of 3\fR
+.CE
+.PP
+This example demonstrates how to use class methods. (Note that the constructor
+for \fBoo::class\fR calls \fBoo::define\fR on the class.)
+.PP
+.CS
+oo::class create DBTable {
+ \fBclassmethod\fR find {description} {
+ puts "DB: locate row from [self] matching $description"
+ return [my new]
+ }
+ \fBclassmethod\fR insert {description} {
+ puts "DB: create row in [self] matching $description"
+ return [my new]
+ }
+ \fBmethod\fR update {description} {
+ puts "DB: update row [self] with $description"
+ }
+ \fBmethod\fR delete {} {
+ puts "DB: delete row [self]"
+ my destroy; # Just delete the object, not the DB row
+ }
+}
+
+oo::class create Users {
+ \fBsuperclass\fR DBTable
+}
+oo::class create Groups {
+ \fBsuperclass\fR DBTable
+}
+
+set u1 [Users insert "username=abc"]
+ \fI\(-> DB: create row from ::Users matching username=abc\fR
+set u2 [Users insert "username=def"]
+ \fI\(-> DB: create row from ::Users matching username=def\fR
+$u2 update "group=NULL"
+ \fI\(-> DB: update row ::oo::Obj124 with group=NULL\fR
+$u1 delete
+ \fI\(-> DB: delete row ::oo::Obj123\fR
+set g [Group find "groupname=webadmins"]
+ \fI\(-> DB: locate row ::Group with groupname=webadmins\fR
+$g update "emailaddress=admins"
+ \fI\(-> DB: update row ::oo::Obj125 with emailaddress=admins\fR
+.CE
+.VE TIP478
.SH "SEE ALSO"
next(n), oo::class(n), oo::object(n)
.SH KEYWORDS
diff --git a/doc/link.n b/doc/link.n
new file mode 100644
index 0000000..7219342
--- /dev/null
+++ b/doc/link.n
@@ -0,0 +1,124 @@
+'\"
+'\" Copyright (c) 2011-2015 Andreas Kupries
+'\" Copyright (c) 2018 Donal K. Fellows
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH link n 0.3 TclOO "TclOO Commands"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+link \- create link from command to method of object
+.SH SYNOPSIS
+.nf
+package require TclOO
+
+\fBlink\fR \fImethodName\fR ?\fI...\fR?
+\fBlink\fR \fB{\fIcommandName methodName\fB}\fR ?\fI...\fR?
+.fi
+.BE
+.SH DESCRIPTION
+The \fBlink\fR command is available within methods. It takes a series of one
+or more method names (\fImethodName ...\fR) and/or pairs of command- and
+method-name (\fB{\fIcommandName methodName\fB}\fR) and makes the named methods
+available as commands without requiring the explicit use of the name of the
+object or the \fBmy\fR command. The method does not need to exist at the time
+that the link is made; if the link command is invoked when the method does not
+exist, the standard \fBunknown\fR method handling system is used.
+.PP
+The command name under which the method becomes available defaults to the
+method name, except where explicitly specified through an alias/method pair.
+Formally, every argument must be a list; if the list has two elements, the
+first element is the name of the command to create and the second element is
+the name of the method of the current object to which the command links;
+otherwise, the name of the command and the name of the method are the same
+string (the first element of the list).
+.PP
+If the name of the command is not a fully-qualified command name, it will be
+resolved with respect to the current namespace (i.e., the object namespace).
+.SH EXAMPLES
+This demonstrates linking a single method in various ways. First it makes a
+simple link, then a renamed link, then an external link. Note that the method
+itself is unexported, but that it can still be called directly from outside
+the class.
+.PP
+.CS
+oo::class create ABC {
+ method Foo {} {
+ puts "This is Foo in [self]"
+ }
+
+ constructor {} {
+ \fBlink\fR Foo
+ # The method foo is now directly accessible as foo here
+ \fBlink\fR {bar Foo}
+ # The method foo is now directly accessible as bar
+ \fBlink\fR {::ExternalCall Foo}
+ # The method foo is now directly accessible in the global
+ # namespace as ExternalCall
+ }
+
+ method grill {} {
+ puts "Step 1:"
+ Foo
+ puts "Step 2:"
+ bar
+ }
+}
+
+ABC create abc
+abc grill
+ \fI\(-> Step 1:\fR
+ \fI\(-> This is foo in ::abc\fR
+ \fI\(-> Step 2:\fR
+ \fI\(-> This is foo in ::abc\fR
+# Direct access via the linked command
+puts "Step 3:"; ExternalCall
+ \fI\(-> Step 3:\fR
+ \fI\(-> This is foo in ::abc\fR
+.CE
+.PP
+This example shows that multiple linked commands can be made in a call to
+\fBlink\fR, and that they can handle arguments.
+.PP
+.CS
+oo::class create Ex {
+ constructor {} {
+ \fBlink\fR a b c
+ # The methods a, b, and c (defined below) are all now
+ # directly acessible within methods under their own names.
+ }
+
+ method a {} {
+ puts "This is a"
+ }
+ method b {x} {
+ puts "This is b($x)"
+ }
+ method c {y z} {
+ puts "This is c($y,$z)"
+ }
+
+ method call {p q r} {
+ a
+ b $p
+ c $q $r
+ }
+}
+
+set o [Ex new]
+$o 3 5 7
+ \fI\(-> This is a\fR
+ \fI\(-> This is b(3)\fR
+ \fI\(-> This is c(5,7)\fR
+.CE
+.SH "SEE ALSO"
+interp(n), my(n), oo::class(n), oo::define(n)
+.SH KEYWORDS
+command, method, object
+.\" Local Variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:
diff --git a/doc/my.n b/doc/my.n
index 26d861a..262186f 100644
--- a/doc/my.n
+++ b/doc/my.n
@@ -9,30 +9,45 @@
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
-my \- invoke any method of current object
+my, myclass \- invoke any method of current object or its class
.SH SYNOPSIS
.nf
package require TclOO
\fBmy\fI methodName\fR ?\fIarg ...\fR?
+\fBmyclass\fI methodName\fR ?\fIarg ...\fR?
.fi
.BE
.SH DESCRIPTION
.PP
The \fBmy\fR command is used to allow methods of objects to invoke methods
-of the object (or its class). In particular, the set of valid values for
+of the object (or its class),
+.VS TIP478
+and he \fBmyclass\fR command is used to allow methods of objects to invoke
+methods of the current class of the object \fIas an object\fR.
+.VE TIP478
+In particular, the set of valid values for
\fImethodName\fR is the set of all methods supported by an object and its
superclasses, including those that are not exported
.VS TIP500
and private methods of the object or class when used within another method
defined by that object or class.
.VE TIP500
-The object upon which the method is invoked is the one that owns the namespace
-that the \fBmy\fR command is contained in initially (\fBNB:\fR the link
+.PP
+The object upon which the method is invoked via \fBmy\fR is the one that owns
+the namespace that the \fBmy\fR command is contained in initially (\fBNB:\fR the link
remains if the command is renamed), which is the currently invoked object by
default.
+.VS TIP478
+Similarly, the object on which the method is invoked via \fBmyclass\fR is the
+object that is the current class of the object that owns the namespace that
+the \fBmyclass\fR command is contained in initially. As with \fBmy\fR, the
+link remains even if the command is renamed into another namespace, and
+defaults to being the manufacturing class of the current object.
+.VE TIP478
.PP
-Each object has its own \fBmy\fR command, contained in its instance namespace.
+Each object has its own \fBmy\fR and \fBmyclass\fR commands, contained in its
+instance namespace.
.SH EXAMPLES
.PP
This example shows basic use of \fBmy\fR to use the \fBvariables\fR method of
@@ -54,7 +69,8 @@ o count \fI\(-> prints "3"\fR
.PP
This example shows how you can use \fBmy\fR to make callbacks to private
methods from outside the object (from a \fBtrace\fR), using
-\fBnamespace code\fR to enter the correct context:
+\fBnamespace code\fR to enter the correct context. (See the \fBcallback\fR
+command for the recommended way of doing this.)
.PP
.CS
oo::class create HasCallback {
@@ -73,6 +89,38 @@ set o [HasCallback new]
trace add variable xyz write [$o makeCallback]
set xyz "called" \fI\(-> prints "callback: xyz {} write"\fR
.CE
+.PP
+.VS TIP478
+This example shows how to access a private method of a class from an instance
+of that class. (See the \fBclassmethod\fR declaration in \fBoo::define\fR for
+a higher level interface for doing this.)
+.PP
+.CS
+oo::class create CountedSteps {
+ self {
+ variable count
+ method Count {} {
+ return [incr count]
+ }
+ }
+ method advanceTwice {} {
+ puts "in [self] step A: [\fBmyclass\fR Count]"
+ puts "in [self] step B: [\fBmyclass\fR Count]"
+ }
+}
+
+CountedSteps create x
+CountedSteps create y
+x advanceTwice \fI\(-> prints "in ::x step A: 1"\fR
+ \fI\(-> prints "in ::x step B: 2"\fR
+y advanceTwice \fI\(-> prints "in ::y step A: 3"\fR
+ \fI\(-> prints "in ::y step B: 4"\fR
+x advanceTwice \fI\(-> prints "in ::x step A: 5"\fR
+ \fI\(-> prints "in ::x step B: 6"\fR
+y advanceTwice \fI\(-> prints "in ::y step A: 7"\fR
+ \fI\(-> prints "in ::y step B: 8"\fR
+.CE
+.VE TIP478
.SH "SEE ALSO"
next(n), oo::object(n), self(n)
.SH KEYWORDS
diff --git a/doc/singleton.n b/doc/singleton.n
new file mode 100644
index 0000000..568a8bd
--- /dev/null
+++ b/doc/singleton.n
@@ -0,0 +1,99 @@
+'\"
+'\" Copyright (c) 2018 Donal K. Fellows
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+.TH singleton n 0.3 TclOO "TclOO Commands"
+.so man.macros
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+oo::singleton \- a class that does only allows one instance of itself
+.SH SYNOPSIS
+.nf
+package require TclOO
+
+\fBoo::singleton\fI method \fR?\fIarg ...\fR?
+.fi
+.SH "CLASS HIERARCHY"
+.nf
+\fBoo::object\fR
+ \(-> \fBoo::class\fR
+ \(-> \fBoo::singleton\fR
+.fi
+.BE
+.SH DESCRIPTION
+Singleton classes are classes that only permit at most one instance of
+themselves to exist. They unexport the \fBcreate\fR and
+\fBcreateWithNamespace\fR methods entirely, and override the \fBnew\fR method
+so that it only makes a new instance if there is no existing instance. It is
+not recommended to inherit from a singleton class; singleton-ness is \fInot\fR
+inherited. It is not recommended that a singleton class's constructor take any
+arguments.
+.PP
+Instances have their\fB destroy\fR method overridden with a method that always
+returns an error in order to discourage destruction of the object, but
+destruction remains possible if strictly necessary (e.g., by destroying the
+class or using \fBrename\fR to delete it). They also have a (non-exported)
+\fB<cloned>\fR method defined on them that similarly always returns errors to
+make attempts to use the singleton instance with \fBoo::copy\fR fail.
+.SS CONSTRUCTOR
+The \fBoo::singleton\fR class does not define an explicit constructor; this
+means that it is effectively the same as the constructor of the
+\fBoo::class\fR class.
+.SS DESTRUCTOR
+The \fBoo::singleton\fR class does not define an explicit destructor;
+destroying an instance of it is just like destroying an ordinary class (and
+will destroy the singleton object).
+.SS "EXPORTED METHODS"
+.TP
+\fIcls \fBnew \fR?\fIarg ...\fR?
+.
+This returns the current instance of the singleton class, if one exists, and
+creates a new instance only if there is no existing instance. The additional
+arguments, \fIarg ...\fR, are only used if a new instance is actually
+manufactured; that construction is via the \fBoo::class\fR class's \fBnew\fR
+method.
+.RS
+.PP
+This is an override of the behaviour of a superclass's method with an
+identical call signature to the superclass's implementation.
+.RE
+.SS "NON-EXPORTED METHODS"
+The \fBoo::singleton\fR class explicitly states that \fBcreate\fR and
+\fBcreateWithNamespace\fR are unexported; callers should not assume that they
+have control over either the name or the namespace name of the singleton instance.
+.SH EXAMPLE
+.PP
+This example demonstrates that there is only one instance even though the
+\fBnew\fR method is called three times.
+.PP
+.CS
+\fBoo::singleton\fR create Highlander {
+ method say {} {
+ puts "there can be only one"
+ }
+}
+
+set h1 [Highlander new]
+set h2 [Highlander new]
+if {$h1 eq $h2} {
+ puts "equal objects" \fI\(-> prints "equal objects"\fR
+}
+set h3 [Highlander new]
+if {$h1 eq $h3} {
+ puts "equal objects" \fI\(-> prints "equal objects"\fR
+}
+.CE
+.PP
+Note that the name of the instance of the singleton is not guaranteed to be
+anything in particular.
+.SH "SEE ALSO"
+oo::class(n)
+.SH KEYWORDS
+class, metaclass, object, single instance
+.\" Local variables:
+.\" mode: nroff
+.\" fill-column: 78
+.\" End:
diff --git a/generic/tcl.h b/generic/tcl.h
index d8b1d58..cf27ada 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -2180,7 +2180,7 @@ typedef int (Tcl_ArgvGenFuncProc)(void *clientData, Tcl_Interp *interp,
*/
#define TCL_IO_FAILURE ((size_t)-1)
-#define TCL_NO_LENGTH ((size_t)-1)
+#define TCL_AUTO_LENGTH ((size_t)-1)
/*
*----------------------------------------------------------------------------
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 32cc4e9..63cb3b9 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -6954,27 +6954,14 @@ ExprIntFunc(
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
- long iResult;
+ Tcl_WideInt wResult;
Tcl_Obj *objPtr;
if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
return TCL_ERROR;
}
objPtr = Tcl_GetObjResult(interp);
- if (TclGetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) {
- /*
- * Truncate the bignum; keep only bits in long range.
- */
-
- mp_int big;
-
- Tcl_GetBignumFromObj(NULL, objPtr, &big);
- mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- TclGetLongFromObj(NULL, objPtr, &iResult);
- Tcl_DecrRefCount(objPtr);
- }
- Tcl_SetObjResult(interp, Tcl_NewLongObj(iResult));
+ TclGetWideBitsFromObj(NULL, objPtr, &wResult);
+ Tcl_SetObjResult(interp, Tcl_NewLongObj((long)wResult));
return TCL_OK;
}
@@ -6987,26 +6974,11 @@ ExprWideFunc(
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
Tcl_WideInt wResult;
- Tcl_Obj *objPtr;
if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) {
return TCL_ERROR;
}
- objPtr = Tcl_GetObjResult(interp);
- if (TclGetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) {
- /*
- * Truncate the bignum; keep only bits in wide int range.
- */
-
- mp_int big;
-
- Tcl_GetBignumFromObj(NULL, objPtr, &big);
- mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- TclGetWideIntFromObj(NULL, objPtr, &wResult);
- Tcl_DecrRefCount(objPtr);
- }
+ TclGetWideBitsFromObj(NULL, Tcl_GetObjResult(interp), &wResult);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult));
return TCL_OK;
}
@@ -7109,7 +7081,7 @@ ExprRandFunc(
* Make sure 1 <= randSeed <= (2^31) - 2. See below.
*/
- iPtr->randSeed &= (unsigned long) 0x7fffffff;
+ iPtr->randSeed &= 0x7fffffff;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
iPtr->randSeed ^= 123459876;
}
@@ -7253,7 +7225,7 @@ ExprSrandFunc(
Tcl_Obj *const *objv) /* Parameter vector. */
{
Interp *iPtr = (Interp *) interp;
- long i = 0; /* Initialized to avoid compiler warning. */
+ Tcl_WideInt w = 0; /* Initialized to avoid compiler warning. */
/*
* Convert argument and use it to reset the seed.
@@ -7264,20 +7236,8 @@ ExprSrandFunc(
return TCL_ERROR;
}
- if (TclGetLongFromObj(NULL, objv[1], &i) != TCL_OK) {
- Tcl_Obj *objPtr;
- mp_int big;
-
- if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) {
- /* TODO: more ::errorInfo here? or in caller? */
- return TCL_ERROR;
- }
-
- mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- TclGetLongFromObj(NULL, objPtr, &i);
- Tcl_DecrRefCount(objPtr);
+ if (TclGetWideBitsFromObj(NULL, objv[1], &w) != TCL_OK) {
+ return TCL_ERROR;
}
/*
@@ -7286,8 +7246,7 @@ ExprSrandFunc(
*/
iPtr->flags |= RAND_SEED_INITIALIZED;
- iPtr->randSeed = i;
- iPtr->randSeed &= (unsigned long) 0x7fffffff;
+ iPtr->randSeed = (long) w & 0x7fffffff;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
iPtr->randSeed ^= 123459876;
}
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 13f1c55..0cc35b9 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -1958,7 +1958,6 @@ FormatNumber(
Tcl_Obj *src, /* Number to format. */
unsigned char **cursorPtr) /* Pointer to index into destination buffer. */
{
- long value;
double dvalue;
Tcl_WideInt wvalue;
float fvalue;
@@ -2020,7 +2019,7 @@ FormatNumber(
case 'w':
case 'W':
case 'm':
- if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) {
+ if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
return TCL_ERROR;
}
if (NeedReversing(type)) {
@@ -2050,19 +2049,19 @@ FormatNumber(
case 'i':
case 'I':
case 'n':
- if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
+ if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
return TCL_ERROR;
}
if (NeedReversing(type)) {
- *(*cursorPtr)++ = UCHAR(value);
- *(*cursorPtr)++ = UCHAR(value >> 8);
- *(*cursorPtr)++ = UCHAR(value >> 16);
- *(*cursorPtr)++ = UCHAR(value >> 24);
+ *(*cursorPtr)++ = UCHAR(wvalue);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 8);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 16);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 24);
} else {
- *(*cursorPtr)++ = UCHAR(value >> 24);
- *(*cursorPtr)++ = UCHAR(value >> 16);
- *(*cursorPtr)++ = UCHAR(value >> 8);
- *(*cursorPtr)++ = UCHAR(value);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 24);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 16);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 8);
+ *(*cursorPtr)++ = UCHAR(wvalue);
}
return TCL_OK;
@@ -2072,15 +2071,15 @@ FormatNumber(
case 's':
case 'S':
case 't':
- if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
+ if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
return TCL_ERROR;
}
if (NeedReversing(type)) {
- *(*cursorPtr)++ = UCHAR(value);
- *(*cursorPtr)++ = UCHAR(value >> 8);
+ *(*cursorPtr)++ = UCHAR(wvalue);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 8);
} else {
- *(*cursorPtr)++ = UCHAR(value >> 8);
- *(*cursorPtr)++ = UCHAR(value);
+ *(*cursorPtr)++ = UCHAR(wvalue >> 8);
+ *(*cursorPtr)++ = UCHAR(wvalue);
}
return TCL_OK;
@@ -2088,10 +2087,10 @@ FormatNumber(
* 8-bit integer values.
*/
case 'c':
- if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
+ if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) {
return TCL_ERROR;
}
- *(*cursorPtr)++ = UCHAR(value);
+ *(*cursorPtr)++ = UCHAR(wvalue);
return TCL_OK;
default:
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 3ffea38..e8e4425 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -1261,9 +1261,9 @@ FileAttrAccessTimeCmd(
* platforms. [Bug 698146]
*/
- long newTime;
+ Tcl_WideInt newTime;
- if (TclGetLongFromObj(interp, objv[2], &newTime) != TCL_OK) {
+ if (TclGetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) {
return TCL_ERROR;
}
@@ -1342,9 +1342,9 @@ FileAttrModifyTimeCmd(
* platforms. [Bug 698146]
*/
- long newTime;
+ Tcl_WideInt newTime;
- if (TclGetLongFromObj(interp, objv[2], &newTime) != TCL_OK) {
+ if (TclGetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) {
return TCL_ERROR;
}
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 47e11b8..367c492 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -309,10 +309,10 @@ declare 74 {
void TclpFree(void *ptr)
}
declare 75 {
- unsigned long TclpGetClicks(void)
+ Tcl_WideUInt TclpGetClicks(void)
}
declare 76 {
- unsigned long TclpGetSeconds(void)
+ Tcl_WideUInt TclpGetSeconds(void)
}
# Removed in 9.0:
@@ -1102,7 +1102,7 @@ declare 5 win {
# const char *optval, int optlen)
#}
declare 8 win {
- int TclpGetPid(Tcl_Pid pid)
+ size_t TclpGetPid(Tcl_Pid pid)
}
# Removed in 9.0:
#declare 9 win {
@@ -1160,7 +1160,7 @@ declare 19 win {
TclFile TclpOpenFile(const char *fname, int mode)
}
declare 20 win {
- void TclWinAddProcess(HANDLE hProcess, DWORD id)
+ void TclWinAddProcess(HANDLE hProcess, size_t id)
}
# Removed in 9.0:
#declare 21 win {
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 4af01d2..e191fa2 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2974,6 +2974,8 @@ MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr,
MODULE_SCOPE int TclGetLoadedPackagesEx(Tcl_Interp *interp,
const char *targetName,
const char *packageName);
+MODULE_SCOPE int TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *,
+ Tcl_WideInt *);
MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern,
Tcl_Obj *unquotedPrefix, int globFlags,
Tcl_GlobTypeData *types);
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 51408a5..cc58220 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -195,9 +195,9 @@ EXTERN void * TclpAlloc(size_t size);
/* 74 */
EXTERN void TclpFree(void *ptr);
/* 75 */
-EXTERN unsigned long TclpGetClicks(void);
+EXTERN Tcl_WideUInt TclpGetClicks(void);
/* 76 */
-EXTERN unsigned long TclpGetSeconds(void);
+EXTERN Tcl_WideUInt TclpGetSeconds(void);
/* Slot 77 is reserved */
/* Slot 78 is reserved */
/* Slot 79 is reserved */
@@ -658,8 +658,8 @@ typedef struct TclIntStubs {
void (*reserved72)(void);
void (*reserved73)(void);
void (*tclpFree) (void *ptr); /* 74 */
- unsigned long (*tclpGetClicks) (void); /* 75 */
- unsigned long (*tclpGetSeconds) (void); /* 76 */
+ Tcl_WideUInt (*tclpGetClicks) (void); /* 75 */
+ Tcl_WideUInt (*tclpGetSeconds) (void); /* 76 */
void (*reserved77)(void);
void (*reserved78)(void);
void (*reserved79)(void);
diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h
index 5ec0544..37a9176 100644
--- a/generic/tclIntPlatDecls.h
+++ b/generic/tclIntPlatDecls.h
@@ -108,7 +108,7 @@ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout);
/* Slot 6 is reserved */
/* Slot 7 is reserved */
/* 8 */
-EXTERN int TclpGetPid(Tcl_Pid pid);
+EXTERN size_t TclpGetPid(Tcl_Pid pid);
/* Slot 9 is reserved */
/* Slot 10 is reserved */
/* 11 */
@@ -138,7 +138,7 @@ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction);
/* 19 */
EXTERN TclFile TclpOpenFile(const char *fname, int mode);
/* 20 */
-EXTERN void TclWinAddProcess(HANDLE hProcess, DWORD id);
+EXTERN void TclWinAddProcess(HANDLE hProcess, size_t id);
/* Slot 21 is reserved */
/* 22 */
EXTERN TclFile TclpCreateTempFile(const char *contents);
@@ -274,7 +274,7 @@ typedef struct TclIntPlatStubs {
int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */
void (*reserved6)(void);
void (*reserved7)(void);
- int (*tclpGetPid) (Tcl_Pid pid); /* 8 */
+ size_t (*tclpGetPid) (Tcl_Pid pid); /* 8 */
void (*reserved9)(void);
void (*reserved10)(void);
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */
@@ -286,7 +286,7 @@ typedef struct TclIntPlatStubs {
int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */
TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */
TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */
- void (*tclWinAddProcess) (HANDLE hProcess, DWORD id); /* 20 */
+ void (*tclWinAddProcess) (HANDLE hProcess, size_t id); /* 20 */
void (*reserved21)(void);
TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */
void (*reserved23)(void);
@@ -503,7 +503,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
#if !defined(_WIN32)
# undef TclpGetPid
-# define TclpGetPid(pid) ((unsigned long) (pid))
+# define TclpGetPid(pid) ((size_t) (pid))
#endif
#endif /* _TCLINTPLATDECLS */
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 96cb039..97782f0 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -102,6 +102,13 @@ static int PrivateObjectCmd(ClientData clientData,
static int PrivateNRObjectCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const *objv);
+static int MyClassObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+static int MyClassNRObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const *objv);
+static void MyClassDeleted(ClientData clientData);
/*
* Methods in the oo::object and oo::class classes. First, we define a helper
@@ -152,65 +159,10 @@ static const char *initScript =
/* " tcloo.tcl OO_LIBRARY oo::library;"; */
/*
- * The scripted part of the definitions of slots.
- */
-
-static const char *slotScript =
-"::oo::define ::oo::Slot {\n"
-" method Get {} {error unimplemented}\n"
-" method Set list {error unimplemented}\n"
-" method -set args {\n"
-" uplevel 1 [list [namespace which my] Set $args]\n"
-" }\n"
-" method -append args {\n"
-" uplevel 1 [list [namespace which my] Set [list"
-" {*}[uplevel 1 [list [namespace which my] Get]] {*}$args]]\n"
-" }\n"
-" method -clear {} {uplevel 1 [list [namespace which my] Set {}]}\n"
-" forward --default-operation my -append\n"
-" method unknown {args} {\n"
-" set def --default-operation\n"
-" if {[llength $args] == 0} {\n"
-" return [uplevel 1 [list [namespace which my] $def]]\n"
-" } elseif {![string match -* [lindex $args 0]]} {\n"
-" return [uplevel 1 [list [namespace which my] $def {*}$args]]\n"
-" }\n"
-" next {*}$args\n"
-" }\n"
-" export -set -append -clear\n"
-" unexport unknown destroy\n"
-"}\n"
-"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n"
-"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n"
-"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n";
-
-/*
- * The body of the <cloned> method of oo::object.
+ * The scripted part of the definitions of TclOO.
*/
-static const char *clonedBody =
-"foreach p [info procs [info object namespace $originObject]::*] {"
-" set args [info args $p];"
-" set idx -1;"
-" foreach a $args {"
-" lset args [incr idx] "
-" [if {[info default $p $a d]} {list $a $d} {list $a}]"
-" };"
-" set b [info body $p];"
-" set p [namespace tail $p];"
-" proc $p $args $b;"
-"};"
-"foreach v [info vars [info object namespace $originObject]::*] {"
-" upvar 0 $v vOrigin;"
-" namespace upvar [namespace current] [namespace tail $v] vNew;"
-" if {[info exists vOrigin]} {"
-" if {[array exists vOrigin]} {"
-" array set vNew [array get vOrigin];"
-" } else {"
-" set vNew $vOrigin;"
-" }"
-" }"
-"}";
+#include "tclOOScript.h"
/*
* The actual definition of the variable holding the TclOO stub table.
@@ -360,7 +312,7 @@ InitFoundation(
ThreadLocalData *tsdPtr =
Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
Foundation *fPtr = Tcl_Alloc(sizeof(Foundation));
- Tcl_Obj *namePtr, *argsPtr, *bodyPtr;
+ Tcl_Obj *namePtr;
Tcl_DString buffer;
Command *cmdPtr;
int i;
@@ -440,18 +392,6 @@ InitFoundation(
}
/*
- * Create the default <cloned> method implementation, used when 'oo::copy'
- * is called to finish the copying of one object to another.
- */
-
- TclNewLiteralStringObj(argsPtr, "originObject");
- Tcl_IncrRefCount(argsPtr);
- bodyPtr = Tcl_NewStringObj(clonedBody, -1);
- TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr,
- bodyPtr, NULL);
- TclDecrRefCount(argsPtr);
-
- /*
* Finish setting up the class of classes by marking the 'new' method as
* private; classes, unlike general objects, must have explicit names. We
* also need to create the constructor for classes.
@@ -491,7 +431,12 @@ InitFoundation(
if (TclOODefineSlots(fPtr) != TCL_OK) {
return TCL_ERROR;
}
- return Tcl_EvalEx(interp, slotScript, -1, 0);
+
+ /*
+ * Evaluate the remaining definitions, which are a compiled-in Tcl script.
+ */
+
+ return Tcl_EvalEx(interp, tclOOSetupScript, -1, 0);
}
/*
@@ -797,6 +742,9 @@ AllocObject(
oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr,
PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted);
+ oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass",
+ oPtr->namespacePtr, MyClassObjCmd, MyClassNRObjCmd, oPtr,
+ MyClassDeleted);
return oPtr;
}
@@ -824,12 +772,12 @@ SquelchCachedName(
/*
* ----------------------------------------------------------------------
*
- * MyDeleted --
+ * MyDeleted, MyClassDeleted --
*
- * This callback is triggered when the object's [my] command is deleted
- * by any mechanism. It just marks the object as not having a [my]
- * command, and so prevents cleanup of that when the object itself is
- * deleted.
+ * These callbacks are triggered when the object's [my] or [myclass]
+ * commands are deleted by any mechanism. They just mark the object as
+ * not having a [my] command or [myclass] command, and so prevent cleanup
+ * of those commands when the object itself is deleted.
*
* ----------------------------------------------------------------------
*/
@@ -843,6 +791,14 @@ MyDeleted(
oPtr->myCommand = NULL;
}
+
+static void
+MyClassDeleted(
+ ClientData clientData)
+{
+ Object *oPtr = clientData;
+ oPtr->myclassCommand = NULL;
+}
/*
* ----------------------------------------------------------------------
@@ -1215,6 +1171,9 @@ ObjectNamespaceDeleted(
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
}
+ if (oPtr->myclassCommand) {
+ Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myclassCommand);
+ }
if (oPtr->myCommand) {
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
}
@@ -2538,6 +2497,43 @@ TclOOInvokeObject(
/*
* ----------------------------------------------------------------------
*
+ * MyClassObjCmd, MyClassNRObjCmd --
+ *
+ * Special trap door to allow an object to delegate simply to its class.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+MyClassObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ return Tcl_NRCallObjProc(interp, MyClassNRObjCmd, clientData, objc, objv);
+}
+
+static int
+MyClassNRObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ Object *oPtr = clientData;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "methodName ?arg ...?");
+ return TCL_ERROR;
+ }
+ return TclOOObjectCmdCore(oPtr->selfCls->thisPtr, interp, objc, objv, 0,
+ NULL);
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* TclOOObjectCmdCore, FinalizeObjectCall --
*
* Main function for object invocations. Does call chain creation,
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index b12ef81..7f7397b 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -83,7 +83,7 @@ TclOO_Class_Constructor(
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
- Tcl_Obj **invoke;
+ Tcl_Obj **invoke, *nameObj;
if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
@@ -94,6 +94,17 @@ TclOO_Class_Constructor(
}
/*
+ * Make the class definition delegate. This is special; it doesn't reenter
+ * here (and the class definition delegate doesn't run any constructors).
+ */
+
+ nameObj = Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1);
+ Tcl_AppendToObj(nameObj, ":: oo ::delegate", -1);
+ Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls,
+ TclGetString(nameObj), NULL, -1, NULL, -1);
+ Tcl_DecrRefCount(nameObj);
+
+ /*
* Delegate to [oo::define] to do the work.
*/
@@ -111,7 +122,7 @@ TclOO_Class_Constructor(
Tcl_IncrRefCount(invoke[1]);
Tcl_IncrRefCount(invoke[2]);
TclNRAddCallback(interp, DecrRefsPostClassConstructor,
- invoke, NULL, NULL, NULL);
+ invoke, oPtr, NULL, NULL);
/*
* Tricky point: do not want the extra reported level in the Tcl stack
@@ -128,12 +139,27 @@ DecrRefsPostClassConstructor(
int result)
{
Tcl_Obj **invoke = data[0];
+ Object *oPtr = data[1];
+ Tcl_InterpState saved;
+ int code;
TclDecrRefCount(invoke[0]);
TclDecrRefCount(invoke[1]);
TclDecrRefCount(invoke[2]);
+ invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1);
+ invoke[1] = TclOOObjectName(interp, oPtr);
+ Tcl_IncrRefCount(invoke[0]);
+ Tcl_IncrRefCount(invoke[1]);
+ saved = Tcl_SaveInterpState(interp, result);
+ code = Tcl_EvalObjv(interp, 2, invoke, 0);
+ TclDecrRefCount(invoke[0]);
+ TclDecrRefCount(invoke[1]);
Tcl_Free(invoke);
- return result;
+ if (code != TCL_OK) {
+ Tcl_DiscardInterpState(saved);
+ return code;
+ }
+ return Tcl_RestoreInterpState(interp, saved);
}
/*
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index e7d2010..2f3b470 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -209,6 +209,8 @@ typedef struct Object {
PrivateVariableList privateVariables;
/* Configurations for the variable resolver
* used inside methods. */
+ Tcl_Command myclassCommand; /* Reference to this object's class dispatcher
+ * command. */
} Object;
#define OBJECT_DELETED 1 /* Flag to say that an object has been
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
new file mode 100644
index 0000000..e63bd86
--- /dev/null
+++ b/generic/tclOOScript.h
@@ -0,0 +1,240 @@
+/*
+ * tclOOScript.h --
+ *
+ * This file contains support scripts for TclOO. They are defined here so
+ * that the code can be definitely run even in safe interpreters; TclOO's
+ * core setup is safe.
+ *
+ * Copyright (c) 2012-2018 Donal K. Fellows
+ * Copyright (c) 2013 Andreas Kupries
+ * Copyright (c) 2017 Gerald Lester
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#ifndef TCL_OO_SCRIPT_H
+#define TCL_OO_SCRIPT_H
+
+/*
+ * The scripted part of the definitions of TclOO.
+ *
+ * Compiled from generic/tclOOScript.tcl by tools/makeHeader.tcl, which
+ * contains the commented version of everything; *this* file is automatically
+ * generated.
+ */
+
+static const char *tclOOSetupScript =
+/* !BEGIN!: Do not edit below this line. */
+"::namespace eval ::oo {\n"
+"\t::namespace path {}\n"
+"\tnamespace eval Helpers {\n"
+"\t\t::namespace path {}\n"
+"\t\tproc callback {method args} {\n"
+"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n"
+"\t\t}\n"
+"\t\tnamespace export callback\n"
+"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n"
+"\t\tnamespace export -clear\n"
+"\t\trename tmp::callback mymethod\n"
+"\t\tnamespace delete tmp\n"
+"\t\tproc classvariable {name args} {\n"
+"\t\t\tset ns [info object namespace [uplevel 1 {self class}]]\n"
+"\t\t\tforeach v [list $name {*}$args] {\n"
+"\t\t\t\tif {[string match *(*) $v]} {\n"
+"\t\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n"
+"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n"
+"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
+"\t\t\t\t}\n"
+"\t\t\t\tif {[string match *::* $v]} {\n"
+"\t\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n"
+"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n"
+"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
+"\t\t\t\t}\n"
+"\t\t\t\tlappend vs $v $v\n"
+"\t\t\t}\n"
+"\t\t\ttailcall namespace upvar $ns {*}$vs\n"
+"\t\t}\n"
+"\t\tproc link {args} {\n"
+"\t\t\tset ns [uplevel 1 {::namespace current}]\n"
+"\t\t\tforeach link $args {\n"
+"\t\t\t\tif {[llength $link] == 2} {\n"
+"\t\t\t\t\tlassign $link src dst\n"
+"\t\t\t\t} elseif {[llength $link] == 1} {\n"
+"\t\t\t\t\tlassign $link src\n"
+"\t\t\t\t\tset dst $src\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\treturn -code error -errorcode {TCLOO CMDLINK FORMAT} \\\n"
+"\t\t\t\t\t\t\"bad link description; must only have one or two elements\"\n"
+"\t\t\t\t}\n"
+"\t\t\t\tif {![string match ::* $src]} {\n"
+"\t\t\t\t\tset src [string cat $ns :: $src]\n"
+"\t\t\t\t}\n"
+"\t\t\t\tinterp alias {} $src {} ${ns}::my $dst\n"
+"\t\t\t\ttrace add command ${ns}::my delete [list \\\n"
+"\t\t\t\t\t::oo::UnlinkLinkedCommand $src]\n"
+"\t\t\t}\n"
+"\t\t\treturn\n"
+"\t\t}\n"
+"\t}\n"
+"\tproc UnlinkLinkedCommand {cmd args} {\n"
+"\t\tif {[namespace which $cmd] ne {}} {\n"
+"\t\t\trename $cmd {}\n"
+"\t\t}\n"
+"\t}\n"
+"\tproc DelegateName {class} {\n"
+"\t\tstring cat [info object namespace $class] {:: oo ::delegate}\n"
+"\t}\n"
+"\tproc MixinClassDelegates {class} {\n"
+"\t\tif {![info object isa class $class]} {\n"
+"\t\t\treturn\n"
+"\t\t}\n"
+"\t\tset delegate [DelegateName $class]\n"
+"\t\tif {![info object isa class $delegate]} {\n"
+"\t\t\treturn\n"
+"\t\t}\n"
+"\t\tforeach c [info class superclass $class] {\n"
+"\t\t\tset d [DelegateName $c]\n"
+"\t\t\tif {![info object isa class $d]} {\n"
+"\t\t\t\tcontinue\n"
+"\t\t\t}\n"
+"\t\t\tdefine $delegate superclass -append $d\n"
+"\t\t}\n"
+"\t\tobjdefine $class mixin -append $delegate\n"
+"\t}\n"
+"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
+"\t\tset originDelegate [DelegateName $originObject]\n"
+"\t\tset targetDelegate [DelegateName $targetObject]\n"
+"\t\tif {\n"
+"\t\t\t[info object isa class $originDelegate]\n"
+"\t\t\t&& ![info object isa class $targetDelegate]\n"
+"\t\t} then {\n"
+"\t\t\tcopy $originDelegate $targetDelegate\n"
+"\t\t\tobjdefine $targetObject mixin -set \\\n"
+"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n"
+"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n"
+"\t\t\t\t}]\n"
+"\t\t}\n"
+"\t}\n"
+"\tproc define::classmethod {name {args {}} {body {}}} {\n"
+"\t\t::set argc [::llength [::info level 0]]\n"
+"\t\t::if {$argc == 3} {\n"
+"\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n"
+"\t\t\t\t{wrong # args: should be \"%s name \?args body\?\"} \\\n"
+"\t\t\t\t[::lindex [::info level 0] 0]]\n"
+"\t\t}\n"
+"\t\t::set cls [::uplevel 1 self]\n"
+"\t\t::if {$argc == 4} {\n"
+"\t\t\t::oo::define [::oo::DelegateName $cls] method $name $args $body\n"
+"\t\t}\n"
+"\t\t::tailcall forward $name myclass $name\n"
+"\t}\n"
+"\tproc define::initialise {body} {\n"
+"\t\t::set clsns [::info object namespace [::uplevel 1 self]]\n"
+"\t\t::tailcall apply [::list {} $body $clsns]\n"
+"\t}\n"
+"\tnamespace eval define {\n"
+"\t\t::namespace export initialise\n"
+"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n"
+"\t\t::namespace export -clear\n"
+"\t\t::rename tmp::initialise initialize\n"
+"\t\t::namespace delete tmp\n"
+"\t}\n"
+"\tdefine Slot {\n"
+"\t\tmethod Get {} {\n"
+"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
+"\t\t}\n"
+"\t\tmethod Set list {\n"
+"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
+"\t\t}\n"
+"\t\tmethod -set args {tailcall my Set $args}\n"
+"\t\tmethod -append args {\n"
+"\t\t\tset current [uplevel 1 [list [namespace which my] Get]]\n"
+"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
+"\t\t}\n"
+"\t\tmethod -clear {} {tailcall my Set {}}\n"
+"\t\tforward --default-operation my -append\n"
+"\t\tmethod unknown {args} {\n"
+"\t\t\tset def --default-operation\n"
+"\t\t\tif {[llength $args] == 0} {\n"
+"\t\t\t\ttailcall my $def\n"
+"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n"
+"\t\t\t\ttailcall my $def {*}$args\n"
+"\t\t\t}\n"
+"\t\t\tnext {*}$args\n"
+"\t\t}\n"
+"\t\texport -set -append -clear\n"
+"\t\tunexport unknown destroy\n"
+"\t}\n"
+"\tobjdefine define::superclass forward --default-operation my -set\n"
+"\tobjdefine define::mixin forward --default-operation my -set\n"
+"\tobjdefine objdefine::mixin forward --default-operation my -set\n"
+"\tdefine object method <cloned> {originObject} {\n"
+"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n"
+"\t\t\tset args [info args $p]\n"
+"\t\t\tset idx -1\n"
+"\t\t\tforeach a $args {\n"
+"\t\t\t\tif {[info default $p $a d]} {\n"
+"\t\t\t\t\tlset args [incr idx] [list $a $d]\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\tlset args [incr idx] [list $a]\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t\tset b [info body $p]\n"
+"\t\t\tset p [namespace tail $p]\n"
+"\t\t\tproc $p $args $b\n"
+"\t\t}\n"
+"\t\tforeach v [info vars [info object namespace $originObject]::*] {\n"
+"\t\t\tupvar 0 $v vOrigin\n"
+"\t\t\tnamespace upvar [namespace current] [namespace tail $v] vNew\n"
+"\t\t\tif {[info exists vOrigin]} {\n"
+"\t\t\t\tif {[array exists vOrigin]} {\n"
+"\t\t\t\t\tarray set vNew [array get vOrigin]\n"
+"\t\t\t\t} else {\n"
+"\t\t\t\t\tset vNew $vOrigin\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t}\n"
+"\t}\n"
+"\tdefine class method <cloned> {originObject} {\n"
+"\t\tnext $originObject\n"
+"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
+"\t}\n"
+"\tclass create singleton {\n"
+"\t\tsuperclass class\n"
+"\t\tvariable object\n"
+"\t\tunexport create createWithNamespace\n"
+"\t\tmethod new args {\n"
+"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n"
+"\t\t\t\tset object [next {*}$args]\n"
+"\t\t\t\t::oo::objdefine $object {\n"
+"\t\t\t\t\tmethod destroy {} {\n"
+"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
+"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t\tmethod <cloned> {originObject} {\n"
+"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
+"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n"
+"\t\t\t\t\t}\n"
+"\t\t\t\t}\n"
+"\t\t\t}\n"
+"\t\t\treturn $object\n"
+"\t\t}\n"
+"\t}\n"
+"\tclass create abstract {\n"
+"\t\tsuperclass class\n"
+"\t\tunexport create createWithNamespace new\n"
+"\t}\n"
+"}\n"
+/* !END!: Do not edit above this line. */
+;
+
+#endif /* TCL_OO_SCRIPT_H */
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl
new file mode 100644
index 0000000..d3706ce
--- /dev/null
+++ b/generic/tclOOScript.tcl
@@ -0,0 +1,422 @@
+# tclOOScript.h --
+#
+# This file contains support scripts for TclOO. They are defined here so
+# that the code can be definitely run even in safe interpreters; TclOO's
+# core setup is safe.
+#
+# Copyright (c) 2012-2018 Donal K. Fellows
+# Copyright (c) 2013 Andreas Kupries
+# Copyright (c) 2017 Gerald Lester
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+::namespace eval ::oo {
+ ::namespace path {}
+
+ #
+ # Commands that are made available to objects by default.
+ #
+ namespace eval Helpers {
+ ::namespace path {}
+
+ # ------------------------------------------------------------------
+ #
+ # callback, mymethod --
+ #
+ # Create a script prefix that calls a method on the current
+ # object. Same operation, two names.
+ #
+ # ------------------------------------------------------------------
+
+ proc callback {method args} {
+ list [uplevel 1 {::namespace which my}] $method {*}$args
+ }
+
+ # Make the [callback] command appear as [mymethod] too.
+ namespace export callback
+ namespace eval tmp {namespace import ::oo::Helpers::callback}
+ namespace export -clear
+ rename tmp::callback mymethod
+ namespace delete tmp
+
+ # ------------------------------------------------------------------
+ #
+ # classvariable --
+ #
+ # Link to a variable in the class of the current object.
+ #
+ # ------------------------------------------------------------------
+
+ proc classvariable {name args} {
+ # Get a reference to the class's namespace
+ set ns [info object namespace [uplevel 1 {self class}]]
+ # Double up the list of variable names
+ foreach v [list $name {*}$args] {
+ if {[string match *(*) $v]} {
+ set reason "can't create a scalar variable that looks like an array element"
+ return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \
+ [format {bad variable name "%s": %s} $v $reason]
+ }
+ if {[string match *::* $v]} {
+ set reason "can't create a local variable with a namespace separator in it"
+ return -code error -errorcode {TCL UPVAR INVERTED} \
+ [format {bad variable name "%s": %s} $v $reason]
+ }
+ lappend vs $v $v
+ }
+ # Lastly, link the caller's local variables to the class's variables
+ tailcall namespace upvar $ns {*}$vs
+ }
+
+ # ------------------------------------------------------------------
+ #
+ # link --
+ #
+ # Make a command that invokes a method on the current object.
+ # The name of the command and the name of the method match by
+ # default.
+ #
+ # ------------------------------------------------------------------
+
+ proc link {args} {
+ set ns [uplevel 1 {::namespace current}]
+ foreach link $args {
+ if {[llength $link] == 2} {
+ lassign $link src dst
+ } elseif {[llength $link] == 1} {
+ lassign $link src
+ set dst $src
+ } else {
+ return -code error -errorcode {TCLOO CMDLINK FORMAT} \
+ "bad link description; must only have one or two elements"
+ }
+ if {![string match ::* $src]} {
+ set src [string cat $ns :: $src]
+ }
+ interp alias {} $src {} ${ns}::my $dst
+ trace add command ${ns}::my delete [list \
+ ::oo::UnlinkLinkedCommand $src]
+ }
+ return
+ }
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # UnlinkLinkedCommand --
+ #
+ # Callback used to remove linked command when the underlying mechanism
+ # that supports it is deleted.
+ #
+ # ----------------------------------------------------------------------
+
+ proc UnlinkLinkedCommand {cmd args} {
+ if {[namespace which $cmd] ne {}} {
+ rename $cmd {}
+ }
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # DelegateName --
+ #
+ # Utility that gets the name of the class delegate for a class. It's
+ # trivial, but makes working with them much easier as delegate names are
+ # intentionally hard to create by accident.
+ #
+ # ----------------------------------------------------------------------
+
+ proc DelegateName {class} {
+ string cat [info object namespace $class] {:: oo ::delegate}
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # MixinClassDelegates --
+ #
+ # Support code called *after* [oo::define] inside the constructor of a
+ # class that patches in the appropriate class delegates.
+ #
+ # ----------------------------------------------------------------------
+
+ proc MixinClassDelegates {class} {
+ if {![info object isa class $class]} {
+ return
+ }
+ set delegate [DelegateName $class]
+ if {![info object isa class $delegate]} {
+ return
+ }
+ foreach c [info class superclass $class] {
+ set d [DelegateName $c]
+ if {![info object isa class $d]} {
+ continue
+ }
+ define $delegate superclass -append $d
+ }
+ objdefine $class mixin -append $delegate
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # UpdateClassDelegatesAfterClone --
+ #
+ # Support code that is like [MixinClassDelegates] except for when a
+ # class is cloned.
+ #
+ # ----------------------------------------------------------------------
+
+ proc UpdateClassDelegatesAfterClone {originObject targetObject} {
+ # Rebuild the class inheritance delegation class
+ set originDelegate [DelegateName $originObject]
+ set targetDelegate [DelegateName $targetObject]
+ if {
+ [info object isa class $originDelegate]
+ && ![info object isa class $targetDelegate]
+ } then {
+ copy $originDelegate $targetDelegate
+ objdefine $targetObject mixin -set \
+ {*}[lmap c [info object mixin $targetObject] {
+ if {$c eq $originDelegate} {set targetDelegate} {set c}
+ }]
+ }
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # oo::define::classmethod --
+ #
+ # Defines a class method. See define(n) for details.
+ #
+ # Note that the ::oo::define namespace is semi-public and a bit weird
+ # anyway, so we don't regard the namespace path as being under control:
+ # fully qualified names are used for everything.
+ #
+ # ----------------------------------------------------------------------
+
+ proc define::classmethod {name {args {}} {body {}}} {
+ # Create the method on the class if the caller gave arguments and body
+ ::set argc [::llength [::info level 0]]
+ ::if {$argc == 3} {
+ ::return -code error -errorcode {TCL WRONGARGS} [::format \
+ {wrong # args: should be "%s name ?args body?"} \
+ [::lindex [::info level 0] 0]]
+ }
+ ::set cls [::uplevel 1 self]
+ ::if {$argc == 4} {
+ ::oo::define [::oo::DelegateName $cls] method $name $args $body
+ }
+ # Make the connection by forwarding
+ ::tailcall forward $name myclass $name
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # oo::define::initialise, oo::define::initialize --
+ #
+ # Do specific initialisation for a class. See define(n) for details.
+ #
+ # Note that the ::oo::define namespace is semi-public and a bit weird
+ # anyway, so we don't regard the namespace path as being under control:
+ # fully qualified names are used for everything.
+ #
+ # ----------------------------------------------------------------------
+
+ proc define::initialise {body} {
+ ::set clsns [::info object namespace [::uplevel 1 self]]
+ ::tailcall apply [::list {} $body $clsns]
+ }
+
+ # Make the [initialise] definition appear as [initialize] too
+ namespace eval define {
+ ::namespace export initialise
+ ::namespace eval tmp {::namespace import ::oo::define::initialise}
+ ::namespace export -clear
+ ::rename tmp::initialise initialize
+ ::namespace delete tmp
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # Slot --
+ #
+ # The class of slot operations, which are basically lists at the low
+ # level of TclOO; this provides a more consistent interface to them.
+ #
+ # ----------------------------------------------------------------------
+
+ define Slot {
+ # ------------------------------------------------------------------
+ #
+ # Slot Get --
+ #
+ # Basic slot getter. Retrieves the contents of the slot.
+ # Particular slots must provide concrete non-erroring
+ # implementation.
+ #
+ # ------------------------------------------------------------------
+
+ method Get {} {
+ return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
+ }
+
+ # ------------------------------------------------------------------
+ #
+ # Slot Set --
+ #
+ # Basic slot setter. Sets the contents of the slot. Particular
+ # slots must provide concrete non-erroring implementation.
+ #
+ # ------------------------------------------------------------------
+
+ method Set list {
+ return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
+ }
+
+ # ------------------------------------------------------------------
+ #
+ # Slot -set, -append, -clear, --default-operation --
+ #
+ # Standard public slot operations. If a slot can't figure out
+ # what method to call directly, it uses --default-operation.
+ #
+ # ------------------------------------------------------------------
+
+ method -set args {tailcall my Set $args}
+ method -append args {
+ set current [uplevel 1 [list [namespace which my] Get]]
+ tailcall my Set [list {*}$current {*}$args]
+ }
+ method -clear {} {tailcall my Set {}}
+
+ # Default handling
+ forward --default-operation my -append
+ method unknown {args} {
+ set def --default-operation
+ if {[llength $args] == 0} {
+ tailcall my $def
+ } elseif {![string match -* [lindex $args 0]]} {
+ tailcall my $def {*}$args
+ }
+ next {*}$args
+ }
+
+ # Set up what is exported and what isn't
+ export -set -append -clear
+ unexport unknown destroy
+ }
+
+ # Set the default operation differently for these slots
+ objdefine define::superclass forward --default-operation my -set
+ objdefine define::mixin forward --default-operation my -set
+ objdefine objdefine::mixin forward --default-operation my -set
+
+ # ----------------------------------------------------------------------
+ #
+ # oo::object <cloned> --
+ #
+ # Handler for cloning objects that clones basic bits (only!) of the
+ # object's namespace. Non-procedures, traces, sub-namespaces, etc. need
+ # more complex (and class-specific) handling.
+ #
+ # ----------------------------------------------------------------------
+
+ define object method <cloned> {originObject} {
+ # Copy over the procedures from the original namespace
+ foreach p [info procs [info object namespace $originObject]::*] {
+ set args [info args $p]
+ set idx -1
+ foreach a $args {
+ if {[info default $p $a d]} {
+ lset args [incr idx] [list $a $d]
+ } else {
+ lset args [incr idx] [list $a]
+ }
+ }
+ set b [info body $p]
+ set p [namespace tail $p]
+ proc $p $args $b
+ }
+ # Copy over the variables from the original namespace
+ foreach v [info vars [info object namespace $originObject]::*] {
+ upvar 0 $v vOrigin
+ namespace upvar [namespace current] [namespace tail $v] vNew
+ if {[info exists vOrigin]} {
+ if {[array exists vOrigin]} {
+ array set vNew [array get vOrigin]
+ } else {
+ set vNew $vOrigin
+ }
+ }
+ }
+ # General commands, sub-namespaces and advancd variable config (traces,
+ # etc) are *not* copied over. Classes that want that should do it
+ # themselves.
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # oo::class <cloned> --
+ #
+ # Handler for cloning classes, which fixes up the delegates.
+ #
+ # ----------------------------------------------------------------------
+
+ define class method <cloned> {originObject} {
+ next $originObject
+ # Rebuild the class inheritance delegation class
+ ::oo::UpdateClassDelegatesAfterClone $originObject [self]
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # oo::singleton --
+ #
+ # A metaclass that is used to make classes that only permit one instance
+ # of them to exist. See singleton(n).
+ #
+ # ----------------------------------------------------------------------
+
+ class create singleton {
+ superclass class
+ variable object
+ unexport create createWithNamespace
+ method new args {
+ if {![info exists object] || ![info object isa object $object]} {
+ set object [next {*}$args]
+ ::oo::objdefine $object {
+ method destroy {} {
+ ::return -code error -errorcode {TCLOO SINGLETON} \
+ "may not destroy a singleton object"
+ }
+ method <cloned> {originObject} {
+ ::return -code error -errorcode {TCLOO SINGLETON} \
+ "may not clone a singleton object"
+ }
+ }
+ }
+ return $object
+ }
+ }
+
+ # ----------------------------------------------------------------------
+ #
+ # oo::abstract --
+ #
+ # A metaclass that is used to make classes that can't be directly
+ # instantiated. See abstract(n).
+ #
+ # ----------------------------------------------------------------------
+
+ class create abstract {
+ superclass class
+ unexport create createWithNamespace new
+ }
+}
+
+# Local Variables:
+# mode: tcl
+# c-basic-offset: 4
+# fill-column: 78
+# End:
diff --git a/generic/tclObj.c b/generic/tclObj.c
index a172342..19da2f6 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -2397,10 +2397,9 @@ Tcl_GetLongFromObj(
mp_int big;
UNPACK_BIGNUM(objPtr, big);
- if ((size_t) big.used <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1)
+ if ((size_t) big.used <= (CHAR_BIT * sizeof(unsigned long) + DIGIT_BIT - 1)
/ DIGIT_BIT) {
- unsigned long value = 0, numBytes = sizeof(long);
- long scratch;
+ unsigned long scratch, value = 0, numBytes = sizeof(unsigned long);
unsigned char *bytes = (unsigned char *) &scratch;
if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) {
@@ -2671,6 +2670,73 @@ Tcl_GetWideIntFromObj(
/*
*----------------------------------------------------------------------
*
+ * TclGetWideBitsFromObj --
+ *
+ * Attempt to return a wide integer from the Tcl object "objPtr". If the
+ * object is not already a int, double or bignum, an attempt will be made
+ * to convert it to one of these. Out-of-range values don't result in an
+ * error, but only the least significant 64 bits will be returned.
+ *
+ * Results:
+ * The return value is a standard Tcl object result. If an error occurs
+ * during conversion, an error message is left in the interpreter's
+ * result unless "interp" is NULL.
+ *
+ * Side effects:
+ * If the object is not already an int, double or bignum object, the
+ * conversion will free any old internal representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclGetWideBitsFromObj(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr, /* Object from which to get a wide int. */
+ Tcl_WideInt *wideIntPtr) /* Place to store resulting wide integer. */
+{
+ do {
+ if (objPtr->typePtr == &tclIntType) {
+ *wideIntPtr = objPtr->internalRep.wideValue;
+ return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclDoubleType) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "expected integer but got \"%s\"",
+ TclGetString(objPtr)));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
+ }
+ return TCL_ERROR;
+ }
+ if (objPtr->typePtr == &tclBignumType) {
+ mp_int big;
+
+ Tcl_WideUInt value = 0, scratch;
+ unsigned long numBytes = sizeof(Tcl_WideInt);
+ unsigned char *bytes = (unsigned char *) &scratch;
+
+ Tcl_GetBignumFromObj(NULL, objPtr, &big);
+ mp_mod_2d(&big, (int) (CHAR_BIT * sizeof(Tcl_WideInt)), &big);
+ mp_to_unsigned_bin_n(&big, bytes, &numBytes);
+ while (numBytes-- > 0) {
+ value = (value << CHAR_BIT) | *bytes++;
+ }
+ if (big.sign) {
+ value = -value;
+ }
+ *wideIntPtr = (Tcl_WideInt) value;
+ mp_clear(&big);
+ return TCL_OK;
+ }
+ } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL,
+ TCL_PARSE_INTEGER_ONLY)==TCL_OK);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* FreeBignum --
*
* This function frees the internal rep of a bignum.
diff --git a/generic/tclProcess.c b/generic/tclProcess.c
index 799d0d4..ef16f4f 100644
--- a/generic/tclProcess.c
+++ b/generic/tclProcess.c
@@ -47,7 +47,7 @@ static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid,
int resolvedPid);
static void FreeProcessInfo(ProcessInfo *info);
static int RefreshProcessInfo(ProcessInfo *info, int options);
-static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid,
+static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, size_t resolvedPid,
int options, int *codePtr, Tcl_Obj **msgPtr,
Tcl_Obj **errorObjPtr);
static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info);
@@ -193,7 +193,7 @@ RefreshProcessInfo(
TclProcessWaitStatus
WaitProcessStatus(
Tcl_Pid pid, /* Process id. */
- int resolvedPid, /* Resolved process id. */
+ size_t resolvedPid, /* Resolved process id. */
int options, /* Options passed to Tcl_WaitPid. */
int *codePtr, /* If non-NULL, will receive either:
* - 0 for normal exit.
@@ -799,7 +799,7 @@ void
TclProcessCreated(
Tcl_Pid pid) /* Process id. */
{
- int resolvedPid;
+ size_t resolvedPid;
Tcl_HashEntry *entry, *entry2;
int isNew;
ProcessInfo *info;
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index febc792..7289d5d 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -2020,33 +2020,15 @@ Tcl_AppendFormatToObj(
}
#ifndef TCL_WIDE_INT_IS_LONG
} else if (useWide) {
- if (TclGetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
- Tcl_Obj *objPtr;
-
- if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) {
- goto error;
- }
- mp_mod_2d(&big, (int) CHAR_BIT*sizeof(Tcl_WideInt), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- TclGetWideIntFromObj(NULL, objPtr, &w);
- Tcl_DecrRefCount(objPtr);
+ if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) {
+ goto error;
}
isNegative = (w < (Tcl_WideInt) 0);
if (w == (Tcl_WideInt) 0) gotHash = 0;
#endif
} else if (TclGetLongFromObj(NULL, segment, &l) != TCL_OK) {
- if (TclGetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
- Tcl_Obj *objPtr;
-
- if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) {
- goto error;
- }
- mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big);
- objPtr = Tcl_NewBignumObj(&big);
- Tcl_IncrRefCount(objPtr);
- TclGetLongFromObj(NULL, objPtr, &l);
- Tcl_DecrRefCount(objPtr);
+ if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) {
+ goto error;
} else {
l = Tcl_WideAsLong(w);
}
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 3aa0e4b..46a19be 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -68,7 +68,7 @@ doNothing(void)
{
/* dummy implementation, no need to do anything */
}
-# define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing
+# define TclWinAddProcess (void (*) (void *, size_t)) doNothing
# define TclWinFlushDirtyChannels doNothing
static int
TclpIsAtty(int fd)
@@ -98,10 +98,10 @@ TclWinNoBackslash(char *path)
return path;
}
-int
+size_t
TclpGetPid(Tcl_Pid pid)
{
- return (int) (size_t) pid;
+ return (size_t) pid;
}
char *
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 0a76533..8b9d169 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -293,6 +293,8 @@ static int TestgetassocdataCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestgetintCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
+static int TestlongsizeCmd(ClientData dummy,
+ Tcl_Interp *interp, int argc, const char **argv);
static int TestgetplatformCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestgetvarfullnameCmd(
@@ -645,6 +647,8 @@ Tcltest_Init(
NULL, NULL);
Tcl_CreateCommand(interp, "testgetint", TestgetintCmd,
NULL, NULL);
+ Tcl_CreateCommand(interp, "testlongsize", TestlongsizeCmd,
+ NULL, NULL);
Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetvarfullname",
@@ -6933,6 +6937,24 @@ TestgetintCmd(
}
}
+/*
+ * Used for determining sizeof(long) at script level.
+ */
+static int
+TestlongsizeCmd(
+ ClientData dummy,
+ Tcl_Interp *interp,
+ int argc,
+ const char **argv)
+{
+ if (argc != 1) {
+ Tcl_AppendResult(interp, "wrong # args", NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewIntObj((int)sizeof(long)));
+ return TCL_OK;
+}
+
static int
NREUnwind_callback(
ClientData data[],
diff --git a/tests/binary.test b/tests/binary.test
index 1ee815b..54e8e94 100644
--- a/tests/binary.test
+++ b/tests/binary.test
@@ -1647,22 +1647,6 @@ test binary-43.2 {Tcl_BinaryObjCmd: format wide int} {} {
binary format W 7810179016327718216
} lcTolleH
-test binary-44.1 {Tcl_BinaryObjCmd: scan wide int} {} {
- binary scan HelloTcl W x
- set x
-} 5216694956358656876
-test binary-44.2 {Tcl_BinaryObjCmd: scan wide int} {} {
- binary scan lcTolleH w x
- set x
-} 5216694956358656876
-test binary-44.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} {
- binary scan [binary format w [expr {wide(3) << 31}]] w x
- set x
-} 6442450944
-test binary-44.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} {
- binary scan [binary format W [expr {wide(3) << 31}]] W x
- set x
-} 6442450944
test binary-43.5 {Tcl_BinaryObjCmd: scan wide int} {} {
unset -nocomplain arg1
list [binary scan \x80[string repeat \x00 7] W arg1] $arg1
@@ -1684,6 +1668,31 @@ test binary-43.9 {Tcl_BinaryObjCmd: scan unsigned wide int} {} {
list [binary scan [string repeat \x00 7]\x80[string repeat \x00 7]\x80 wuw arg1 arg2] $arg1 $arg2
} {2 9223372036854775808 -9223372036854775808}
+test binary-44.1 {Tcl_BinaryObjCmd: scan wide int} {} {
+ binary scan HelloTcl W x
+ set x
+} 5216694956358656876
+test binary-44.2 {Tcl_BinaryObjCmd: scan wide int} {} {
+ binary scan lcTolleH w x
+ set x
+} 5216694956358656876
+test binary-44.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} {
+ binary scan [binary format w [expr {wide(3) << 31}]] w x
+ set x
+} 6442450944
+test binary-44.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} {
+ binary scan [binary format W [expr {wide(3) << 31}]] W x
+ set x
+} 6442450944
+test binary-44.5 {Tcl_BinaryObjCmd: scan wide int with bit 31 and 64 set} {} {
+ binary scan [binary format w [expr {(wide(3) << 31) + (wide(3) << 64)}]] w x
+ set x
+} 6442450944
+test binary-44.6 {Tcl_BinaryObjCmd: scan wide int with bit 31 and 64 set} {} {
+ binary scan [binary format W [expr {(wide(3) << 31) + (wide(3) << 64)}]] W x
+ set x
+} 6442450944
+
test binary-45.1 {Tcl_BinaryObjCmd: combined wide int handling} {
binary scan [binary format sws 16450 -1 19521] c* x
set x
diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test
index 1e267e3..4c51721 100644
--- a/tests/compExpr-old.test
+++ b/tests/compExpr-old.test
@@ -78,8 +78,8 @@ proc testIEEE {} {
}
testConstraint ieeeFloatingPoint [testIEEE]
-testConstraint longIs32bit [expr {int(0x80000000) < 0}]
-testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
+testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
+testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
# procedures used below
diff --git a/tests/execute.test b/tests/execute.test
index 91a7de2..13ac348 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -34,7 +34,7 @@ testConstraint testobj [expr {
&& [llength [info commands teststringobj]]
}]
-testConstraint longIs32bit [expr {int(0x80000000) < 0}]
+testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint testexprlongobj [llength [info commands testexprlongobj]]
# Tests for the omnibus TclExecuteByteCode function:
diff --git a/tests/expr-old.test b/tests/expr-old.test
index 4ffd02c..50040a5 100644
--- a/tests/expr-old.test
+++ b/tests/expr-old.test
@@ -22,7 +22,8 @@ catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testexprlong [llength [info commands testexprlong]]
testConstraint testexprdouble [llength [info commands testexprdouble]]
testConstraint testexprstring [llength [info commands testexprstring]]
-testConstraint longIs32bit [expr {int(0x80000000) < 0}]
+testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
+testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
# Big test for correct ordering of data in [expr]
diff --git a/tests/expr.test b/tests/expr.test
index e31da7a..279115c 100644
--- a/tests/expr.test
+++ b/tests/expr.test
@@ -21,10 +21,9 @@ catch [list package require -exact Tcltest [info patchlevel]]
# Determine if "long int" type is a 32 bit number and if the wide
# type is a 64 bit number on this machine.
-testConstraint longIs32bit [expr {int(0x80000000) < 0}]
-testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
-testConstraint wideIs64bit \
- [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}]
+testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
+testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
+testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]
# Big test for correct ordering of data in [expr]
diff --git a/tests/format.test b/tests/format.test
index 0f24e8f..4f22520 100644
--- a/tests/format.test
+++ b/tests/format.test
@@ -16,11 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
}
# %u output depends on word length, so this test is not portable.
-testConstraint longIs32bit [expr {int(0x80000000) < 0}]
-testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
-testConstraint wideIs64bit \
- [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}]
-testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}]
+testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
+testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
+testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]
testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}]
test format-1.1 {integer formatting} {
@@ -547,7 +545,7 @@ for {set i 290} {$i < 400} {incr i} {
append b "x"
}
-test format-17.1 {testing %d with wide} {wideIs64bit wideBiggerThanInt} {
+test format-17.1 {testing %d with wide} {longIs32bit wideIs64bit} {
format %d 7810179016327718216
} 1819043144
test format-17.2 {testing %ld with wide} {wideIs64bit} {
@@ -580,7 +578,7 @@ test format-18.1 {do not demote existing numeric values} {
format %08x $b
lappend result [expr {$a == $b}]
} {1 1 1 1}
-test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} {
+test format-18.2 {do not demote existing numeric values} {longIs32bit wideIs64bit} {
set a [expr {0xaaaaaaaaaa + 1}]
set b 0xaaaaaaaaab
list [format %08x $a] [expr {$a == $b}]
diff --git a/tests/get.test b/tests/get.test
index c82b7e5..9851925 100644
--- a/tests/get.test
+++ b/tests/get.test
@@ -20,8 +20,8 @@ catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testgetint [llength [info commands testgetint]]
testConstraint testdoubleobj [llength [info commands testdoubleobj]]
-testConstraint longIs32bit [expr {int(0x80000000) < 0}]
-testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
+testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
+testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
test get-1.1 {Tcl_GetInt procedure} testgetint {
testgetint 44 { 22}
diff --git a/tests/obj.test b/tests/obj.test
index cb62d3f..d407669 100644
--- a/tests/obj.test
+++ b/tests/obj.test
@@ -20,8 +20,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testobj [llength [info commands testobj]]
-testConstraint longIs32bit [expr {int(0x80000000) < 0}]
-testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}]
+testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
+testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]
test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj {
set r 1
@@ -549,11 +549,11 @@ test obj-32.1 {freeing very large object trees} {
unset x
} {}
-test obj-33.1 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
+test obj-33.1 {integer overflow on input} {longIs32bit wideIs64bit} {
set x 0x8000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {1 2147483648}
-test obj-33.2 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
+test obj-33.2 {integer overflow on input} {longIs32bit wideIs64bit} {
set x 0xffff; append x ffff
list [string is integer $x] [expr { wide($x) }]
} {1 4294967295}
@@ -561,15 +561,15 @@ test obj-33.3 {integer overflow on input} {
set x 0x10000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {0 4294967296}
-test obj-33.4 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
+test obj-33.4 {integer overflow on input} {longIs32bit wideIs64bit} {
set x -0x8000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {1 -2147483648}
-test obj-33.5 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
+test obj-33.5 {integer overflow on input} {longIs32bit wideIs64bit} {
set x -0x8000; append x 0001
list [string is integer $x] [expr { wide($x) }]
} {1 -2147483649}
-test obj-33.6 {integer overflow on input} {longIs32bit wideBiggerThanInt} {
+test obj-33.6 {integer overflow on input} {longIs32bit wideIs64bit} {
set x -0xffff; append x ffff
list [string is integer $x] [expr { wide($x) }]
} {1 -4294967295}
diff --git a/tests/oo.test b/tests/oo.test
index 85af233..a303309 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -340,10 +340,10 @@ test oo-1.21 {basic test of OO functionality: default relations} -setup {
lappend x [info object class ::oo::$initial]
}
return $x
- }] {lsort $x}
+ }] {lsort [lmap y $x {if {[string match *::delegate $y]} continue; set y}]}
} -cleanup {
interp delete $fresh
-} -result {{} {::oo::Slot ::oo::class ::oo::object} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}
+} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {::oo::abstract ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}
test oo-2.1 {basic test of OO functionality: constructor} -setup {
# This is a bit complex because it needs to run in a sub-interp as
@@ -4845,6 +4845,75 @@ test oo-40.3 {TIP 500: private and unexport} -setup {
} -cleanup {
cls destroy
} -result {{} {} foo {} foo {}}
+
+test oo-41.1 {TIP 478: myclass command, including class morphing} -setup {
+ oo::class create parent
+ set result {}
+} -body {
+ oo::class create cls1 {
+ superclass parent
+ self method count {} {
+ my variable c
+ incr c
+ }
+ method act {} {
+ myclass count
+ }
+ }
+ cls1 create x
+ lappend result [x act] [x act]
+ cls1 create y
+ lappend result [y act] [y act] [x act]
+ oo::class create cls2 {
+ superclass cls1
+ self method count {} {
+ my variable d
+ expr {1.0 * [incr d]}
+ }
+ }
+ oo::objdefine x {class cls2}
+ lappend result [x act] [y act] [x act] [y act]
+} -cleanup {
+ parent destroy
+} -result {1 2 3 4 5 1.0 6 2.0 7}
+test oo-41.2 {TIP 478: myclass command cleanup} -setup {
+ oo::class create parent
+ set result {}
+} -body {
+ oo::class create cls1 {
+ superclass parent
+ self method hi {} {
+ return "this is [self]"
+ }
+ method hi {} {
+ return "this is [self]"
+ }
+ }
+ cls1 create x
+ rename [info object namespace x]::my foo
+ rename [info object namespace x]::myclass bar
+ lappend result [cls1 hi] [x hi] [foo hi] [bar hi]
+ x destroy
+ lappend result [catch {foo hi}] [catch {bar hi}]
+} -cleanup {
+ parent destroy
+} -result {{this is ::cls1} {this is ::x} {this is ::x} {this is ::cls1} 1 1}
+test oo-41.3 {TIP 478: myclass command calls unexported methods, via forward} -setup {
+ oo::class create parent
+ set result {}
+} -body {
+ oo::class create cls1 {
+ superclass parent
+ self method Hi {} {
+ return "this is [self]"
+ }
+ forward poke myclass Hi
+ }
+ cls1 create x
+ lappend result [catch {cls1 Hi}] [x poke]
+} -cleanup {
+ parent destroy
+} -result {1 {this is ::cls1}}
cleanupTests
return
diff --git a/tests/ooUtil.test b/tests/ooUtil.test
new file mode 100644
index 0000000..ff7093f
--- /dev/null
+++ b/tests/ooUtil.test
@@ -0,0 +1,563 @@
+# This file contains a collection of tests for functionality originally
+# sourced from the ooutil package in Tcllib. Sourcing this file into Tcl runs
+# the tests and generates output for errors. No output means no errors were
+# found.
+#
+# Copyright (c) 2014-2016 Andreas Kupries
+# Copyright (c) 2018 Donal K. Fellows
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require TclOO 1.0.3
+package require tcltest 2
+if {"::tcltest" in [namespace children]} {
+ namespace import -force ::tcltest::*
+}
+
+test ooUtil-1.1 {TIP 478: classmethod} -setup {
+ oo::class create parent
+} -body {
+ oo::class create ActiveRecord {
+ superclass parent
+ classmethod find args {
+ return "[self] called with arguments: $args"
+ }
+ }
+ oo::class create Table {
+ superclass ActiveRecord
+ }
+ Table find foo bar
+} -cleanup {
+ parent destroy
+} -result {::Table called with arguments: foo bar}
+test ooUtil-1.2 {TIP 478: classmethod in namespace} -setup {
+ namespace eval ::testns {}
+} -body {
+ namespace eval ::testns {
+ oo::class create ActiveRecord {
+ classmethod find args {
+ return "[self] called with arguments: $args"
+ }
+ }
+ oo::class create Table {
+ superclass ActiveRecord
+ }
+ }
+ testns::Table find foo bar
+} -cleanup {
+ namespace delete ::testns
+} -result {::testns::Table called with arguments: foo bar}
+test ooUtil-1.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup {
+ oo::class create parent
+} -body {
+ oo::class create TestClass {
+ superclass oo::class parent
+ self method create {name ignore body} {
+ next $name $body
+ }
+ }
+ TestClass create okay {} {}
+} -cleanup {
+ parent destroy
+} -result {::okay}
+test ooUtil-1.4 {TIP 478: classmethod with several inheritance levels} -setup {
+ oo::class create parent
+} -body {
+ oo::class create ActiveRecord {
+ superclass parent
+ classmethod find args {
+ return "[self] called with arguments: $args"
+ }
+ }
+ oo::class create Table {
+ superclass ActiveRecord
+ }
+ oo::class create SubTable {
+ superclass Table
+ }
+ SubTable find foo bar
+} -cleanup {
+ parent destroy
+} -result {::SubTable called with arguments: foo bar}
+test ooUtil-1.5 {TIP 478: classmethod and instances} -setup {
+ oo::class create parent
+} -body {
+ oo::class create ActiveRecord {
+ superclass parent
+ classmethod find args {
+ return "[self] called with arguments: $args"
+ }
+ }
+ oo::class create Table {
+ superclass ActiveRecord
+ }
+ set t [Table new]
+ $t find 1 2 3
+} -cleanup {
+ parent destroy
+} -result {::Table called with arguments: 1 2 3}
+test ooUtil-1.6 {TIP 478: classmethod and instances} -setup {
+ oo::class create parent
+} -body {
+ oo::class create ActiveRecord {
+ superclass parent
+ classmethod find args {
+ return "[self] called with arguments: $args"
+ }
+ }
+ oo::class create Table {
+ superclass ActiveRecord
+ unexport find
+ }
+ set t [Table new]
+ $t find 1 2 3
+} -returnCodes error -cleanup {
+ parent destroy
+} -match glob -result {unknown method "find": must be *}
+test ooUtil-1.7 {} -setup {
+ oo::class create parent
+} -body {
+ oo::class create Foo {
+ superclass parent
+ classmethod bar {} {
+ puts "This is in the class; self is [self]"
+ my meee
+ }
+ classmethod meee {} {
+ puts "This is meee"
+ }
+ }
+ oo::class create Grill {
+ superclass Foo
+ classmethod meee {} {
+ puts "This is meee 2"
+ }
+ }
+ list [Foo bar] [Grill bar] [[Foo new] bar] [[Grill new] bar]
+} -cleanup {
+ parent destroy
+} -result {{} {} {} {}} -output "This is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\nThis is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\n"
+# Two tests to confirm that we correctly initialise the scripted part of TclOO
+# in child interpreters. This is slightly tricky at the implementation level
+# because we cannot count on either [source] or [open] being available.
+test ooUtil-1.8 {TIP 478: classmethod in child interp} -setup {
+ set childinterp [interp create]
+} -body {
+ $childinterp eval {
+ oo::class create ActiveRecord {
+ classmethod find args {
+ return "[self] called with arguments: $args"
+ }
+ }
+ oo::class create Table {
+ superclass ActiveRecord
+ }
+ # This is confirming that this is not the master interpreter
+ list [Table find foo bar] [info globals childinterp]
+ }
+} -cleanup {
+ interp delete $childinterp
+} -result {{::Table called with arguments: foo bar} {}}
+test ooUtil-1.9 {TIP 478: classmethod in safe child interp} -setup {
+ set safeinterp [interp create -safe]
+} -body {
+ $safeinterp eval {
+ oo::class create ActiveRecord {
+ classmethod find args {
+ return "[self] called with arguments: $args"
+ }
+ }
+ oo::class create Table {
+ superclass ActiveRecord
+ }
+ # This is confirming that this is a (basic) safe interpreter
+ list [Table find foo bar] [info commands source]
+ }
+} -cleanup {
+ interp delete $safeinterp
+} -result {{::Table called with arguments: foo bar} {}}
+
+test ooUtil-2.1 {TIP 478: callback generation} -setup {
+ oo::class create parent
+} -body {
+ oo::class create c {
+ superclass parent
+ method CallMe {} { return ok,[self] }
+ method makeCall {} {
+ return [callback CallMe]
+ }
+ }
+ c create ::context
+ set cb [context makeCall]
+ {*}$cb
+} -cleanup {
+ parent destroy
+} -result {ok,::context}
+test ooUtil-2.2 {TIP 478: callback generation} -setup {
+ oo::class create parent
+} -body {
+ oo::class create c {
+ superclass parent
+ method CallMe {a b c} { return ok,[self],$a,$b,$c }
+ method makeCall {b} {
+ return [callback CallMe 123 $b]
+ }
+ }
+ c create ::context
+ set cb [context makeCall "a b c"]
+ {*}$cb PQR
+} -cleanup {
+ parent destroy
+} -result {ok,::context,123,a b c,PQR}
+test ooUtil-2.3 {TIP 478: callback generation, alternate name} -setup {
+ oo::class create parent
+} -body {
+ oo::class create c {
+ superclass parent
+ method CallMe {} { return ok,[self] }
+ method makeCall {} {
+ return [mymethod CallMe]
+ }
+ }
+ c create ::context
+ set cb [context makeCall]
+ {*}$cb
+} -cleanup {
+ parent destroy
+} -result {ok,::context}
+test ooUtil-2.4 {TIP 478: callback generation, alternate name} -setup {
+ oo::class create parent
+} -body {
+ oo::class create c {
+ superclass parent
+ method CallMe {a b c} { return ok,[self],$a,$b,$c }
+ method makeCall {b} {
+ return [mymethod CallMe 123 $b]
+ }
+ }
+ c create ::context
+ set cb [context makeCall "a b c"]
+ {*}$cb PQR
+} -cleanup {
+ parent destroy
+} -result {ok,::context,123,a b c,PQR}
+test ooUtil-2.5 {TIP 478: callbacks and method lifetime} -setup {
+ oo::class create parent
+} -body {
+ oo::class create c {
+ superclass parent
+ method makeCall {b} {
+ return [callback CallMe 123 $b]
+ }
+ }
+ c create ::context
+ set cb [context makeCall "a b c"]
+ set result [list [catch {{*}$cb PQR} msg] $msg]
+ oo::objdefine context {
+ method CallMe {a b c} { return ok,[self],$a,$b,$c }
+ }
+ lappend result [{*}$cb PQR]
+} -cleanup {
+ parent destroy
+} -result {1 {unknown method "CallMe": must be <cloned>, destroy, eval, makeCall, unknown, variable or varname} {ok,::context,123,a b c,PQR}}
+test ooUtil-2.6 {TIP 478: callback use case} -setup {
+ oo::class create parent
+ unset -nocomplain x
+} -body {
+ oo::class create c {
+ superclass parent
+ variable count
+ constructor {var} {
+ set count 0
+ upvar 1 $var v
+ trace add variable v write [callback TraceCallback]
+ }
+ method count {} {return $count}
+ method TraceCallback {name1 name2 op} {
+ incr count
+ }
+ }
+ set o [c new x]
+ for {set x 0} {$x < 5} {incr x} {}
+ $o count
+} -cleanup {
+ unset -nocomplain x
+ parent destroy
+} -result 6
+
+test ooUtil-3.1 {TIP 478: class initialisation} -setup {
+ oo::class create parent
+ catch {rename ::foobar-3.1 {}}
+} -body {
+ oo::class create ::cls {
+ superclass parent
+ initialise {
+ proc foobar-3.1 {} {return ok}
+ }
+ method calls {} {
+ list [catch foobar-3.1 msg] $msg \
+ [namespace eval [info object namespace [self class]] foobar-3.1]
+ }
+ }
+ [cls new] calls
+} -cleanup {
+ parent destroy
+} -result {1 {invalid command name "foobar-3.1"} ok}
+test ooUtil-3.2 {TIP 478: class variables} -setup {
+ oo::class create parent
+ catch {rename ::foobar-3.1 {}}
+} -body {
+ oo::class create ::cls {
+ superclass parent
+ initialise {
+ variable x 123
+ }
+ method call {} {
+ classvariable x
+ incr x
+ }
+ }
+ cls create a
+ cls create b
+ cls create c
+ list [a call] [b call] [c call] [a call] [b call] [c call]
+} -cleanup {
+ parent destroy
+} -result {124 125 126 127 128 129}
+test ooUtil-3.3 {TIP 478: class initialisation} -setup {
+ oo::class create parent
+ catch {rename ::foobar-3.3 {}}
+} -body {
+ oo::class create ::cls {
+ superclass parent
+ initialize {
+ proc foobar-3.3 {} {return ok}
+ }
+ method calls {} {
+ list [catch foobar-3.3 msg] $msg \
+ [namespace eval [info object namespace [self class]] foobar-3.3]
+ }
+ }
+ [cls new] calls
+} -cleanup {
+ parent destroy
+} -result {1 {invalid command name "foobar-3.3"} ok}
+test ooUtil-3.4 {TIP 478: class initialisation} -setup {
+ oo::class create parent
+ catch {rename ::appendToResultVar {}}
+ proc ::appendToResultVar args {
+ lappend ::result {*}$args
+ }
+ set result {}
+} -body {
+ trace add execution oo::define::initialise enter appendToResultVar
+ oo::class create ::cls {
+ superclass parent
+ initialize {proc xyzzy {} {}}
+ }
+ return $result
+} -cleanup {
+ catch {
+ trace remove execution oo::define::initialise enter appendToResultVar
+ }
+ rename ::appendToResultVar {}
+ parent destroy
+} -result {{initialize {proc xyzzy {} {}}} enter}
+test ooUtil-3.5 {TIP 478: class initialisation} -body {
+ oo::define oo::object {
+ ::list [::namespace which initialise] [::namespace which initialize] \
+ [::namespace origin initialise] [::namespace origin initialize]
+ }
+} -result {::oo::define::initialise ::oo::define::initialize ::oo::define::initialise ::oo::define::initialise}
+
+test ooUtil-4.1 {TIP 478: singleton} -setup {
+ oo::class create parent
+} -body {
+ oo::singleton create xyz {
+ superclass parent
+ }
+ set x [xyz new]
+ set y [xyz new]
+ set z [xyz new]
+ set code [catch {$x destroy} msg]
+ set p [xyz new]
+ lappend code [catch {rename $x ""}]
+ set q [xyz new]
+ string map [list $x ONE $q TWO] [list {*}$code $x $y $z $p $q [xyz new]]
+} -cleanup {
+ parent destroy
+} -result {1 0 ONE ONE ONE ONE TWO TWO}
+test ooUtil-4.2 {TIP 478: singleton errors} -setup {
+ oo::class create parent
+} -body {
+ oo::singleton create xyz {
+ superclass parent
+ }
+ [xyz new] destroy
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {may not destroy a singleton object}
+test ooUtil-4.3 {TIP 478: singleton errors} -setup {
+ oo::class create parent
+} -body {
+ oo::singleton create xyz {
+ superclass parent
+ }
+ oo::copy [xyz new]
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {may not clone a singleton object}
+
+
+test ooUtil-5.1 {TIP 478: abstract} -setup {
+ oo::class create parent
+} -body {
+ oo::abstract create xyz {
+ superclass parent
+ method foo {} {return 123}
+ }
+ oo::class create pqr {
+ superclass xyz
+ method bar {} {return 456}
+ }
+ set codes [list [catch {xyz new}] [catch {xyz create x}] [catch {xyz createWithNamespace x y}]]
+ set x [pqr new]
+ set y [pqr create ::y]
+ lappend codes [$x foo] [$x bar] $y
+} -cleanup {
+ parent destroy
+} -result {1 1 1 123 456 ::y}
+
+test ooUtil-6.1 {TIP 478: classvarable} -setup {
+ oo::class create parent
+} -body {
+ oo::class create xyz {
+ superclass parent
+ initialise {
+ variable x 1 y 2
+ }
+ method a {} {
+ classvariable x
+ incr x
+ }
+ method b {} {
+ classvariable y
+ incr y
+ }
+ method c {} {
+ classvariable x y
+ list $x $y
+ }
+ }
+ set p [xyz new]
+ set q [xyz new]
+ set result [list [$p c] [$q c]]
+ $p a
+ $q b
+ lappend result [[xyz new] c]
+} -cleanup {
+ parent destroy
+} -result {{1 2} {1 2} {2 3}}
+test ooUtil-6.2 {TIP 478: classvarable error case} -setup {
+ oo::class create parent
+} -body {
+ oo::class create xyz {
+ superclass parent
+ method a {} {
+ classvariable x(1)
+ incr x(1)
+ }
+ }
+ set p [xyz new]
+ set q [xyz new]
+ list [$p a] [$q a]
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {bad variable name "x(1)": can't create a scalar variable that looks like an array element}
+test ooUtil-6.3 {TIP 478: classvarable error case} -setup {
+ oo::class create parent
+} -body {
+ oo::class create xyz {
+ superclass parent
+ method a {} {
+ classvariable ::x
+ incr x
+ }
+ }
+ set p [xyz new]
+ set q [xyz new]
+ list [$p a] [$q a]
+} -returnCodes error -cleanup {
+ parent destroy
+} -result {bad variable name "::x": can't create a local variable with a namespace separator in it}
+
+test ooUtil-7.1 {TIP 478: link calling pattern} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ method foo {} {return "in foo of [self]"}
+ method Bar {} {return "in bar of [self]"}
+ method Grill {} {return "in grill of [self]"}
+ export eval
+ constructor {} {
+ link foo
+ link {bar Bar} {grill Grill}
+ }
+ }
+ cls create o
+ o eval {list [foo] [bar] [grill]}
+} -cleanup {
+ parent destroy
+} -result {{in foo of ::o} {in bar of ::o} {in grill of ::o}}
+test ooUtil-7.2 {TIP 478: link removed when [my] disappears} -setup {
+ oo::class create parent
+} -body {
+ oo::class create cls {
+ superclass parent
+ method foo {} {return "in foo of [self]"}
+ constructor {cmd} {
+ link [list ::$cmd foo]
+ }
+ }
+ cls create o pqr
+ list [o foo] [pqr] [rename [info object namespace o]::my {}] [catch pqr msg] $msg
+} -cleanup {
+ parent destroy
+} -result {{in foo of ::o} {in foo of ::o} {} 1 {invalid command name "pqr"}}
+
+# Tests that verify issues detected with the tcllib version of the code
+test ooUtil-tcllib-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup {
+ oo::class create animal {}
+ namespace eval ::ooutiltest {
+ oo::class create pet { superclass animal }
+ }
+} -body {
+ namespace eval ::ooutiltest {
+ oo::class create dog { superclass pet }
+ }
+} -cleanup {
+ namespace delete ooutiltest
+ rename animal {}
+} -result {::ooutiltest::dog}
+test ooUtil-tcllib-ticket-fe7a0e0a3a {classmethod must not interfere with constructor signatures} -setup {
+ oo::class create TestClass {
+ superclass oo::class
+ self method create {name ignore body} {
+ next $name $body
+ }
+ }
+} -body {
+ TestClass create okay {} {}
+} -cleanup {
+ rename TestClass {}
+} -result {::okay}
+
+cleanupTests
+return
+
+# Local Variables:
+# fill-column: 78
+# mode: tcl
+# End:
diff --git a/tests/platform.test b/tests/platform.test
index fa533e8..5880fb9 100644
--- a/tests/platform.test
+++ b/tests/platform.test
@@ -25,6 +25,7 @@ namespace eval ::tcl::test::platform {
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testCPUID [llength [info commands testcpuid]]
+testConstraint testlongsize [llength [info commands testlongsize]]
test platform-1.0 {tcl_platform(engine)} {
set tcl_platform(engine)
@@ -39,16 +40,9 @@ test platform-1.1 {TclpSetVariables: tcl_platform} {
set result
} {byteOrder engine machine os osVersion pathSeparator platform pointerSize user wordSize}
-# Test assumes twos-complement arithmetic, which is true of virtually
-# everything these days. Note that this does *not* use wide(), and
-# this is intentional since that could make Tcl's numbers wider than
-# the machine-integer on some platforms...
-test platform-2.1 {tcl_platform(wordSize) indicates size of native word} {
- set result [expr {int(1 << (8 * $tcl_platform(wordSize) - 1))}]
- # Result must be the largest bit in a machine word, which this checks
- # without assuming how wide the word really is
- list [expr {$result < 0}] [expr {$result ^ int($result - 1)}]
-} {1 -1}
+test platform-2.1 {tcl_platform(wordSize) indicates size of native word} testlongsize {
+ expr {$tcl_platform(wordSize) == [testlongsize]}
+} {1}
# On Windows/UNIX, test that the CPU ID works
diff --git a/tests/scan.test b/tests/scan.test
index 1f32b9f..5c38fff 100644
--- a/tests/scan.test
+++ b/tests/scan.test
@@ -85,8 +85,7 @@ proc testIEEE {} {
}
testConstraint ieeeFloatingPoint [testIEEE]
-testConstraint wideIs64bit \
- [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}]
+testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]
test scan-1.1 {BuildCharSet, CharInSet} {
list [scan foo {%[^o]} x] $x
diff --git a/tools/makeHeader.tcl b/tools/makeHeader.tcl
new file mode 100644
index 0000000..e9b7ed1
--- /dev/null
+++ b/tools/makeHeader.tcl
@@ -0,0 +1,182 @@
+# makeHeader.tcl --
+#
+# This script generates embeddable C source (in a .h file) from a .tcl
+# script.
+#
+# Copyright (c) 2018 Donal K. Fellows
+#
+# 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.6
+
+namespace eval makeHeader {
+
+ ####################################################################
+ #
+ # mapSpecial --
+ # Transform a single line so that it is able to be put in a C string.
+ #
+ proc mapSpecial {str} {
+ # All Tcl metacharacters and key C backslash sequences
+ set MAP {
+ \" \\\\\" \\ \\\\\\\\ $ \\$ [ \\[ ] \\] ' \\\\' ? \\\\?
+ \a \\\\a \b \\\\b \f \\\\f \n \\\\n \r \\\\r \t \\\\t \v \\\\v
+ }
+ set XFORM {[format \\\\\\\\u%04x {*}[scan & %c]]}
+
+ subst [regsub -all {[^\u0020-\u007e]} [string map $MAP $str] $XFORM]
+ }
+
+ ####################################################################
+ #
+ # compactLeadingSpaces --
+ # Converts the leading whitespace on a line into a more compact form.
+ #
+ proc compactLeadingSpaces {line} {
+ set line [string map {\t { }} [string trimright $line]]
+ if {[regexp {^[ ]+} $line spaces]} {
+ regsub -all {[ ]{4}} $spaces \t replace
+ set len [expr {[string length $spaces] - 1}]
+ set line [string replace $line 0 $len $replace]
+ }
+ return $line
+ }
+
+ ####################################################################
+ #
+ # processScript --
+ # Transform a whole sequence of lines with [mapSpecial].
+ #
+ proc processScript {scriptLines} {
+ lmap line $scriptLines {
+ # Skip blank and comment lines; they're there in the original
+ # sources so we don't need to copy them over.
+ if {[regexp {^\s*(?:#|$)} $line]} continue
+ format {"%s"} [mapSpecial [compactLeadingSpaces $line]\n]
+ }
+ }
+
+ ####################################################################
+ #
+ # updateTemplate --
+ # Rewrite a template to contain the content from the input script.
+ #
+ proc updateTemplate {dataVar scriptLines} {
+ set BEGIN "*!BEGIN!: Do not edit below this line.*"
+ set END "*!END!: Do not edit above this line.*"
+
+ upvar 1 $dataVar data
+
+ set from [lsearch -glob $data $BEGIN]
+ set to [lsearch -glob $data $END]
+ if {$from == -1 || $to == -1 || $from >= $to} {
+ throw BAD "not a template"
+ }
+
+ set data [lreplace $data $from+1 $to-1 {*}[processScript $scriptLines]]
+ }
+
+ ####################################################################
+ #
+ # stripSurround --
+ # Removes the header and footer comments from a (line-split list of
+ # lines of) Tcl script code.
+ #
+ proc stripSurround {lines} {
+ set RE {^\s*$|^#}
+ set state 0
+ set lines [lmap line [lreverse $lines] {
+ if {!$state && [regexp $RE $line]} continue {
+ set state 1
+ set line
+ }
+ }]
+ return [lmap line [lreverse $lines] {
+ if {$state && [regexp $RE $line]} continue {
+ set state 0
+ set line
+ }
+ }]
+ }
+
+ ####################################################################
+ #
+ # updateTemplateFile --
+ # Rewrites a template file with the lines of the given script.
+ #
+ proc updateTemplateFile {headerFile scriptLines} {
+ set f [open $headerFile "r+"]
+ try {
+ set content [split [chan read -nonewline $f] "\n"]
+ updateTemplate content [stripSurround $scriptLines]
+ chan seek $f 0
+ chan puts $f [join $content \n]
+ chan truncate $f
+ } trap BAD msg {
+ # Add the filename to the message
+ throw BAD "${headerFile}: $msg"
+ } finally {
+ chan close $f
+ }
+ }
+
+ ####################################################################
+ #
+ # readScript --
+ # Read a script from a file and return its lines.
+ #
+ proc readScript {script} {
+ set f [open $script]
+ try {
+ chan configure $f -encoding utf-8
+ return [split [string trim [chan read $f]] "\n"]
+ } finally {
+ chan close $f
+ }
+ }
+
+ ####################################################################
+ #
+ # run --
+ # The main program of this script.
+ #
+ proc run {args} {
+ try {
+ if {[llength $args] != 2} {
+ throw ARGS "inputTclScript templateFile"
+ }
+ lassign $args inputTclScript templateFile
+
+ puts "Inserting $inputTclScript into $templateFile"
+ set scriptLines [readScript $inputTclScript]
+ updateTemplateFile $templateFile $scriptLines
+ exit 0
+ } trap ARGS msg {
+ puts stderr "wrong # args: should be \"[file tail $::argv0] $msg\""
+ exit 2
+ } trap BAD msg {
+ puts stderr $msg
+ exit 1
+ } trap POSIX msg {
+ puts stderr $msg
+ exit 1
+ } on error {- opts} {
+ puts stderr [dict get $opts -errorinfo]
+ exit 3
+ }
+ }
+}
+
+########################################################################
+#
+# Launch the main program
+#
+if {[info script] eq $::argv0} {
+ makeHeader::run {*}$::argv
+}
+
+# Local-Variables:
+# mode: tcl
+# fill-column: 78
+# End:
diff --git a/unix/Makefile.in b/unix/Makefile.in
index c79a11a..1b999ca 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -259,6 +259,7 @@ INSTALL_TZDATA = @INSTALL_TZDATA@
#--------------------------------------------------------------------------
GDB = gdb
+LLDB = lldb
TRACE = strace
TRACE_OPTS =
VALGRIND = valgrind
@@ -732,6 +733,12 @@ gdb-test: ${TCLTEST_EXE}
$(GDB) ./${TCLTEST_EXE} --command=gdb.run
rm gdb.run
+lldb-test: ${TCLTEST_EXE}
+ @echo "settings set target.env-vars @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > lldb.run
+ @echo "settings set target.env-vars TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> lldb.run
+ $(LLDB) --source lldb.run ./${TCLTEST_EXE} -- $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) -singleproc 1
+ rm lldb.run
+
# Useful target to launch a built tcltest with the proper path,...
runtest: ${TCLTEST_EXE}
$(SHELL_ENV) ./${TCLTEST_EXE}
@@ -1222,7 +1229,7 @@ tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c $(COMPILEHDR)
tclNotify.o: $(GENERIC_DIR)/tclNotify.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNotify.c
-tclOO.o: $(GENERIC_DIR)/tclOO.c
+tclOO.o: $(GENERIC_DIR)/tclOO.c $(GENERIC_DIR)/tclOOScript.h
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOO.c
tclOOBasic.o: $(GENERIC_DIR)/tclOOBasic.c
@@ -1890,6 +1897,11 @@ $(GENERIC_DIR)/tclOOStubInit.c: $(GENERIC_DIR)/tclOO.decls
@echo "Developers may want to run \"make genstubs\" to regenerate."
@echo "This warning can be safely ignored, do not report as a bug!"
+$(GENERIC_DIR)/tclOOScript.h: $(GENERIC_DIR)/tclOOScript.tcl
+ @echo "Warning: tclOOScript.h may be out of date."
+ @echo "Developers may want to run \"make genscript\" to regenerate."
+ @echo "This warning can be safely ignored, do not report as a bug!"
+
genstubs:
$(NATIVE_TCLSH) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \
$(GENERIC_DIR)/tcl.decls $(GENERIC_DIR)/tclInt.decls \
@@ -1897,6 +1909,10 @@ genstubs:
$(NATIVE_TCLSH) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \
$(GENERIC_DIR)/tclOO.decls
+genscript:
+ $(NATIVE_TCLSH) $(TOOL_DIR)/makeHeader.tcl \
+ $(GENERIC_DIR)/tclOOScript.tcl $(GENERIC_DIR)/tclOOScript.h
+
#
# Target to check that all exported functions have an entry in the stubs
# tables.
diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c
index 2d6560b..9ae5016 100644
--- a/unix/tclUnixTime.c
+++ b/unix/tclUnixTime.c
@@ -52,7 +52,7 @@ ClientData tclTimeClientData = NULL;
*----------------------------------------------------------------------
*/
-unsigned long
+Tcl_WideUInt
TclpGetSeconds(void)
{
return time(NULL);
@@ -77,30 +77,30 @@ TclpGetSeconds(void)
*----------------------------------------------------------------------
*/
-unsigned long
+Tcl_WideUInt
TclpGetClicks(void)
{
- unsigned long now;
+ Tcl_WideUInt now;
#ifdef NO_GETTOD
if (tclGetTimeProcPtr != NativeGetTime) {
Tcl_Time time;
tclGetTimeProcPtr(&time, tclTimeClientData);
- now = time.sec*1000000 + time.usec;
+ now = (Tcl_WideUInt)time.sec*1000000 + time.usec;
} else {
/*
* A semi-NativeGetTime, specialized to clicks.
*/
struct tms dummy;
- now = (unsigned long) times(&dummy);
+ now = (Tcl_WideUInt) times(&dummy);
}
#else
Tcl_Time time;
tclGetTimeProcPtr(&time, tclTimeClientData);
- now = time.sec*1000000 + time.usec;
+ now = (Tcl_WideUInt)time.sec*1000000 + time.usec;
#endif
return now;
@@ -113,9 +113,9 @@ TclpGetClicks(void)
* TclpGetWideClicks --
*
* This procedure returns a WideInt value that represents the highest
- * resolution clock available on the system. There are no garantees on
+ * resolution clock available on the system. There are no guarantees on
* what the resolution will be. In Tcl we will call this value a "click".
- * The start time is also system dependant.
+ * The start time is also system dependent.
*
* Results:
* Number of WideInt clicks from some start time.
diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c
index 28c8445..b34fc4f 100644
--- a/win/tclWinNotify.c
+++ b/win/tclWinNotify.c
@@ -36,7 +36,6 @@ typedef struct {
int pending; /* Alert message pending, this field is locked
* by the notifierMutex. */
HWND hwnd; /* Messaging window. */
- int timeout; /* Current timeout value. */
int timerActive; /* 1 if interval timer is running. */
} ThreadSpecificData;
@@ -309,11 +308,10 @@ Tcl_SetTimer(
timeout = 1;
}
}
- tsdPtr->timeout = timeout;
if (timeout != 0) {
tsdPtr->timerActive = 1;
SetTimer(tsdPtr->hwnd, INTERVAL_TIMER,
- (unsigned long) tsdPtr->timeout, NULL);
+ timeout, NULL);
} else {
tsdPtr->timerActive = 0;
KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c
index 8537ca5..0313708 100644
--- a/win/tclWinPipe.c
+++ b/win/tclWinPipe.c
@@ -61,7 +61,7 @@ typedef struct {
typedef struct ProcInfo {
HANDLE hProcess;
- DWORD dwProcessId;
+ size_t dwProcessId;
struct ProcInfo *nextPtr;
} ProcInfo;
@@ -859,7 +859,7 @@ TclpCloseFile(
*--------------------------------------------------------------------------
*/
-int
+size_t
TclpGetPid(
Tcl_Pid pid) /* The HANDLE of the child process. */
{
@@ -869,13 +869,13 @@ TclpGetPid(
Tcl_MutexLock(&pipeMutex);
for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
- if (infoPtr->dwProcessId == (DWORD) pid) {
+ if (infoPtr->dwProcessId == (size_t) pid) {
Tcl_MutexUnlock(&pipeMutex);
return infoPtr->dwProcessId;
}
}
Tcl_MutexUnlock(&pipeMutex);
- return (unsigned long) -1;
+ return (size_t)-1;
}
/*
@@ -1163,7 +1163,7 @@ TclpCreateProcess(
WaitForInputIdle(procInfo.hProcess, 5000);
CloseHandle(procInfo.hThread);
- *pidPtr = (Tcl_Pid) procInfo.dwProcessId;
+ *pidPtr = (Tcl_Pid) (size_t) procInfo.dwProcessId;
if (*pidPtr != 0) {
TclWinAddProcess(procInfo.hProcess, procInfo.dwProcessId);
}
@@ -1478,10 +1478,10 @@ QuoteCmdLinePart(
QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL);
start = *bspos;
}
- /*
- * escape all special chars enclosed in quotes like `"..."`, note that here we
+ /*
+ * escape all special chars enclosed in quotes like `"..."`, note that here we
* don't must escape `\` (with `\`), because it's outside of the main quotes,
- * so `\` remains `\`, but important - not at end of part, because results as
+ * so `\` remains `\`, but important - not at end of part, because results as
* before the quote, so `%\%\` should be escaped as `"%\%"\\`).
*/
TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */
@@ -1636,7 +1636,7 @@ BuildCommandLine(
special++;
}
/* rest of argument (and escape backslashes before closing main quote) */
- QuoteCmdLineBackslash(&ds, start, special,
+ QuoteCmdLineBackslash(&ds, start, special,
(quote & CL_QUOTE) ? bspos : NULL);
}
if (quote & CL_QUOTE) {
@@ -2476,7 +2476,7 @@ Tcl_WaitPid(
prevPtrPtr = &procList;
for (infoPtr = procList; infoPtr != NULL;
prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) {
- if (infoPtr->dwProcessId == (DWORD) pid) {
+ if (infoPtr->dwProcessId == (size_t) pid) {
*prevPtrPtr = infoPtr->nextPtr;
break;
}
@@ -2620,7 +2620,7 @@ Tcl_WaitPid(
void
TclWinAddProcess(
void *hProcess, /* Handle to process */
- unsigned long id) /* Global process identifier */
+ size_t id) /* Global process identifier */
{
ProcInfo *procPtr = Tcl_Alloc(sizeof(ProcInfo));
diff --git a/win/tclWinTime.c b/win/tclWinTime.c
index 598dade..a6557d9 100644
--- a/win/tclWinTime.c
+++ b/win/tclWinTime.c
@@ -127,7 +127,7 @@ ClientData tclTimeClientData = NULL;
*----------------------------------------------------------------------
*/
-unsigned long
+Tcl_WideUInt
TclpGetSeconds(void)
{
Tcl_Time t;
@@ -155,7 +155,7 @@ TclpGetSeconds(void)
*----------------------------------------------------------------------
*/
-unsigned long
+Tcl_WideUInt
TclpGetClicks(void)
{
/*
@@ -168,7 +168,7 @@ TclpGetClicks(void)
tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */
- retval = (now.sec * 1000000) + now.usec;
+ retval = ((Tcl_WideUInt) now.sec * 1000000) + now.usec;
return retval;
}