Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | Merge trunk. Also rename TCL_NO_LENGTH -> TCL_AUTO_LENGTH |
---|---|
Downloads: | Tarball | ZIP archive |
Timelines: | family | ancestors | descendants | both | memory-API |
Files: | files | file ages | folders |
SHA3-256: |
6488c06992a9909ee67b171120b660b2 |
User & Date: | jan.nijtmans 2018-09-05 14:54:26.542 |
Context
2018-09-07
| ||
22:09 | merge trunk check-in: 98b877b9ef user: jan.nijtmans tags: memory-API | |
2018-09-05
| ||
14:54 | Merge trunk. Also rename TCL_NO_LENGTH -> TCL_AUTO_LENGTH check-in: 6488c06992 user: jan.nijtmans tags: memory-API | |
13:45 | Merge 8.7. Change some internal function signatures, accounting for the 64-bit era. check-in: 4280c4f9d0 user: jan.nijtmans tags: trunk | |
2018-09-01
| ||
22:01 | Change ckalloc and friends to Tcl_Alloc and friends. Add two defines, TCL_IO_FAILURE and TCL_NO_LENG... check-in: f13660b5a5 user: jan.nijtmans tags: memory-API | |
Changes
Added doc/abstract.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | '\" '\" 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: |
Added doc/callback.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 | '\" '\" 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: |
Added doc/classvariable.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | '\" '\" 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: |
Changes to doc/define.n.
1 | '\" | | | 1 2 3 4 5 6 7 8 9 | '\" '\" 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. '\" .TH define n 0.3 TclOO "TclOO Commands" .so man.macros .BS |
︙ | ︙ | |||
34 35 36 37 38 39 40 41 42 43 44 45 46 47 | \fIarg\fR arguments; when the second is present, it is exactly as if all the arguments from \fIsubcommand\fR onwards are made into a list and that list is used as the \fIdefScript\fR argument. .SS "CONFIGURING CLASSES" .PP 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 \fBconstructor\fI argList bodyScript\fR . This creates or updates the constructor for a class. The formal arguments to the constructor (defined using the same format as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the constructor will be \fIbodyScript\fR. When the body of the constructor is evaluated, the current | > > > > > > > > > > > > > > > > > > > > > | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | \fIarg\fR arguments; when the second is present, it is exactly as if all the arguments from \fIsubcommand\fR onwards are made into a list and that list is used as the \fIdefScript\fR argument. .SS "CONFIGURING CLASSES" .PP 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 the constructor (defined using the same format as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the constructor will be \fIbodyScript\fR. When the body of the constructor is evaluated, the current |
︙ | ︙ | |||
105 106 107 108 109 110 111 112 113 114 115 116 117 118 | .RS .PP .VS TIP500 If in a private definition context (see the \fBprivate\fR definition command, below), this command creates private forwarded methods. .VE TIP500 .RE .TP \fBmethod\fI name argList bodyScript\fR . This creates or updates a method that is implemented as a procedure-like script. The name of the method is \fIname\fR, the formal arguments to the method (defined using the same format as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the method will be \fIbodyScript\fR. When | > > > > > > > > > | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 | .RS .PP .VS TIP500 If in a private definition context (see the \fBprivate\fR definition command, 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 script. The name of the method is \fIname\fR, the formal arguments to the method (defined using the same format as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the method will be \fIbodyScript\fR. When |
︙ | ︙ | |||
492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 | } \fBoo::objdefine\fR inst { \fBmixin -append\fR B } inst m1 \fI\(-> prints "red brick"\fR inst m2 \fI\(-> prints "blue brick"\fR .CE .SH "SEE ALSO" next(n), oo::class(n), oo::object(n) .SH KEYWORDS class, definition, method, object, slot .\" Local variables: .\" mode: nroff .\" fill-column: 78 .\" End: | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 | } \fBoo::objdefine\fR inst { \fBmixin -append\fR 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 class, definition, method, object, slot .\" Local variables: .\" mode: nroff .\" fill-column: 78 .\" End: |
Added doc/link.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 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: |
Changes to doc/my.n.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 2007 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 my n 0.1 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME | | > | > > > > > > | | > > > > > > > | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | '\" '\" Copyright (c) 2007 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 my n 0.1 TclOO "TclOO Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME 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), .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 .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 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 the \fBoo::object\fR class, which is not publicly visible by default: .PP .CS oo::class create c { |
︙ | ︙ | |||
50 51 52 53 54 55 56 | o count \fI\(-> prints "1"\fR o count \fI\(-> prints "2"\fR o count \fI\(-> prints "3"\fR .CE .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 | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 | o count \fI\(-> prints "1"\fR o count \fI\(-> prints "2"\fR o count \fI\(-> prints "3"\fR .CE .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. (See the \fBcallback\fR command for the recommended way of doing this.) .PP .CS oo::class create HasCallback { method makeCallback {} { return [namespace code { \fBmy\fR Callback }] } method Callback {args} { puts "callback: $args" } } 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 method, method visibility, object, private method, public method .\" Local variables: .\" mode: nroff .\" fill-column: 78 .\" End: |
Added doc/singleton.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 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: |
Changes to generic/tcl.h.
︙ | ︙ | |||
2176 2177 2178 2179 2180 2181 2182 | #define TCL_TCPSERVER_REUSEPORT (1<<1) /* * Constants for special size_t-typed values, see TIP #494 */ #define TCL_IO_FAILURE ((size_t)-1) | | | 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 | #define TCL_TCPSERVER_REUSEPORT (1<<1) /* * Constants for special size_t-typed values, see TIP #494 */ #define TCL_IO_FAILURE ((size_t)-1) #define TCL_AUTO_LENGTH ((size_t)-1) /* *---------------------------------------------------------------------------- * Single public declaration for NRE. */ typedef int (Tcl_NRPostProc) (void *data[], Tcl_Interp *interp, |
︙ | ︙ |
Changes to generic/tclBasic.c.
︙ | ︙ | |||
6950 6951 6952 6953 6954 6955 6956 | ExprIntFunc( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter vector. */ { | | < < < < < < < | < < < < < < | < | < < < < < < < < < < < < < < | 6950 6951 6952 6953 6954 6955 6956 6957 6958 6959 6960 6961 6962 6963 6964 6965 6966 6967 6968 6969 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 6983 6984 6985 6986 6987 6988 | ExprIntFunc( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ 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); TclGetWideBitsFromObj(NULL, objPtr, &wResult); Tcl_SetObjResult(interp, Tcl_NewLongObj((long)wResult)); return TCL_OK; } static int ExprWideFunc( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter vector. */ { Tcl_WideInt wResult; if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { return TCL_ERROR; } TclGetWideBitsFromObj(NULL, Tcl_GetObjResult(interp), &wResult); Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult)); return TCL_OK; } /* * Common implmentation of max() and min(). */ |
︙ | ︙ | |||
7105 7106 7107 7108 7109 7110 7111 | iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); /* * Make sure 1 <= randSeed <= (2^31) - 2. See below. */ | | | 7077 7078 7079 7080 7081 7082 7083 7084 7085 7086 7087 7088 7089 7090 7091 | iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); /* * Make sure 1 <= randSeed <= (2^31) - 2. See below. */ iPtr->randSeed &= 0x7fffffff; if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { iPtr->randSeed ^= 123459876; } } /* * Generate the random number using the linear congruential generator |
︙ | ︙ | |||
7249 7250 7251 7252 7253 7254 7255 | ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Parameter vector. */ { Interp *iPtr = (Interp *) interp; | | | < < < < < | < < < < < < < | < | 7221 7222 7223 7224 7225 7226 7227 7228 7229 7230 7231 7232 7233 7234 7235 7236 7237 7238 7239 7240 7241 7242 7243 7244 7245 7246 7247 7248 7249 7250 7251 7252 7253 7254 7255 7256 | ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Parameter vector. */ { Interp *iPtr = (Interp *) interp; Tcl_WideInt w = 0; /* Initialized to avoid compiler warning. */ /* * Convert argument and use it to reset the seed. */ if (objc != 2) { MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } if (TclGetWideBitsFromObj(NULL, objv[1], &w) != TCL_OK) { return TCL_ERROR; } /* * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. See comments in * ExprRandFunc for more details. */ iPtr->flags |= RAND_SEED_INITIALIZED; iPtr->randSeed = (long) w & 0x7fffffff; if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { iPtr->randSeed ^= 123459876; } /* * To avoid duplicating the random number generation code we simply clean * up our state and call the real random number function. That function |
︙ | ︙ |
Changes to generic/tclBinary.c.
︙ | ︙ | |||
1954 1955 1956 1957 1958 1959 1960 | FormatNumber( Tcl_Interp *interp, /* Current interpreter, used to report * errors. */ int type, /* Type of number to format. */ Tcl_Obj *src, /* Number to format. */ unsigned char **cursorPtr) /* Pointer to index into destination buffer. */ { | < | 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 | FormatNumber( Tcl_Interp *interp, /* Current interpreter, used to report * errors. */ int type, /* Type of number to format. */ Tcl_Obj *src, /* Number to format. */ unsigned char **cursorPtr) /* Pointer to index into destination buffer. */ { double dvalue; Tcl_WideInt wvalue; float fvalue; switch (type) { case 'd': case 'q': |
︙ | ︙ | |||
2016 2017 2018 2019 2020 2021 2022 | /* * 64-bit integer values. */ case 'w': case 'W': case 'm': | | | 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 | /* * 64-bit integer values. */ case 'w': case 'W': case 'm': if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { return TCL_ERROR; } if (NeedReversing(type)) { *(*cursorPtr)++ = UCHAR(wvalue); *(*cursorPtr)++ = UCHAR(wvalue >> 8); *(*cursorPtr)++ = UCHAR(wvalue >> 16); *(*cursorPtr)++ = UCHAR(wvalue >> 24); |
︙ | ︙ | |||
2046 2047 2048 2049 2050 2051 2052 | /* * 32-bit integer values. */ case 'i': case 'I': case 'n': | | | | | | | | | | | | | | | | | | 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 | /* * 32-bit integer values. */ case 'i': case 'I': case 'n': if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { return TCL_ERROR; } if (NeedReversing(type)) { *(*cursorPtr)++ = UCHAR(wvalue); *(*cursorPtr)++ = UCHAR(wvalue >> 8); *(*cursorPtr)++ = UCHAR(wvalue >> 16); *(*cursorPtr)++ = UCHAR(wvalue >> 24); } else { *(*cursorPtr)++ = UCHAR(wvalue >> 24); *(*cursorPtr)++ = UCHAR(wvalue >> 16); *(*cursorPtr)++ = UCHAR(wvalue >> 8); *(*cursorPtr)++ = UCHAR(wvalue); } return TCL_OK; /* * 16-bit integer values. */ case 's': case 'S': case 't': if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { return TCL_ERROR; } if (NeedReversing(type)) { *(*cursorPtr)++ = UCHAR(wvalue); *(*cursorPtr)++ = UCHAR(wvalue >> 8); } else { *(*cursorPtr)++ = UCHAR(wvalue >> 8); *(*cursorPtr)++ = UCHAR(wvalue); } return TCL_OK; /* * 8-bit integer values. */ case 'c': if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { return TCL_ERROR; } *(*cursorPtr)++ = UCHAR(wvalue); return TCL_OK; default: Tcl_Panic("unexpected fallthrough"); return TCL_ERROR; } } |
︙ | ︙ |
Changes to generic/tclCmdAH.c.
︙ | ︙ | |||
1257 1258 1259 1260 1261 1262 1263 | if (objc == 3) { /* * Need separate variable for reading longs from an object on 64-bit * platforms. [Bug 698146] */ | | | | 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 | if (objc == 3) { /* * Need separate variable for reading longs from an object on 64-bit * platforms. [Bug 698146] */ Tcl_WideInt newTime; if (TclGetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) { return TCL_ERROR; } tval.actime = newTime; tval.modtime = buf.st_mtime; if (Tcl_FSUtime(objv[1], &tval) != 0) { |
︙ | ︙ | |||
1338 1339 1340 1341 1342 1343 1344 | #endif if (objc == 3) { /* * Need separate variable for reading longs from an object on 64-bit * platforms. [Bug 698146] */ | | | | 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 | #endif if (objc == 3) { /* * Need separate variable for reading longs from an object on 64-bit * platforms. [Bug 698146] */ Tcl_WideInt newTime; if (TclGetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) { return TCL_ERROR; } tval.actime = buf.st_atime; tval.modtime = newTime; if (Tcl_FSUtime(objv[1], &tval) != 0) { |
︙ | ︙ |
Changes to generic/tclInt.decls.
︙ | ︙ | |||
305 306 307 308 309 310 311 | #declare 73 { # int TclpDeleteFile(const char *path) #} declare 74 { void TclpFree(void *ptr) } declare 75 { | | | | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 | #declare 73 { # int TclpDeleteFile(const char *path) #} declare 74 { void TclpFree(void *ptr) } declare 75 { Tcl_WideUInt TclpGetClicks(void) } declare 76 { Tcl_WideUInt TclpGetSeconds(void) } # Removed in 9.0: #declare 77 { # void TclpGetTime(Tcl_Time *time) #} # Removed in 8.6: |
︙ | ︙ | |||
1098 1099 1100 1101 1102 1103 1104 | #} # Removed in 9.0: #declare 7 win { # int TclWinSetSockOpt(SOCKET s, int level, int optname, # const char *optval, int optlen) #} declare 8 win { | | | 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 | #} # Removed in 9.0: #declare 7 win { # int TclWinSetSockOpt(SOCKET s, int level, int optname, # const char *optval, int optlen) #} declare 8 win { size_t TclpGetPid(Tcl_Pid pid) } # Removed in 9.0: #declare 9 win { # int TclWinGetPlatformId(void) #} # Removed in 9.0: #declare 10 win { |
︙ | ︙ | |||
1156 1157 1158 1159 1160 1161 1162 | declare 18 win { TclFile TclpMakeFile(Tcl_Channel channel, int direction) } declare 19 win { TclFile TclpOpenFile(const char *fname, int mode) } declare 20 win { | | | 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 | declare 18 win { TclFile TclpMakeFile(Tcl_Channel channel, int direction) } declare 19 win { TclFile TclpOpenFile(const char *fname, int mode) } declare 20 win { void TclWinAddProcess(HANDLE hProcess, size_t id) } # Removed in 9.0: #declare 21 win { # char *TclpInetNtoa(struct in_addr addr) #} # removed permanently for 8.4 #declare 21 win { |
︙ | ︙ |
Changes to generic/tclInt.h.
︙ | ︙ | |||
2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 | MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, unsigned int *sizePtr); MODULE_SCOPE int TclGetLoadedPackagesEx(Tcl_Interp *interp, const char *targetName, const char *packageName); MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, Tcl_GlobTypeData *types); MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr); MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); | > > | 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 | MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, unsigned int *sizePtr); 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); MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr); MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); |
︙ | ︙ |
Changes to generic/tclIntDecls.h.
︙ | ︙ | |||
191 192 193 194 195 196 197 | /* Slot 70 is reserved */ /* Slot 71 is reserved */ /* Slot 72 is reserved */ /* Slot 73 is reserved */ /* 74 */ EXTERN void TclpFree(void *ptr); /* 75 */ | | | | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 | /* Slot 70 is reserved */ /* Slot 71 is reserved */ /* Slot 72 is reserved */ /* Slot 73 is reserved */ /* 74 */ EXTERN void TclpFree(void *ptr); /* 75 */ EXTERN Tcl_WideUInt TclpGetClicks(void); /* 76 */ EXTERN Tcl_WideUInt TclpGetSeconds(void); /* Slot 77 is reserved */ /* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ /* 81 */ EXTERN void * TclpRealloc(void *ptr, size_t size); /* Slot 82 is reserved */ |
︙ | ︙ | |||
654 655 656 657 658 659 660 | void (*reserved68)(void); void * (*tclpAlloc) (size_t size); /* 69 */ void (*reserved70)(void); void (*reserved71)(void); void (*reserved72)(void); void (*reserved73)(void); void (*tclpFree) (void *ptr); /* 74 */ | | | | 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 | void (*reserved68)(void); void * (*tclpAlloc) (size_t size); /* 69 */ void (*reserved70)(void); void (*reserved71)(void); void (*reserved72)(void); void (*reserved73)(void); void (*tclpFree) (void *ptr); /* 74 */ Tcl_WideUInt (*tclpGetClicks) (void); /* 75 */ Tcl_WideUInt (*tclpGetSeconds) (void); /* 76 */ void (*reserved77)(void); void (*reserved78)(void); void (*reserved79)(void); void (*reserved80)(void); void * (*tclpRealloc) (void *ptr, size_t size); /* 81 */ void (*reserved82)(void); void (*reserved83)(void); |
︙ | ︙ |
Changes to generic/tclIntPlatDecls.h.
︙ | ︙ | |||
104 105 106 107 108 109 110 | /* 4 */ EXTERN HINSTANCE TclWinGetTclInstance(void); /* 5 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* Slot 6 is reserved */ /* Slot 7 is reserved */ /* 8 */ | | | 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 | /* 4 */ EXTERN HINSTANCE TclWinGetTclInstance(void); /* 5 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* Slot 6 is reserved */ /* Slot 7 is reserved */ /* 8 */ EXTERN size_t TclpGetPid(Tcl_Pid pid); /* Slot 9 is reserved */ /* Slot 10 is reserved */ /* 11 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); /* 12 */ EXTERN int TclpCloseFile(TclFile file); |
︙ | ︙ | |||
134 135 136 137 138 139 140 | const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 18 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 19 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 20 */ | | | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 | const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 18 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 19 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 20 */ EXTERN void TclWinAddProcess(HANDLE hProcess, size_t id); /* Slot 21 is reserved */ /* 22 */ EXTERN TclFile TclpCreateTempFile(const char *contents); /* Slot 23 is reserved */ /* 24 */ EXTERN char * TclWinNoBackslash(char *path); /* Slot 25 is reserved */ |
︙ | ︙ | |||
270 271 272 273 274 275 276 | void (*reserved1)(void); void (*reserved2)(void); void (*reserved3)(void); HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ void (*reserved6)(void); void (*reserved7)(void); | | | | 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 | void (*reserved1)(void); void (*reserved2)(void); void (*reserved3)(void); HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ void (*reserved6)(void); void (*reserved7)(void); size_t (*tclpGetPid) (Tcl_Pid pid); /* 8 */ void (*reserved9)(void); void (*reserved10)(void); void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ int (*tclpCloseFile) (TclFile file); /* 12 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 14 */ int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ int (*tclpIsAtty) (int fd); /* 16 */ 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, size_t id); /* 20 */ void (*reserved21)(void); TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ void (*reserved23)(void); char * (*tclWinNoBackslash) (char *path); /* 24 */ void (*reserved25)(void); void (*reserved26)(void); void (*tclWinFlushDirtyChannels) (void); /* 27 */ |
︙ | ︙ | |||
499 500 501 502 503 504 505 | #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #define TclWinConvertWSAError TclWinConvertError #if !defined(_WIN32) # undef TclpGetPid | | | 499 500 501 502 503 504 505 506 507 508 509 | #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #define TclWinConvertWSAError TclWinConvertError #if !defined(_WIN32) # undef TclpGetPid # define TclpGetPid(pid) ((size_t) (pid)) #endif #endif /* _TCLINTPLATDECLS */ |
Changes to generic/tclOO.c.
︙ | ︙ | |||
98 99 100 101 102 103 104 105 106 107 108 109 110 111 | Tcl_Obj *const *objv); static int PrivateObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int PrivateNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); /* * Methods in the oo::object and oo::class classes. First, we define a helper * macro that makes building the method type declaration structure a lot * easier. No point in making life harder than it has to be! * * Note that the core methods don't need clone or free proc callbacks. | > > > > > > > | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 | Tcl_Obj *const *objv); static int PrivateObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); 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 * macro that makes building the method type declaration structure a lot * easier. No point in making life harder than it has to be! * * Note that the core methods don't need clone or free proc callbacks. |
︙ | ︙ | |||
148 149 150 151 152 153 154 | "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};" "namespace eval ::oo { variable version " TCLOO_VERSION " };" "namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };"; /* "tcl_findLibrary tcloo $oo::version $oo::version" */ /* " tcloo.tcl OO_LIBRARY oo::library;"; */ /* | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < | 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 | "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};" "namespace eval ::oo { variable version " TCLOO_VERSION " };" "namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };"; /* "tcl_findLibrary tcloo $oo::version $oo::version" */ /* " tcloo.tcl OO_LIBRARY oo::library;"; */ /* * The scripted part of the definitions of TclOO. */ #include "tclOOScript.h" /* * The actual definition of the variable holding the TclOO stub table. */ MODULE_SCOPE const TclOOStubs tclOOStubs; |
︙ | ︙ | |||
356 357 358 359 360 361 362 | InitFoundation( Tcl_Interp *interp) { static Tcl_ThreadDataKey tsdKey; ThreadLocalData *tsdPtr = Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData)); Foundation *fPtr = Tcl_Alloc(sizeof(Foundation)); | | | 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 | InitFoundation( Tcl_Interp *interp) { static Tcl_ThreadDataKey tsdKey; ThreadLocalData *tsdPtr = Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData)); Foundation *fPtr = Tcl_Alloc(sizeof(Foundation)); Tcl_Obj *namePtr; Tcl_DString buffer; Command *cmdPtr; int i; /* * Initialize the structure that holds the OO system core. This is * attached to the interpreter via an assocData entry; not very efficient, |
︙ | ︙ | |||
435 436 437 438 439 440 441 | for (i=0 ; objMethods[i].name ; i++) { TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]); } for (i=0 ; clsMethods[i].name ; i++) { TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]); } | < < < < < < < < < < < < | 387 388 389 390 391 392 393 394 395 396 397 398 399 400 | for (i=0 ; objMethods[i].name ; i++) { TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]); } for (i=0 ; clsMethods[i].name ; i++) { TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]); } /* * 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. */ TclNewLiteralStringObj(namePtr, "new"); |
︙ | ︙ | |||
487 488 489 490 491 492 493 | /* * Now make the class of slots. */ if (TclOODefineSlots(fPtr) != TCL_OK) { return TCL_ERROR; } | > > > > > | | 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 | /* * Now make the class of slots. */ if (TclOODefineSlots(fPtr) != TCL_OK) { return TCL_ERROR; } /* * Evaluate the remaining definitions, which are a compiled-in Tcl script. */ return Tcl_EvalEx(interp, tclOOSetupScript, -1, 0); } /* * ---------------------------------------------------------------------- * * InitClassSystemRoots -- * |
︙ | ︙ | |||
793 794 795 796 797 798 799 800 801 802 803 804 805 806 | tracePtr->clientData = oPtr; tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE; tracePtr->nextPtr = NULL; tracePtr->refCount = 1; oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr, PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); return oPtr; } /* * ---------------------------------------------------------------------- * * SquelchCachedName -- | > > > | 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 | tracePtr->clientData = oPtr; tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE; tracePtr->nextPtr = NULL; tracePtr->refCount = 1; oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr, PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass", oPtr->namespacePtr, MyClassObjCmd, MyClassNRObjCmd, oPtr, MyClassDeleted); return oPtr; } /* * ---------------------------------------------------------------------- * * SquelchCachedName -- |
︙ | ︙ | |||
820 821 822 823 824 825 826 | oPtr->cachedNameObj = NULL; } } /* * ---------------------------------------------------------------------- * | | | | > | < > > > > > > > > | 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 | oPtr->cachedNameObj = NULL; } } /* * ---------------------------------------------------------------------- * * MyDeleted, MyClassDeleted -- * * 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. * * ---------------------------------------------------------------------- */ static void MyDeleted( ClientData clientData) /* Reference to the object whose [my] has been * squelched. */ { register Object *oPtr = clientData; oPtr->myCommand = NULL; } static void MyClassDeleted( ClientData clientData) { Object *oPtr = clientData; oPtr->myclassCommand = NULL; } /* * ---------------------------------------------------------------------- * * ObjectRenamedTrace -- * * This callback is triggered when the object is deleted by any |
︙ | ︙ | |||
1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 | * The namespace must have been deleted directly. Delete the command * as well. */ Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); } if (oPtr->myCommand) { Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand); } /* * Splice the object out of its context. After this, we must *not* call * methods on the object. | > > > | 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 | * The namespace must have been deleted directly. Delete the command * as well. */ 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); } /* * Splice the object out of its context. After this, we must *not* call * methods on the object. |
︙ | ︙ | |||
2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 | return TclOOObjectCmdCore((Object *) object, interp, objc, objv, PRIVATE_METHOD, (Class *) startCls); default: return TclOOObjectCmdCore((Object *) object, interp, objc, objv, 0, (Class *) startCls); } } /* * ---------------------------------------------------------------------- * * TclOOObjectCmdCore, FinalizeObjectCall -- * * Main function for object invocations. Does call chain creation, | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 | return TclOOObjectCmdCore((Object *) object, interp, objc, objv, PRIVATE_METHOD, (Class *) startCls); default: return TclOOObjectCmdCore((Object *) object, interp, objc, objv, 0, (Class *) startCls); } } /* * ---------------------------------------------------------------------- * * 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, |
︙ | ︙ |
Changes to generic/tclOOBasic.c.
︙ | ︙ | |||
79 80 81 82 83 84 85 | ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); | | > > > > > > > > > > > | > > > > > > > > > > > > > | > > | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 | ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); Tcl_Obj **invoke, *nameObj; if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "?definitionScript?"); return TCL_ERROR; } else if (objc == Tcl_ObjectContextSkippedArgs(context)) { return TCL_OK; } /* * 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. */ invoke = Tcl_Alloc(3 * sizeof(Tcl_Obj *)); invoke[0] = oPtr->fPtr->defineName; invoke[1] = TclOOObjectName(interp, oPtr); invoke[2] = objv[objc-1]; /* * Must add references or errors in configuration script will cause * trouble. */ Tcl_IncrRefCount(invoke[0]); Tcl_IncrRefCount(invoke[1]); Tcl_IncrRefCount(invoke[2]); TclNRAddCallback(interp, DecrRefsPostClassConstructor, invoke, oPtr, NULL, NULL); /* * Tricky point: do not want the extra reported level in the Tcl stack * trace, so use TCL_EVAL_NOERR. */ return TclNREvalObjv(interp, 3, invoke, TCL_EVAL_NOERR, NULL); } static int DecrRefsPostClassConstructor( ClientData data[], Tcl_Interp *interp, 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); if (code != TCL_OK) { Tcl_DiscardInterpState(saved); return code; } return Tcl_RestoreInterpState(interp, saved); } /* * ---------------------------------------------------------------------- * * TclOO_Class_Create -- * |
︙ | ︙ |
Changes to generic/tclOOInt.h.
︙ | ︙ | |||
205 206 207 208 209 210 211 212 213 214 215 216 217 218 | Tcl_ObjectMapMethodNameProc *mapMethodNameProc; /* Function to allow remapping of method * names. For itcl-ng. */ VariableNameList variables; PrivateVariableList privateVariables; /* Configurations for the variable resolver * used inside methods. */ } Object; #define OBJECT_DELETED 1 /* Flag to say that an object has been * destroyed. */ #define DESTRUCTOR_CALLED 2 /* Flag to say that the destructor has been * called. */ #define CLASS_GONE 4 /* Obsolete. Indicates that the class of this | > > | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 | Tcl_ObjectMapMethodNameProc *mapMethodNameProc; /* Function to allow remapping of method * names. For itcl-ng. */ VariableNameList variables; 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 * destroyed. */ #define DESTRUCTOR_CALLED 2 /* Flag to say that the destructor has been * called. */ #define CLASS_GONE 4 /* Obsolete. Indicates that the class of this |
︙ | ︙ |
Added generic/tclOOScript.h.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 | /* * 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: */ |
Added generic/tclOOScript.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 | # 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: |
Changes to generic/tclObj.c.
︙ | ︙ | |||
2393 2394 2395 2396 2397 2398 2399 | * long range get auto-narrowed to tclIntType, while all the * values in the unsigned long range will fit in a long. */ mp_int big; UNPACK_BIGNUM(objPtr, big); | | | < | 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 | * long range get auto-narrowed to tclIntType, while all the * values in the unsigned long range will fit in a long. */ mp_int big; UNPACK_BIGNUM(objPtr, big); if ((size_t) big.used <= (CHAR_BIT * sizeof(unsigned long) + DIGIT_BIT - 1) / DIGIT_BIT) { 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) { while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; } if (big.sign) { |
︙ | ︙ | |||
2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 | const char *s = "integer value too large to represent"; Tcl_Obj *msg = Tcl_NewStringObj(s, -1); Tcl_SetObjResult(interp, msg); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); } return TCL_ERROR; } } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } /* | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 | const char *s = "integer value too large to represent"; Tcl_Obj *msg = Tcl_NewStringObj(s, -1); Tcl_SetObjResult(interp, msg); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); } return TCL_ERROR; } } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * 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; } /* |
︙ | ︙ |
Changes to generic/tclProcess.c.
︙ | ︙ | |||
43 44 45 46 47 48 49 | * Prototypes for functions defined later in this file: */ static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid, int resolvedPid); static void FreeProcessInfo(ProcessInfo *info); static int RefreshProcessInfo(ProcessInfo *info, int options); | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | * Prototypes for functions defined later in this file: */ 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, size_t resolvedPid, int options, int *codePtr, Tcl_Obj **msgPtr, Tcl_Obj **errorObjPtr); static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info); static int ProcessListObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int ProcessStatusObjCmd(ClientData clientData, |
︙ | ︙ | |||
189 190 191 192 193 194 195 | * *---------------------------------------------------------------------- */ TclProcessWaitStatus WaitProcessStatus( Tcl_Pid pid, /* Process id. */ | | | 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 | * *---------------------------------------------------------------------- */ TclProcessWaitStatus WaitProcessStatus( Tcl_Pid pid, /* 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. * - errno in case of error. * - non-zero exit code for abormal exit. * - signal number if killed or suspended. * - Tcl_WaitPid status in all other cases. |
︙ | ︙ | |||
795 796 797 798 799 800 801 | *---------------------------------------------------------------------- */ void TclProcessCreated( Tcl_Pid pid) /* Process id. */ { | | | 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 | *---------------------------------------------------------------------- */ void TclProcessCreated( Tcl_Pid pid) /* Process id. */ { size_t resolvedPid; Tcl_HashEntry *entry, *entry2; int isNew; ProcessInfo *info; /* * Get resolved pid first. */ |
︙ | ︙ |
Changes to generic/tclStringObj.c.
︙ | ︙ | |||
2016 2017 2018 2019 2020 2021 2022 | goto errorMsg; } else { ch = 'd'; } } #ifndef TCL_WIDE_INT_IS_LONG } else if (useWide) { | | < < < | < < < < < < | < < < | < < < < < < | 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 | goto errorMsg; } else { ch = 'd'; } } #ifndef TCL_WIDE_INT_IS_LONG } else if (useWide) { 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 (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) { goto error; } else { l = Tcl_WideAsLong(w); } if (useShort) { s = (short) l; isNegative = (s < (short) 0); if (s == (short) 0) gotHash = 0; |
︙ | ︙ |
Changes to generic/tclStubInit.c.
︙ | ︙ | |||
64 65 66 67 68 69 70 | #elif defined(__CYGWIN__) # define TclpIsAtty TclPlatIsAtty static void doNothing(void) { /* dummy implementation, no need to do anything */ } | | | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | #elif defined(__CYGWIN__) # define TclpIsAtty TclPlatIsAtty static void doNothing(void) { /* dummy implementation, no need to do anything */ } # define TclWinAddProcess (void (*) (void *, size_t)) doNothing # define TclWinFlushDirtyChannels doNothing static int TclpIsAtty(int fd) { return isatty(fd); } |
︙ | ︙ | |||
94 95 96 97 98 99 100 | if (*p == '\\') { *p = '/'; } } return path; } | | | | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | if (*p == '\\') { *p = '/'; } } return path; } size_t TclpGetPid(Tcl_Pid pid) { return (size_t) pid; } char * Tcl_WinUtfToTChar( const char *string, size_t len, Tcl_DString *dsPtr) |
︙ | ︙ |
Changes to generic/tclTest.c.
︙ | ︙ | |||
288 289 290 291 292 293 294 295 296 297 298 299 300 301 | static int TestfilelinkCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestfeventCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); 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 TestgetplatformCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestgetvarfullnameCmd( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestinterpdeleteCmd(ClientData dummy, | > > | 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 | static int TestfilelinkCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestfeventCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); 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( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestinterpdeleteCmd(ClientData dummy, |
︙ | ︙ | |||
640 641 642 643 644 645 646 647 648 649 650 651 652 653 | Tcl_CreateObjCommand(interp, "testfile", TestfileCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testhashsystemhash", TestHashSystemHashCmd, NULL, NULL); Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd, NULL, NULL); Tcl_CreateCommand(interp, "testgetint", TestgetintCmd, NULL, NULL); Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testgetvarfullname", TestgetvarfullnameCmd, NULL, NULL); Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd, NULL, NULL); | > > | 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 | Tcl_CreateObjCommand(interp, "testfile", TestfileCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testhashsystemhash", TestHashSystemHashCmd, NULL, NULL); Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd, 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", TestgetvarfullnameCmd, NULL, NULL); Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd, NULL, NULL); |
︙ | ︙ | |||
6928 6929 6930 6931 6932 6933 6934 6935 6936 6937 6938 6939 6940 6941 | } total += val; } Tcl_SetObjResult(interp, Tcl_NewIntObj(total)); return TCL_OK; } } static int NREUnwind_callback( ClientData data[], Tcl_Interp *interp, int result) { | > > > > > > > > > > > > > > > > > > | 6932 6933 6934 6935 6936 6937 6938 6939 6940 6941 6942 6943 6944 6945 6946 6947 6948 6949 6950 6951 6952 6953 6954 6955 6956 6957 6958 6959 6960 6961 6962 6963 | } total += val; } Tcl_SetObjResult(interp, Tcl_NewIntObj(total)); return TCL_OK; } } /* * 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[], Tcl_Interp *interp, int result) { |
︙ | ︙ |
Changes to tests/binary.test.
︙ | ︙ | |||
1643 1644 1645 1646 1647 1648 1649 | test binary-43.1 {Tcl_BinaryObjCmd: format wide int} {} { binary format w 7810179016327718216 } HelloTcl test binary-43.2 {Tcl_BinaryObjCmd: format wide int} {} { binary format W 7810179016327718216 } lcTolleH | < < < < < < < < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > | 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 | test binary-43.1 {Tcl_BinaryObjCmd: format wide int} {} { binary format w 7810179016327718216 } HelloTcl test binary-43.2 {Tcl_BinaryObjCmd: format wide int} {} { binary format W 7810179016327718216 } lcTolleH test binary-43.5 {Tcl_BinaryObjCmd: scan wide int} {} { unset -nocomplain arg1 list [binary scan \x80[string repeat \x00 7] W arg1] $arg1 } {1 -9223372036854775808} test binary-43.6 {Tcl_BinaryObjCmd: scan unsigned wide int} {} { unset -nocomplain arg1 list [binary scan \x80[string repeat \x00 7] Wu arg1] $arg1 } {1 9223372036854775808} test binary-43.7 {Tcl_BinaryObjCmd: scan unsigned wide int} {} { unset -nocomplain arg1 list [binary scan [string repeat \x00 7]\x80 wu arg1] $arg1 } {1 9223372036854775808} test binary-43.8 {Tcl_BinaryObjCmd: scan unsigned wide int} {} { unset -nocomplain arg1 arg2 list [binary scan \x80[string repeat \x00 7]\x80[string repeat \x00 7] WuW arg1 arg2] $arg1 $arg2 } {2 9223372036854775808 -9223372036854775808} test binary-43.9 {Tcl_BinaryObjCmd: scan unsigned wide int} {} { unset -nocomplain arg1 arg2 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 } {66 64 -1 -1 -1 -1 -1 -1 -1 -1 65 76} test binary-45.2 {Tcl_BinaryObjCmd: combined wide int handling} { binary scan [binary format sWs 16450 0x7fffffff 19521] c* x |
︙ | ︙ |
Changes to tests/compExpr-old.test.
︙ | ︙ | |||
74 75 76 77 78 79 80 | default { return 0 } } } testConstraint ieeeFloatingPoint [testIEEE] | | | | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 | default { return 0 } } } testConstraint ieeeFloatingPoint [testIEEE] testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] # procedures used below proc put_hello_char {c} { global a append a [format %c $c] return $c |
︙ | ︙ |
Changes to tests/execute.test.
︙ | ︙ | |||
30 31 32 33 34 35 36 | testConstraint testobj [expr { [llength [info commands testobj]] && [llength [info commands testdoubleobj]] && [llength [info commands teststringobj]] }] | | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | testConstraint testobj [expr { [llength [info commands testobj]] && [llength [info commands testdoubleobj]] && [llength [info commands teststringobj]] }] testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] testConstraint testexprlongobj [llength [info commands testexprlongobj]] # Tests for the omnibus TclExecuteByteCode function: # INST_DONE not tested # INST_PUSH1 not tested # INST_PUSH4 not tested |
︙ | ︙ |
Changes to tests/expr-old.test.
︙ | ︙ | |||
18 19 20 21 22 23 24 | ::tcltest::loadTestedCommands 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]] | | > | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | ::tcltest::loadTestedCommands 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 {$tcl_platform(wordSize) == 4}] testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] # Big test for correct ordering of data in [expr] proc testIEEE {} { variable ieeeValues binary scan [binary format dd -1.0 1.0] c* c switch -exact -- $c { |
︙ | ︙ |
Changes to tests/expr.test.
︙ | ︙ | |||
17 18 19 20 21 22 23 | ::tcltest::loadTestedCommands 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. | | | | < | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | ::tcltest::loadTestedCommands 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 {$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] proc testIEEE {} { variable ieeeValues binary scan [binary format dd -1.0 1.0] c* c switch -exact -- $c { |
︙ | ︙ |
Changes to tests/format.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } # %u output depends on word length, so this test is not portable. | | | | < < | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } # %u output depends on word length, so this test is not portable. 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} { format "%*d %d %d %d" 6 34 16923 -12 -1 } { 34 16923 -12 -1} test format-1.2 {integer formatting} { format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12 |
︙ | ︙ | |||
543 544 545 546 547 548 549 | for {set i 290} {$i < 400} {incr i} { test format-16.[expr $i -289] {testing MAX_FLOAT_SIZE} { format {%s} $b } $b append b "x" } | | | 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 | for {set i 290} {$i < 400} {incr i} { test format-16.[expr $i -289] {testing MAX_FLOAT_SIZE} { format {%s} $b } $b append b "x" } test format-17.1 {testing %d with wide} {longIs32bit wideIs64bit} { format %d 7810179016327718216 } 1819043144 test format-17.2 {testing %ld with wide} {wideIs64bit} { format %ld 7810179016327718216 } 7810179016327718216 test format-17.3 {testing %ld with non-wide} {wideIs64bit} { format %ld 42 |
︙ | ︙ | |||
576 577 578 579 580 581 582 | lappend result [expr {$a == $b}] set b 0xaaaa append b aaaa lappend result [expr {$a == $b}] format %08x $b lappend result [expr {$a == $b}] } {1 1 1 1} | | | 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 | lappend result [expr {$a == $b}] set b 0xaaaa append b aaaa lappend result [expr {$a == $b}] format %08x $b lappend result [expr {$a == $b}] } {1 1 1 1} 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}] } {aaaaaaab 1} test format-19.1 {regression test - tcl-core message by Brian Griffin on 26 0ctober 2004} -body { set x 0x8fedc654 |
︙ | ︙ |
Changes to tests/get.test.
︙ | ︙ | |||
16 17 18 19 20 21 22 | } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testgetint [llength [info commands testgetint]] testConstraint testdoubleobj [llength [info commands testdoubleobj]] | | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testgetint [llength [info commands testgetint]] testConstraint testdoubleobj [llength [info commands testdoubleobj]] 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} } {66} test get-1.2 {Tcl_GetInt procedure} testgetint { testgetint 44 -3 } {41} |
︙ | ︙ |
Changes to tests/obj.test.
︙ | ︙ | |||
16 17 18 19 20 21 22 | namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testobj [llength [info commands testobj]] | | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testobj [llength [info commands testobj]] 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 foreach {t} { bytearray bytecode cmdName |
︙ | ︙ | |||
545 546 547 548 549 550 551 | set x {} for {set i 0} {$i<100000} {incr i} { set x [list $x {}] } unset x } {} | | | | | | | 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 | set x {} for {set i 0} {$i<100000} {incr i} { set x [list $x {}] } unset x } {} 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 wideIs64bit} { set x 0xffff; append x ffff list [string is integer $x] [expr { wide($x) }] } {1 4294967295} 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 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 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 wideIs64bit} { set x -0xffff; append x ffff list [string is integer $x] [expr { wide($x) }] } {1 -4294967295} test obj-33.7 {integer overflow on input} { set x -0x10000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {0 -4294967296} |
︙ | ︙ |
Changes to tests/oo.test.
︙ | ︙ | |||
336 337 338 339 340 341 342 | lappend x [info class $cmd ::oo::$initial] } } foreach initial {object class Slot} { lappend x [info object class ::oo::$initial] } return $x | | | | 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 | lappend x [info class $cmd ::oo::$initial] } } foreach initial {object class Slot} { lappend x [info object class ::oo::$initial] } return $x }] {lsort [lmap y $x {if {[string match *::delegate $y]} continue; set y}]} } -cleanup { interp delete $fresh } -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 # we're modifying the root object class's constructor interp create subinterp subinterp eval { package require TclOO |
︙ | ︙ | |||
4841 4842 4843 4844 4845 4846 4847 | unexport foo } lappend result {*}[lmap s {public unexported private} { info class methods cls -scope $s}] } -cleanup { cls destroy } -result {{} {} foo {} foo {}} | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 | unexport foo } lappend result {*}[lmap s {public unexported private} { info class methods cls -scope $s}] } -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 # Local Variables: # mode: tcl # End: |
Added tests/ooUtil.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 | # 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: |
Changes to tests/platform.test.
︙ | ︙ | |||
21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | #variable ::tcl_platform namespace upvar :: tcl_platform tcl_platform ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] testConstraint testCPUID [llength [info commands testcpuid]] test platform-1.0 {tcl_platform(engine)} { set tcl_platform(engine) } {Tcl} test platform-1.1 {TclpSetVariables: tcl_platform} { interp create i i eval {catch {unset tcl_platform(debug)}} i eval {catch {unset tcl_platform(threaded)}} set result [i eval {lsort [array names tcl_platform]}] interp delete i set result } {byteOrder engine machine os osVersion pathSeparator platform pointerSize user wordSize} | > < < < < | | < < < | | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | #variable ::tcl_platform namespace upvar :: tcl_platform tcl_platform ::tcltest::loadTestedCommands 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) } {Tcl} test platform-1.1 {TclpSetVariables: tcl_platform} { interp create i i eval {catch {unset tcl_platform(debug)}} i eval {catch {unset tcl_platform(threaded)}} set result [i eval {lsort [array names tcl_platform]}] interp delete i set result } {byteOrder engine machine os osVersion pathSeparator platform pointerSize user wordSize} 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 test platform-3.1 {CPU ID on Windows/UNIX} \ -constraints testCPUID \ -body { set cpudata [testcpuid 0] |
︙ | ︙ |
Changes to tests/scan.test.
︙ | ︙ | |||
81 82 83 84 85 86 87 | default { return 0 } } } testConstraint ieeeFloatingPoint [testIEEE] | | < | 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 | default { return 0 } } } testConstraint ieeeFloatingPoint [testIEEE] testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] test scan-1.1 {BuildCharSet, CharInSet} { list [scan foo {%[^o]} x] $x } {1 f} test scan-1.2 {BuildCharSet, CharInSet} { list [scan \]foo {%[]f]} x] $x } {1 \]f} |
︙ | ︙ |
Added tools/makeHeader.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 | # 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: |
Changes to unix/Makefile.in.
︙ | ︙ | |||
255 256 257 258 259 260 261 262 263 264 265 266 267 268 | #-------------------------------------------------------------------------- # The information below is usually usable as is. The configure script won't # modify it and it only exists to make working around selected rare system # configurations easier. #-------------------------------------------------------------------------- GDB = gdb TRACE = strace TRACE_OPTS = VALGRIND = valgrind VALGRINDARGS = --tool=memcheck --num-callers=24 \ --leak-resolution=high --leak-check=yes --show-reachable=yes -v \ --suppressions=$(TOOL_DIR)/valgrind_suppress | > | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 | #-------------------------------------------------------------------------- # The information below is usually usable as is. The configure script won't # modify it and it only exists to make working around selected rare system # configurations easier. #-------------------------------------------------------------------------- GDB = gdb LLDB = lldb TRACE = strace TRACE_OPTS = VALGRIND = valgrind VALGRINDARGS = --tool=memcheck --num-callers=24 \ --leak-resolution=high --leak-check=yes --show-reachable=yes -v \ --suppressions=$(TOOL_DIR)/valgrind_suppress |
︙ | ︙ | |||
727 728 729 730 731 732 733 734 735 736 737 738 739 740 | gdb-test: ${TCLTEST_EXE} @echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > gdb.run @echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run @echo "set args $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) -singleproc 1" >> gdb.run $(GDB) ./${TCLTEST_EXE} --command=gdb.run rm gdb.run # Useful target to launch a built tcltest with the proper path,... runtest: ${TCLTEST_EXE} $(SHELL_ENV) ./${TCLTEST_EXE} # Useful target for running the test suite with an unwritable current # directory... | > > > > > > | 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 | gdb-test: ${TCLTEST_EXE} @echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > gdb.run @echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run @echo "set args $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) -singleproc 1" >> gdb.run $(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} # Useful target for running the test suite with an unwritable current # directory... |
︙ | ︙ | |||
1218 1219 1220 1221 1222 1223 1224 | tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNamesp.c tclNotify.o: $(GENERIC_DIR)/tclNotify.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNotify.c | | | 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 | tclNamesp.o: $(GENERIC_DIR)/tclNamesp.c $(COMPILEHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNamesp.c tclNotify.o: $(GENERIC_DIR)/tclNotify.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclNotify.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 $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOBasic.c tclOOCall.o: $(GENERIC_DIR)/tclOOCall.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOCall.c |
︙ | ︙ | |||
1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 | @echo "This warning can be safely ignored, do not report as a bug!" $(GENERIC_DIR)/tclOOStubInit.c: $(GENERIC_DIR)/tclOO.decls @echo "Warning: tclOOStubInit.c may be out of date." @echo "Developers may want to run \"make genstubs\" 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 \ $(GENERIC_DIR)/tclTomMath.decls $(NATIVE_TCLSH) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \ $(GENERIC_DIR)/tclOO.decls # # Target to check that all exported functions have an entry in the stubs # tables. # checkstubs: $(TCL_LIB_FILE) -@for i in `nm -p $(TCL_LIB_FILE) \ | > > > > > > > > > | 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 | @echo "This warning can be safely ignored, do not report as a bug!" $(GENERIC_DIR)/tclOOStubInit.c: $(GENERIC_DIR)/tclOO.decls @echo "Warning: tclOOStubInit.c may be out of date." @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 \ $(GENERIC_DIR)/tclTomMath.decls $(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. # checkstubs: $(TCL_LIB_FILE) -@for i in `nm -p $(TCL_LIB_FILE) \ |
︙ | ︙ |
Changes to unix/tclUnixTime.c.
︙ | ︙ | |||
48 49 50 51 52 53 54 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 | * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_WideUInt TclpGetSeconds(void) { return time(NULL); } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
73 74 75 76 77 78 79 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | | | | | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 | * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_WideUInt TclpGetClicks(void) { Tcl_WideUInt now; #ifdef NO_GETTOD if (tclGetTimeProcPtr != NativeGetTime) { Tcl_Time time; tclGetTimeProcPtr(&time, tclTimeClientData); now = (Tcl_WideUInt)time.sec*1000000 + time.usec; } else { /* * A semi-NativeGetTime, specialized to clicks. */ struct tms dummy; now = (Tcl_WideUInt) times(&dummy); } #else Tcl_Time time; tclGetTimeProcPtr(&time, tclTimeClientData); now = (Tcl_WideUInt)time.sec*1000000 + time.usec; #endif return now; } #ifdef TCL_WIDE_CLICKS /* *---------------------------------------------------------------------- * * TclpGetWideClicks -- * * This procedure returns a WideInt value that represents the highest * 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 dependent. * * Results: * Number of WideInt clicks from some start time. * * Side effects: * None. * |
︙ | ︙ |
Changes to win/tclWinNotify.c.
︙ | ︙ | |||
32 33 34 35 36 37 38 | DWORD thread; /* Identifier for thread associated with this * notifier. */ HANDLE event; /* Event object used to wake up the notifier * thread. */ int pending; /* Alert message pending, this field is locked * by the notifierMutex. */ HWND hwnd; /* Messaging window. */ | < | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | DWORD thread; /* Identifier for thread associated with this * notifier. */ HANDLE event; /* Event object used to wake up the notifier * thread. */ int pending; /* Alert message pending, this field is locked * by the notifierMutex. */ HWND hwnd; /* Messaging window. */ int timerActive; /* 1 if interval timer is running. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * The following static indicates the number of threads that have initialized |
︙ | ︙ | |||
305 306 307 308 309 310 311 | */ timeout = timePtr->sec * 1000 + timePtr->usec / 1000; if (timeout == 0) { timeout = 1; } } | < | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 | */ timeout = timePtr->sec * 1000 + timePtr->usec / 1000; if (timeout == 0) { timeout = 1; } } if (timeout != 0) { tsdPtr->timerActive = 1; SetTimer(tsdPtr->hwnd, INTERVAL_TIMER, timeout, NULL); } else { tsdPtr->timerActive = 0; KillTimer(tsdPtr->hwnd, INTERVAL_TIMER); } } } |
︙ | ︙ |
Changes to win/tclWinPipe.c.
︙ | ︙ | |||
57 58 59 60 61 62 63 | /* * This list is used to map from pids to process handles. */ typedef struct ProcInfo { HANDLE hProcess; | | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | /* * This list is used to map from pids to process handles. */ typedef struct ProcInfo { HANDLE hProcess; size_t dwProcessId; struct ProcInfo *nextPtr; } ProcInfo; static ProcInfo *procList; /* * Bit masks used in the flags field of the PipeInfo structure below. |
︙ | ︙ | |||
855 856 857 858 859 860 861 | * * Side effects: * None. * *-------------------------------------------------------------------------- */ | | | | | 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 | * * Side effects: * None. * *-------------------------------------------------------------------------- */ size_t TclpGetPid( Tcl_Pid pid) /* The HANDLE of the child process. */ { ProcInfo *infoPtr; PipeInit(); Tcl_MutexLock(&pipeMutex); for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->dwProcessId == (size_t) pid) { Tcl_MutexUnlock(&pipeMutex); return infoPtr->dwProcessId; } } Tcl_MutexUnlock(&pipeMutex); return (size_t)-1; } /* *---------------------------------------------------------------------- * * TclpCreateProcess -- * |
︙ | ︙ | |||
1159 1160 1161 1162 1163 1164 1165 | * CreateProcess() and CloseHandle(), the problem does not occur." PSS ID * Number: Q124121 */ WaitForInputIdle(procInfo.hProcess, 5000); CloseHandle(procInfo.hThread); | | | 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 | * CreateProcess() and CloseHandle(), the problem does not occur." PSS ID * Number: Q124121 */ WaitForInputIdle(procInfo.hProcess, 5000); CloseHandle(procInfo.hThread); *pidPtr = (Tcl_Pid) (size_t) procInfo.dwProcessId; if (*pidPtr != 0) { TclWinAddProcess(procInfo.hProcess, procInfo.dwProcessId); } result = TCL_OK; end: Tcl_DStringFree(&cmdLine); |
︙ | ︙ | |||
1474 1475 1476 1477 1478 1479 1480 | QuoteCmdLineBackslash(dsPtr, start, special, NULL); start = special; } else { /* rest before first backslash and backslashes into new quoted block */ QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL); start = *bspos; } | | | | | 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 | QuoteCmdLineBackslash(dsPtr, start, special, NULL); start = special; } else { /* rest before first backslash and backslashes into new quoted block */ QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL); start = *bspos; } /* * 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 * before the quote, so `%\%\` should be escaped as `"%\%"\\`). */ TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */ do { *bspos = NULL; special++; if (*special == '\\') { |
︙ | ︙ | |||
1632 1633 1634 1635 1636 1637 1638 | continue; } /* other not special (and not meta) character */ bspos = NULL; /* reset last backslash possition (not interesting) */ special++; } /* rest of argument (and escape backslashes before closing main quote) */ | | | 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 | continue; } /* other not special (and not meta) character */ bspos = NULL; /* reset last backslash possition (not interesting) */ special++; } /* rest of argument (and escape backslashes before closing main quote) */ QuoteCmdLineBackslash(&ds, start, special, (quote & CL_QUOTE) ? bspos : NULL); } if (quote & CL_QUOTE) { /* end of argument (main closing quote-char) */ TclDStringAppendLiteral(&ds, "\""); } } |
︙ | ︙ | |||
2472 2473 2474 2475 2476 2477 2478 | * Find the process and cut it from the process list. */ Tcl_MutexLock(&pipeMutex); prevPtrPtr = &procList; for (infoPtr = procList; infoPtr != NULL; prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) { | | | 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 | * Find the process and cut it from the process list. */ Tcl_MutexLock(&pipeMutex); prevPtrPtr = &procList; for (infoPtr = procList; infoPtr != NULL; prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) { if (infoPtr->dwProcessId == (size_t) pid) { *prevPtrPtr = infoPtr->nextPtr; break; } } Tcl_MutexUnlock(&pipeMutex); /* |
︙ | ︙ | |||
2616 2617 2618 2619 2620 2621 2622 | * *---------------------------------------------------------------------- */ void TclWinAddProcess( void *hProcess, /* Handle to process */ | | | 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 | * *---------------------------------------------------------------------- */ void TclWinAddProcess( void *hProcess, /* Handle to process */ size_t id) /* Global process identifier */ { ProcInfo *procPtr = Tcl_Alloc(sizeof(ProcInfo)); PipeInit(); procPtr->hProcess = hProcess; procPtr->dwProcessId = id; |
︙ | ︙ |
Changes to win/tclWinTime.c.
︙ | ︙ | |||
123 124 125 126 127 128 129 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 | * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_WideUInt TclpGetSeconds(void) { Tcl_Time t; tclGetTimeProcPtr(&t, tclTimeClientData); /* Tcl_GetTime inlined. */ return t.sec; } |
︙ | ︙ | |||
151 152 153 154 155 156 157 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 | * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_WideUInt TclpGetClicks(void) { /* * Use the Tcl_GetTime abstraction to get the time in microseconds, as * nearly as we can, and return it. */ Tcl_Time now; /* Current Tcl time */ unsigned long retval; /* Value to return */ tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */ retval = ((Tcl_WideUInt) now.sec * 1000000) + now.usec; return retval; } /* *---------------------------------------------------------------------- * |
︙ | ︙ |