Tcl Source Code

Changes On Branch tip-558
Login
Bounty program for improvements to Tcl and certain Tcl packages.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Changes In Branch tip-558 Excluding Merge-Ins

This is equivalent to a diff from f5bc93143d to e92d3a4952

2020-02-26
16:56
merge core-8-branch Leaf check-in: e92d3a4952 user: dkf tags: tip-558
14:05
Merge 8.6 check-in: 0346bb5441 user: jan.nijtmans tags: core-8-branch
10:58
Merge 8.7 Closed-Leaf check-in: cfcbd55aba user: jan.nijtmans tags: cplusplus
08:32
merge core-8-branch Leaf check-in: 7859c7efe0 user: dkf tags: tip-567
08:14
Merge 8.7 check-in: 4dc9a5cea0 user: jan.nijtmans tags: trunk
08:04
Merge 8.6 check-in: f5bc93143d user: jan.nijtmans tags: core-8-branch
07:58
Make tclWinDde.c compilable with C++ compiler. dde -> 1.4.3 Make tclWinReg.c compilable with C++ com... check-in: cc5c355ced user: jan.nijtmans tags: core-8-6-branch
2020-02-24
12:18
Merge 8.6 check-in: 1d3f5159be user: jan.nijtmans tags: core-8-branch
2020-02-22
12:35
merge core-8-branch check-in: 199fa617ec user: dkf tags: tip-558

Added doc/configurable.n.

            1  +'\"
            2  +'\" Copyright (c) 2019 Donal K. Fellows
            3  +'\"
            4  +'\" See the file "license.terms" for information on usage and redistribution
            5  +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
            6  +'\"
            7  +.TH configurable n 0.1 TclOO "TclOO Commands"
            8  +.so man.macros
            9  +.BS
           10  +'\" Note:  do not modify the .SH NAME line immediately below!
           11  +.SH NAME
           12  +oo::configurable, configure, property \- class that makes configurable classes and objects, and supports making configurable properties
           13  +.SH SYNOPSIS
           14  +.nf
           15  +package require TclOO
           16  +
           17  +\fBoo::configurable create \fIclass\fR \fR?\fIdefinitionScript\fR?
           18  +
           19  +\fBoo::define \fIclass\fB {\fR
           20  +    \fBproperty \fIpropName\fR ?\fIoptions...\fR? ?\fIpropName\fR ?\fIoptions...\fR?...?
           21  +\fB}\fR
           22  +
           23  +\fBoo::objdefine \fIobject\fB {\fR
           24  +    \fBproperty \fIpropName\fR ?\fIoptions...\fR? ?\fIpropName\fR ?\fIoptions...\fR?...?
           25  +\fB}\fR
           26  +
           27  +\fIobjectName \fBconfigure\fR
           28  +\fIobjectName \fBconfigure\fR \fI\-prop\fR
           29  +\fIobjectName \fBconfigure\fR \fI\-prop value\fR ?\fI\-prop value\fR...\fR
           30  +.fi
           31  +.SH "CLASS HIERARCHY"
           32  +.nf
           33  +\fBoo::object\fR
           34  +   \(-> \fBoo::class\fR
           35  +       \(-> \fBoo::configurable\fR
           36  +
           37  +\fBoo::object\fR
           38  +   \(-> \fBoo::class\fR
           39  +       \(-> \fBoo::configurablesupport::configurable\fR
           40  +.fi
           41  +.BE
           42  +.SH DESCRIPTION
           43  +.PP
           44  +Configurable objects are objects that support being configured with a
           45  +\fBconfigure\fR method. Each of the configurable entities of the object is
           46  +known as a property of the object. Properties may be defined on classes or
           47  +instances; when configuring an object, any of the properties defined by its
           48  +classes (direct or indirect) or by the instance itself may be configured.
           49  +.PP
           50  +The \fBoo::configurable\fR metaclass installs basic support for making
           51  +configurable objects into a class. This consists of making a \fBproperty\fR
           52  +definition command available in definition scripts for the class and instances
           53  +(e.g., from the class's constructor, within \fBoo::define\fR and within
           54  +\fBoo::objdefine\fR) and making a \fBconfigure\fR method available within the
           55  +instances.
           56  +.SS "CONFIGURE METHOD"
           57  +.PP
           58  +The behavior of the \fBconfigure\fR method is modelled after the
           59  +\fBfconfigure\fR/\fBchan configure\fR command.
           60  +.PP
           61  +If passed no additional arguments, the \fBconfigure\fR method returns an
           62  +alphabetically sorted dictionary of all \fIreadable\fR and \fIread-write\fR
           63  +properties and their current values.
           64  +.PP
           65  +If passed a single addiional argument, that argument to the \fBconfigure\fR
           66  +method must be the name of a property to read (or an unambiguous prefix
           67  +thereof); its value is returned.
           68  +.PP
           69  +Otherwise, if passed an even number of arguments then each pair of arguments
           70  +specifies a property name (or an unambiguous prefix thereof) and the value to
           71  +set it to. The properties will be set in the order specified, including
           72  +duplicates. If the setting of any property fails, the overall \fBconfigure\fR
           73  +method fails, the preceding pairs (if any) will continue to have been applied,
           74  +and the succeeding pairs (if any) will be not applied. On success, the result
           75  +of the \fBconfigure\fR method in this mode operation will be an empty string.
           76  +.SS "PROPERTY DEFINITIONS"
           77  +.PP
           78  +When a class has been manufactured by the \fBoo::configurable\fR metaclass (or
           79  +one of its subclasses), it gains an extra definition, \fBproperty\fR. The
           80  +\fBproperty\fR definition defines one or more properties that will be exposed
           81  +by the class's instances.
           82  +.PP
           83  +The \fBproperty\fR command takes the name of a property to define first,
           84  +\fIwithout a leading hyphen\fR, followed by a number of option-value pairs
           85  +that modify the basic behavior of the property. This can then be followed by
           86  +an arbitrary number of other property definitions. The supported options are:
           87  +.TP
           88  +\fB\-get \fIgetterScript\fR
           89  +.
           90  +This defines the implementation of how to read from the property; the
           91  +\fIgetterScript\fR will become the body of a method (taking no arguments)
           92  +defined on the class, if the kind of the property is such that the property
           93  +can be read from. The method will be named
           94  +\fB<ReadProp-\fIpropertyName\fB>\fR, and will default to being a simple read
           95  +of the instance variable with the same name as the property (e.g.,
           96  +.QW "\fBproperty\fR xyz"
           97  +will result in a method
           98  +.QW <ReadProp-xyz>
           99  +being created).
          100  +.TP
          101  +\fB\-kind \fIpropertyKind\fR
          102  +.
          103  +This defines what sort of property is being created. The \fIpropertyKind\fR
          104  +must be exactly one of \fBreadable\fR, \fBwritable\fR, or \fBreadwrite\fR
          105  +(which is the default) which will make the property read-only, write-only or
          106  +read-write, respectively.  Read-only properties can only ever be read from,
          107  +write-only properties can only ever be written to, and read-write properties
          108  +can be both read and written.
          109  +.RS
          110  +.PP
          111  +Note that write-only properties are not particularly discoverable as they are
          112  +never reported by the \fBconfigure\fR method other than by error messages when
          113  +attempting to write to a property that does not exist.
          114  +.RE
          115  +.TP
          116  +\fB\-set \fIsetterScript\fR
          117  +.
          118  +This defines the implementation of how to write to the property; the
          119  +\fIsetterScript\fR will become the body of a method taking a single argument,
          120  +\fIvalue\fR, defined on the class, if the kind of the property is such that
          121  +the property can be written to. The method will be named
          122  +\fB<WriteProp-\fIpropertyName\fB>\fR, and will default to being a simple write
          123  +of the instance variable with the same name as the property (e.g.,
          124  +.QW "\fBproperty\fR xyz"
          125  +will result in a method
          126  +.QW <WriteProp-xyz>
          127  +being created).
          128  +.PP
          129  +Instances of the class that was created by \fBoo::configurable\fR will also
          130  +support \fBproperty\fR definitions; the semantics will be exactly as above
          131  +except that the properties will be defined on the instance alone.
          132  +.PP
          133  +Note that the property implementation methods that \fBproperty\fR defines
          134  +should not be private, as this makes them inaccessible from the implementation
          135  +of \fBconfigure\fR (by design; the property configuration mechanism is
          136  +intended for use mainly from outside a class, whereas a class may access
          137  +variables directly). The variables accessed by the default implementations of
          138  +the properties \fImay\fR be private, if so declared.
          139  +.SH "ADVANCED USAGE"
          140  +.PP
          141  +The configurable class system is comprised of several pieces. The
          142  +\fBoo::configurable\fR metaclass works by mixing in a class and setting
          143  +definition namespaces during object creation that provide the other bits and
          144  +pieces of machinery. The key pieces of the implementation are enumerated here
          145  +so that they can be used by other code:
          146  +.TP
          147  +\fBoo::configuresupport::configurable\fR
          148  +.
          149  +This is a class that provids the implementation of the \fBconfigure\fR method
          150  +(described above in \fBCONFIGURE METHOD\fR).
          151  +.TP
          152  +\fBoo::configuresupport::configurableclass\fR
          153  +.
          154  +This is a namespace that contains the definition dialect that provides the
          155  +\fBproperty\fR declaration for use in classes (i.e., via \fBoo::define\fR, and
          156  +class constructors under normal circumstances), as described above in
          157  +\fBPROPERTY DEFINITIONS\fR. It \fBnamespace export\fRs its \fBproperty\fR
          158  +command so that it may be used easily in user definition dialects.
          159  +.TP
          160  +.
          161  +\fBoo::configuresupport::configurableobject\fR
          162  +.
          163  +This is a namespace that contains the definition dialect that provides the
          164  +\fBproperty\fR declaration for use in instance objects (i.e., via
          165  +\fBoo::objdefine\fR, and the\fB self\R declaration in \fBoo::define), as
          166  +described above in \fBPROPERTY DEFINITIONS\fR. It \fBnamespace export\fRs its
          167  +\fBproperty\fR command so that it may be used easily in user definition
          168  +dialects.
          169  +.PP
          170  +The underlying property discovery mechanism relies on four slots (see
          171  +\fBoo::define\fR for what that implies) that list the properties that can be
          172  +configured. These slots do not themselves impose any semantics on what the
          173  +slots mean other than that they have unique names, no important order, can be
          174  +inherited and discovered on classes and instances.
          175  +.PP
          176  +These slots, and their intended semantics, are:
          177  +.TP
          178  +\fBoo::configuresupport::readableproperties\fR
          179  +.
          180  +The set of properties of a class (not including those from its superclasses)
          181  +that may be read from when configuring an instance of the class. This slot can
          182  +also be read with the \fBinfo class properties\fR command.
          183  +.TP
          184  +\fBoo::configuresupport::writableproperties\fR
          185  +.
          186  +The set of properties of a class (not including those from its superclasses)
          187  +that may be written to when configuring an instance of the class. This slot
          188  +can also be read with the \fBinfo class properties\fR command.
          189  +.TP
          190  +\fBoo::configuresupport::objreadableproperties\fR
          191  +.
          192  +The set of properties of an object instance (not including those from its
          193  +classes) that may be read from when configuring the object. This slot can
          194  +also be read with the \fBinfo object properties\fR command.
          195  +.TP
          196  +\fBoo::configuresupport::objwritableproperties\fR
          197  +.
          198  +The set of properties of an object instance (not including those from its
          199  +classes) that may be written to when configuring the object. This slot can
          200  +also be read with the \fBinfo object properties\fR command.
          201  +.PP
          202  +Note that though these are slots, they are \fInot\fR in the standard
          203  +\fBoo::define\fR or \fBoo::objdefine\fR namespaces; in order to use them
          204  +inside a definition script, they need to be referred to by full name. This is
          205  +because they are intended to be building bricks of configurable property
          206  +system, and not directly used by normal user code.
          207  +.SS "IMPLEMENTATION NOTE"
          208  +.PP
          209  +The implementation of the \fBconfigure\fR method uses
          210  +\fBinfo object properties\fR with the \fB\-all\fR option to discover what
          211  +properties it may manipulate.
          212  +.SH EXAMPLES
          213  +.PP
          214  +Here we create a simple configurable class and demonstrate how it can be
          215  +configured:
          216  +.PP
          217  +.CS
          218  +\fBoo::configurable\fR create Point {
          219  +    \fBproperty\fR x y
          220  +    constructor args {
          221  +        my \fBconfigure\fR -x 0 -y 0 {*}$args
          222  +    }
          223  +    variable x y
          224  +    method print {} {
          225  +        puts "x=$x, y=$y"
          226  +    }
          227  +}
          228  +
          229  +set pt [Point new -x 27]
          230  +$pt print;   \fI# x=27, y=0\fR
          231  +$pt \fBconfigure\fR -y 42
          232  +$pt print;   \fI# x=27, y=42\fR
          233  +puts "distance from origin: [expr {
          234  +    hypot([$pt \fBconfigure\fR -x], [$pt \fBconfigure\fR -y])
          235  +}]";         \fI# distance from origin: 49.92995093127971\fR
          236  +puts [$pt \fBconfigure\fR]
          237  +             \fI# -x 27 -y 42\fR
          238  +.CE
          239  +.PP
          240  +Such a configurable class can be extended by subclassing, though the subclass
          241  +needs to also be created by \fBoo::configurable\fR if it will use the
          242  +\fBproperty\fR definition:
          243  +.PP
          244  +.CS
          245  +\fBoo::configurable\fR create Point3D {
          246  +    superclass Point
          247  +    \fBproperty\fR z
          248  +    constructor args {
          249  +        next -z 0 {*}$args
          250  +    }
          251  +}
          252  +
          253  +set pt2 [Point3D new -x 2 -y 3 -z 4]
          254  +puts [$pt2 \fBconfigure\fR]
          255  +             \fI# -x 2 -y 3 -z 4\fR
          256  +.CE
          257  +.PP
          258  +Once you have a configurable class, you can also add instance properties to
          259  +it. (The backing variables for all properties start unset.) Note below that we
          260  +are using an unambiguous prefix of a property name when setting it; this is
          261  +supported for all properties though full names are normally recommended
          262  +because subclasses will not make an unambiguous prefix become ambiguous in
          263  +that case.
          264  +.PP
          265  +.CS
          266  +oo::objdefine $pt {
          267  +    \fBproperty\fR color
          268  +}
          269  +$pt \fBconfigure\fR -c bisque
          270  +puts [$pt \fBconfigure\fR]
          271  +             \fI# -color bisque -x 27 -y 42\fR
          272  +.CE
          273  +.PP
          274  +You can also do derived properties by making them read-only and supplying a
          275  +script that computes them.
          276  +.PP
          277  +.CS
          278  +\fBoo::configurable\fR create PointMk2 {
          279  +    \fBproperty\fR x y
          280  +    \fBproperty\fR distance -kind readable -get {
          281  +        return [expr {hypot($x, $y)}]
          282  +    }
          283  +    variable x y
          284  +    constructor args {
          285  +        my \fBconfigure\fR -x 0 -y 0 {*}$args
          286  +    }
          287  +}
          288  +
          289  +set pt3 [PointMk2 new -x 3 -y 4]
          290  +puts [$pt3 \fBconfigure\fR -distance]
          291  +             \fI# 5.0\fR
          292  +$pt3 \fBconfigure\fR -distance 10
          293  +             \fI# ERROR: bad property "-distance": must be -x or -y\fR
          294  +.CE
          295  +.PP
          296  +Setters are used to validate the type of a property:
          297  +.PP
          298  +.CS
          299  +\fBoo::configurable\fR create PointMk3 {
          300  +    \fBproperty\fR x -set {
          301  +        if {![string is double -strict $value]} {
          302  +            error "-x property must be a number"
          303  +        }
          304  +        set x $value
          305  +    }
          306  +    \fBproperty\fR y -set {
          307  +        if {![string is double -strict $value]} {
          308  +            error "-y property must be a number"
          309  +        }
          310  +        set y $value
          311  +    }
          312  +    variable x y
          313  +    constructor args {
          314  +        my \fBconfigure\fR -x 0 -y 0 {*}$args
          315  +    }
          316  +}
          317  +
          318  +set pt4 [PointMk3 new]
          319  +puts [$pt4 \fBconfigure\fR]
          320  +             \fI# -x 0 -y 0\fR
          321  +$pt4 \fBconfigure\fR -x 3 -y 4
          322  +puts [$pt4 \fBconfigure\fR]
          323  +             \fI# -x 3 -y 4\fR
          324  +$pt4 \fBconfigure\fR -x "obviously not a number"
          325  +             \fI# ERROR: -x property must be a number\fR
          326  +.CE
          327  +.SH "SEE ALSO"
          328  +info(n), oo::class(n), oo::define(n)
          329  +.SH KEYWORDS
          330  +class, object, properties, configuration
          331  +.\" Local variables:
          332  +.\" mode: nroff
          333  +.\" fill-column: 78
          334  +.\" End:

Changes to doc/define.n.

   488    488   of values (class names, variable names, etc.) that comprises the contents of
   489    489   the slot. The class defines five operations (as methods) that may be done on
   490    490   the slot:
   491    491   .TP
   492    492   \fIslot\fR \fB\-append\fR ?\fImember ...\fR?
   493    493   .
   494    494   This appends the given \fImember\fR elements to the slot definition.
          495  +.TP
          496  +\fIslot\fR \fB\-appendifnew\fR ?\fImember ...\fR?
          497  +.VS TIP558
          498  +This appends the given \fImember\fR elements to the slot definition if they
          499  +do not already exist.
          500  +.VE TIP558
   495    501   .TP
   496    502   \fIslot\fR \fB\-clear\fR
   497    503   .
   498    504   This sets the slot definition to the empty list.
   499    505   .TP
   500    506   \fIslot\fR \fB\-prepend\fR ?\fImember ...\fR?
   501    507   .VS TIP516

Changes to doc/info.n.

   487    487   definition\fR, and when the result is \fBforward\fR, further information can
   488    488   be discovered with \fBinfo class forward\fR.
   489    489   .TP
   490    490   \fBinfo class mixins\fI class\fR
   491    491   .
   492    492   This subcommand returns a list of all classes that have been mixed into the
   493    493   class named \fIclass\fR.
          494  +.TP
          495  +\fBinfo class properties\fI class\fR ?\fIoptions...\fR
          496  +.VS "TIP 558"
          497  +This subcommand returns a sorted list of properties defined on the class named
          498  +\fIclass\fR. The \fIoptions\fR define exactly which properties are returned:
          499  +.RS
          500  +.TP
          501  +\fB\-all\fR
          502  +.
          503  +With this option, the properties from the superclasses and mixins of the class
          504  +are also returned.
          505  +.TP
          506  +\fB\-readable\fR
          507  +.
          508  +This option (the default behavior) asks for the readable properties to be
          509  +returned. Only readable or writable properties are returned, not both.
          510  +.TP
          511  +\fB\-writable\fR
          512  +.
          513  +This option asks for the writable properties to be returned.  Only readable or
          514  +writable properties are returned, not both.
          515  +.RE
          516  +.VE "TIP 558"
   494    517   .TP
   495    518   \fBinfo class subclasses\fI class\fR ?\fIpattern\fR?
   496    519   .
   497    520   This subcommand returns a list of direct subclasses of class \fIclass\fR. If
   498    521   the optional \fIpattern\fR argument is present, it constrains the list of
   499    522   returned classes to those that match it according to the rules of
   500    523   \fBstring match\fR.
................................................................................
   676    699   This subcommand returns a list of all classes that have been mixed into the
   677    700   object named \fIobject\fR.
   678    701   .TP
   679    702   \fBinfo object namespace\fI object\fR
   680    703   .
   681    704   This subcommand returns the name of the internal namespace of the object named
   682    705   \fIobject\fR.
          706  +.TP
          707  +\fBinfo object properties\fI object\fR ?\fIoptions...\fR
          708  +.VS "TIP 558"
          709  +This subcommand returns a sorted list of properties defined on the object
          710  +named \fIobject\fR. The \fIoptions\fR define exactly which properties are
          711  +returned:
          712  +.RS
          713  +.TP
          714  +\fB\-all\fR
          715  +.
          716  +With this option, the properties from the class, superclasses and mixins of
          717  +the object are also returned.
          718  +.TP
          719  +\fB\-readable\fR
          720  +.
          721  +This option (the default behavior) asks for the readable properties to be
          722  +returned. Only readable or writable properties are returned, not both.
          723  +.TP
          724  +\fB\-writable\fR
          725  +.
          726  +This option asks for the writable properties to be returned. Only readable or
          727  +writable properties are returned, not both.
          728  +.RE
          729  +.VE "TIP 558"
   683    730   .TP
   684    731   \fBinfo object variables\fI object\fRR ?\fB\-private\fR?
   685    732   .
   686    733   This subcommand returns a list of all variables that have been declared for
   687    734   the object named \fIobject\fR (i.e. that are automatically present in the
   688    735   object's methods).
   689    736   .VS TIP500

Changes to generic/tclOO.c.

     1      1   /*
     2      2    * tclOO.c --
     3      3    *
     4      4    *	This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
     5      5    *
     6         - * Copyright (c) 2005-2012 by Donal K. Fellows
            6  + * Copyright (c) 2005-2019 by Donal K. Fellows
     7      7    * Copyright (c) 2017 by Nathan Coulter
     8      8    *
     9      9    * See the file "license.terms" for information on usage and redistribution of
    10     10    * this file, and for a DISCLAIMER OF ALL WARRANTIES.
    11     11    */
    12     12   
    13     13   #ifdef HAVE_CONFIG_H
................................................................................
   319    319       Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1);
   320    320       fPtr->defineNs = Tcl_CreateNamespace(interp, "::oo::define", fPtr,
   321    321   	    DeletedDefineNamespace);
   322    322       fPtr->objdefNs = Tcl_CreateNamespace(interp, "::oo::objdefine", fPtr,
   323    323   	    DeletedObjdefNamespace);
   324    324       fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
   325    325   	    DeletedHelpersNamespace);
          326  +    Tcl_CreateNamespace(interp, "::oo::configuresupport", NULL, NULL);
   326    327       fPtr->epoch = 0;
   327    328       fPtr->tsdPtr = tsdPtr;
   328    329       TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown");
   329    330       TclNewLiteralStringObj(fPtr->constructorName, "<constructor>");
   330    331       TclNewLiteralStringObj(fPtr->destructorName, "<destructor>");
   331    332       TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
   332    333       TclNewLiteralStringObj(fPtr->defineName, "::oo::define");
................................................................................
   957    958       Object *oPtr)		/* The object representing the class. */
   958    959   {
   959    960       FOREACH_HASH_DECLS;
   960    961       int i;
   961    962       Class *clsPtr = oPtr->classPtr, *tmpClsPtr;
   962    963       Method *mPtr;
   963    964       Foundation *fPtr = oPtr->fPtr;
   964         -    Tcl_Obj *variableObj;
          965  +    Tcl_Obj *variableObj, *propertyObj;
   965    966       PrivateVariableMapping *privateVariable;
   966    967   
   967    968       /*
   968    969        * Sanity check!
   969    970        */
   970    971   
   971    972       if (!Destructing(oPtr)) {
................................................................................
  1009   1010   	FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) {
  1010   1011   	    TclOODeleteChain(callPtr);
  1011   1012   	}
  1012   1013   	Tcl_DeleteHashTable(clsPtr->classChainCache);
  1013   1014   	ckfree(clsPtr->classChainCache);
  1014   1015   	clsPtr->classChainCache = NULL;
  1015   1016       }
         1017  +
         1018  +    /*
         1019  +     * Squelch the property lists.
         1020  +     */
         1021  +
         1022  +    if (clsPtr->properties.allReadableCache) {
         1023  +	Tcl_DecrRefCount(clsPtr->properties.allReadableCache);
         1024  +    }
         1025  +    if (clsPtr->properties.allWritableCache) {
         1026  +	Tcl_DecrRefCount(clsPtr->properties.allWritableCache);
         1027  +    }
         1028  +    if (clsPtr->properties.readable.num) {
         1029  +	FOREACH(propertyObj, clsPtr->properties.readable) {
         1030  +	    Tcl_DecrRefCount(propertyObj);
         1031  +	}
         1032  +	ckfree(clsPtr->properties.readable.list);
         1033  +    }
         1034  +    if (clsPtr->properties.writable.num) {
         1035  +	FOREACH(propertyObj, clsPtr->properties.writable) {
         1036  +	    Tcl_DecrRefCount(propertyObj);
         1037  +	}
         1038  +	ckfree(clsPtr->properties.writable.list);
         1039  +    }
  1016   1040   
  1017   1041       /*
  1018   1042        * Squelch our filter list.
  1019   1043        */
  1020   1044   
  1021   1045       if (clsPtr->filters.num) {
  1022   1046   	Tcl_Obj *filterObj;
................................................................................
  1111   1135   				 * being deleted. */
  1112   1136   {
  1113   1137       Object *oPtr = clientData;
  1114   1138       Foundation *fPtr = oPtr->fPtr;
  1115   1139       FOREACH_HASH_DECLS;
  1116   1140       Class *mixinPtr;
  1117   1141       Method *mPtr;
  1118         -    Tcl_Obj *filterObj, *variableObj;
         1142  +    Tcl_Obj *filterObj, *variableObj, *propertyObj;
  1119   1143       PrivateVariableMapping *privateVariable;
  1120   1144       Tcl_Interp *interp = oPtr->fPtr->interp;
  1121   1145       int i;
  1122   1146   
  1123   1147       if (Destructing(oPtr)) {
  1124   1148   	/*
  1125   1149   	 * TODO:  Can ObjectNamespaceDeleted ever be called twice?  If not,
................................................................................
  1263   1287   	FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
  1264   1288   	    metadataTypePtr->deleteProc(value);
  1265   1289   	}
  1266   1290   	Tcl_DeleteHashTable(oPtr->metadataPtr);
  1267   1291   	ckfree(oPtr->metadataPtr);
  1268   1292   	oPtr->metadataPtr = NULL;
  1269   1293       }
         1294  +
         1295  +    /*
         1296  +     * Squelch the property lists.
         1297  +     */
         1298  +
         1299  +    if (oPtr->properties.allReadableCache) {
         1300  +	Tcl_DecrRefCount(oPtr->properties.allReadableCache);
         1301  +    }
         1302  +    if (oPtr->properties.allWritableCache) {
         1303  +	Tcl_DecrRefCount(oPtr->properties.allWritableCache);
         1304  +    }
         1305  +    if (oPtr->properties.readable.num) {
         1306  +	FOREACH(propertyObj, oPtr->properties.readable) {
         1307  +	    Tcl_DecrRefCount(propertyObj);
         1308  +	}
         1309  +	ckfree(oPtr->properties.readable.list);
         1310  +    }
         1311  +    if (oPtr->properties.writable.num) {
         1312  +	FOREACH(propertyObj, oPtr->properties.writable) {
         1313  +	    Tcl_DecrRefCount(propertyObj);
         1314  +	}
         1315  +	ckfree(oPtr->properties.writable.list);
         1316  +    }
  1270   1317   
  1271   1318       /*
  1272   1319        * Because an object can be a class that is an instance of itself, the
  1273   1320        * class object's class structure should only be cleaned after most of
  1274   1321        * the cleanup on the object is done.
  1275   1322        *
  1276   1323        * The class of objects needs some special care; if it is deleted (and

Changes to generic/tclOOCall.c.

     1      1   /*
     2      2    * tclOOCall.c --
     3      3    *
     4      4    *	This file contains the method call chain management code for the
     5         - *	object-system core.
            5  + *	object-system core. It also contains everything else that does
            6  + *	inheritance hierarchy traversal.
     6      7    *
     7         - * Copyright (c) 2005-2012 by Donal K. Fellows
            8  + * Copyright (c) 2005-2019 by Donal K. Fellows
     8      9    *
     9     10    * See the file "license.terms" for information on usage and redistribution of
    10     11    * this file, and for a DISCLAIMER OF ALL WARRANTIES.
    11     12    */
    12     13   
    13     14   #ifdef HAVE_CONFIG_H
    14     15   #include "config.h"
................................................................................
    54     55   #define DEFINITE_PROTECTED 0x100000
    55     56   #define DEFINITE_PUBLIC    0x200000
    56     57   #define KNOWN_STATE	   (DEFINITE_PROTECTED | DEFINITE_PUBLIC)
    57     58   #define SPECIAL		   (CONSTRUCTOR | DESTRUCTOR | FORCE_UNKNOWN)
    58     59   #define BUILDING_MIXINS	   0x400000
    59     60   #define TRAVERSED_MIXIN	   0x800000
    60     61   #define OBJECT_MIXIN	   0x1000000
           62  +#define DEFINE_FOR_CLASS   0x2000000
    61     63   #define MIXIN_CONSISTENT(flags) \
    62     64       (((flags) & OBJECT_MIXIN) ||					\
    63     65   	!((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN))
    64     66   
    65     67   /*
    66     68    * Note that the flag bit PRIVATE_METHOD has a confusing name; it's just for
    67     69    * Itcl's special type of private.
................................................................................
  1893   1895   				 * [oo::define], otherwise, we are going to
  1894   1896   				 * use this for [oo::objdefine]. */
  1895   1897   {
  1896   1898       DefineChain define;
  1897   1899       DefineEntry staticSpace[DEFINE_CHAIN_STATIC_SIZE];
  1898   1900       DefineEntry *entryPtr;
  1899   1901       Tcl_Namespace *nsPtr = NULL;
  1900         -    int i;
         1902  +    int i, flags = (forClass ? DEFINE_FOR_CLASS : 0);
  1901   1903   
  1902   1904       define.list = staticSpace;
  1903   1905       define.num = 0;
  1904   1906       define.size = DEFINE_CHAIN_STATIC_SIZE;
  1905   1907   
  1906   1908       /*
  1907   1909        * Add the actual define locations. We have to do this twice to handle
  1908   1910        * class mixins right.
  1909   1911        */
  1910   1912   
  1911         -    AddSimpleDefineNamespaces(oPtr, &define, forClass | BUILDING_MIXINS);
  1912         -    AddSimpleDefineNamespaces(oPtr, &define, forClass);
         1913  +    AddSimpleDefineNamespaces(oPtr, &define, flags | BUILDING_MIXINS);
         1914  +    AddSimpleDefineNamespaces(oPtr, &define, flags);
  1913   1915   
  1914   1916       /*
  1915   1917        * Go through the list until we find a namespace whose name we can
  1916   1918        * resolve.
  1917   1919        */
  1918   1920   
  1919   1921       FOREACH_STRUCT(entryPtr, define) {
................................................................................
  1989   1991   
  1990   1992     tailRecurse:
  1991   1993       FOREACH(superPtr, classPtr->mixins) {
  1992   1994   	AddSimpleClassDefineNamespaces(superPtr, definePtr,
  1993   1995   		flags | TRAVERSED_MIXIN);
  1994   1996       }
  1995   1997   
  1996         -    if (flags & ~(TRAVERSED_MIXIN | BUILDING_MIXINS)) {
         1998  +    if (flags & DEFINE_FOR_CLASS) {
  1997   1999   	AddDefinitionNamespaceToChain(classPtr, classPtr->clsDefinitionNs,
  1998   2000   		definePtr, flags);
  1999   2001       } else {
  2000   2002   	AddDefinitionNamespaceToChain(classPtr, classPtr->objDefinitionNs,
  2001   2003   		definePtr, flags);
  2002   2004       }
  2003   2005   
................................................................................
  2097   2099   		    sizeof(DefineEntry) * definePtr->size);
  2098   2100   	}
  2099   2101       }
  2100   2102       definePtr->list[i].definerCls = definerCls;
  2101   2103       definePtr->list[i].namespaceName = namespaceName;
  2102   2104       definePtr->num++;
  2103   2105   }
         2106  +
         2107  +static void
         2108  +FindClassProps(
         2109  +    Class *clsPtr,
         2110  +    int writable,
         2111  +    Tcl_HashTable *accumulator)
         2112  +{
         2113  +    int i, dummy;
         2114  +    Tcl_Obj *propName;
         2115  +    Class *mixin, *sup;
         2116  +
         2117  +  tailRecurse:
         2118  +    if (writable) {
         2119  +	FOREACH(propName, clsPtr->properties.writable) {
         2120  +	    Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
         2121  +	}
         2122  +    } else {
         2123  +	FOREACH(propName, clsPtr->properties.readable) {
         2124  +	    Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
         2125  +	}
         2126  +    }
         2127  +    if (clsPtr->thisPtr->flags & ROOT_OBJECT) {
         2128  +	/*
         2129  +	 * We do *not* traverse upwards from the root!
         2130  +	 */
         2131  +	return;
         2132  +    }
         2133  +    FOREACH(mixin, clsPtr->mixins) {
         2134  +	FindClassProps(mixin, writable, accumulator);
         2135  +    }
         2136  +    if (clsPtr->superclasses.num == 1) {
         2137  +	clsPtr = clsPtr->superclasses.list[0];
         2138  +	goto tailRecurse;
         2139  +    }
         2140  +    FOREACH(sup, clsPtr->superclasses) {
         2141  +	FindClassProps(sup, writable, accumulator);
         2142  +    }
         2143  +}
         2144  +
         2145  +static void
         2146  +FindObjectProps(
         2147  +    Object *oPtr,
         2148  +    int writable,
         2149  +    Tcl_HashTable *accumulator)
         2150  +{
         2151  +    int i, dummy;
         2152  +    Tcl_Obj *propName;
         2153  +    Class *mixin;
         2154  +
         2155  +    if (writable) {
         2156  +	FOREACH(propName, oPtr->properties.writable) {
         2157  +	    Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
         2158  +	}
         2159  +    } else {
         2160  +	FOREACH(propName, oPtr->properties.readable) {
         2161  +	    Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
         2162  +	}
         2163  +    }
         2164  +    FOREACH(mixin, oPtr->mixins) {
         2165  +	FindClassProps(mixin, writable, accumulator);
         2166  +    }
         2167  +    FindClassProps(oPtr->selfCls, writable, accumulator);
         2168  +}
         2169  +
         2170  +Tcl_Obj *
         2171  +TclOOGetAllClassProperties(
         2172  +    Class *clsPtr,
         2173  +    int writable,
         2174  +    int *allocated)
         2175  +{
         2176  +    Tcl_HashTable hashTable;
         2177  +    FOREACH_HASH_DECLS;
         2178  +    Tcl_Obj *propName, *result;
         2179  +    void *dummy;
         2180  +
         2181  +    /*
         2182  +     * Look in the cache.
         2183  +     */
         2184  +
         2185  +    if (clsPtr->properties.epoch == clsPtr->thisPtr->fPtr->epoch) {
         2186  +	if (writable) {
         2187  +	    if (clsPtr->properties.allWritableCache) {
         2188  +		*allocated = 0;
         2189  +		return clsPtr->properties.allWritableCache;
         2190  +	    }
         2191  +	} else {
         2192  +	    if (clsPtr->properties.allReadableCache) {
         2193  +		*allocated = 0;
         2194  +		return clsPtr->properties.allReadableCache;
         2195  +	    }
         2196  +	}
         2197  +    }
         2198  +
         2199  +    /*
         2200  +     * Gather the information. Unsorted! (Caller will sort.)
         2201  +     */
         2202  +
         2203  +    *allocated = 1;
         2204  +    Tcl_InitObjHashTable(&hashTable);
         2205  +    FindClassProps(clsPtr, writable, &hashTable);
         2206  +    result = Tcl_NewObj();
         2207  +    FOREACH_HASH(propName, dummy, &hashTable) {
         2208  +	Tcl_ListObjAppendElement(NULL, result, propName);
         2209  +    }
         2210  +    Tcl_DeleteHashTable(&hashTable);
         2211  +
         2212  +    /*
         2213  +     * Cache the information. Also purges the cache.
         2214  +     */
         2215  +
         2216  +    if (clsPtr->properties.epoch != clsPtr->thisPtr->fPtr->epoch) {
         2217  +	if (clsPtr->properties.allWritableCache) {
         2218  +	    Tcl_DecrRefCount(clsPtr->properties.allWritableCache);
         2219  +	    clsPtr->properties.allWritableCache = NULL;
         2220  +	}
         2221  +	if (clsPtr->properties.allReadableCache) {
         2222  +	    Tcl_DecrRefCount(clsPtr->properties.allReadableCache);
         2223  +	    clsPtr->properties.allReadableCache = NULL;
         2224  +	}
         2225  +    }
         2226  +    clsPtr->properties.epoch = clsPtr->thisPtr->fPtr->epoch;
         2227  +    if (writable) {
         2228  +	clsPtr->properties.allWritableCache = result;
         2229  +    } else {
         2230  +	clsPtr->properties.allReadableCache = result;
         2231  +    }
         2232  +    Tcl_IncrRefCount(result);
         2233  +    return result;
         2234  +}
         2235  +
         2236  +Tcl_Obj *
         2237  +TclOOGetAllObjectProperties(
         2238  +    Object *oPtr,
         2239  +    int writable,
         2240  +    int *allocated)
         2241  +{
         2242  +    Tcl_HashTable hashTable;
         2243  +    FOREACH_HASH_DECLS;
         2244  +    Tcl_Obj *propName, *result;
         2245  +    void *dummy;
         2246  +
         2247  +    /*
         2248  +     * Look in the cache.
         2249  +     */
         2250  +
         2251  +    if (oPtr->properties.epoch == oPtr->fPtr->epoch) {
         2252  +	if (writable) {
         2253  +	    if (oPtr->properties.allWritableCache) {
         2254  +		*allocated = 0;
         2255  +		return oPtr->properties.allWritableCache;
         2256  +	    }
         2257  +	} else {
         2258  +	    if (oPtr->properties.allReadableCache) {
         2259  +		*allocated = 0;
         2260  +		return oPtr->properties.allReadableCache;
         2261  +	    }
         2262  +	}
         2263  +    }
         2264  +
         2265  +    /*
         2266  +     * Gather the information. Unsorted! (Caller will sort.)
         2267  +     */
         2268  +
         2269  +    *allocated = 1;
         2270  +    Tcl_InitObjHashTable(&hashTable);
         2271  +    FindObjectProps(oPtr, writable, &hashTable);
         2272  +    result = Tcl_NewObj();
         2273  +    FOREACH_HASH(propName, dummy, &hashTable) {
         2274  +	Tcl_ListObjAppendElement(NULL, result, propName);
         2275  +    }
         2276  +    Tcl_DeleteHashTable(&hashTable);
         2277  +
         2278  +    /*
         2279  +     * Cache the information.
         2280  +     */
         2281  +
         2282  +    if (oPtr->properties.epoch != oPtr->fPtr->epoch) {
         2283  +	if (oPtr->properties.allWritableCache) {
         2284  +	    Tcl_DecrRefCount(oPtr->properties.allWritableCache);
         2285  +	    oPtr->properties.allWritableCache = NULL;
         2286  +	}
         2287  +	if (oPtr->properties.allReadableCache) {
         2288  +	    Tcl_DecrRefCount(oPtr->properties.allReadableCache);
         2289  +	    oPtr->properties.allReadableCache = NULL;
         2290  +	}
         2291  +    }
         2292  +    oPtr->properties.epoch = oPtr->fPtr->epoch;
         2293  +    if (writable) {
         2294  +	oPtr->properties.allWritableCache = result;
         2295  +    } else {
         2296  +	oPtr->properties.allReadableCache = result;
         2297  +    }
         2298  +    Tcl_IncrRefCount(result);
         2299  +    return result;
         2300  +}
  2104   2301   
  2105   2302   /*
  2106   2303    * Local Variables:
  2107   2304    * mode: c
  2108   2305    * c-basic-offset: 4
  2109   2306    * fill-column: 78
  2110   2307    * End:
  2111   2308    */

Changes to generic/tclOODefineCmds.c.

     1      1   /*
     2      2    * tclOODefineCmds.c --
     3      3    *
     4      4    *	This file contains the implementation of the ::oo::define command,
     5      5    *	part of the object-system core (NB: not Tcl_Obj, but ::oo).
     6      6    *
     7         - * Copyright (c) 2006-2013 by Donal K. Fellows
            7  + * Copyright (c) 2006-2019 by Donal K. Fellows
     8      8    *
     9      9    * See the file "license.terms" for information on usage and redistribution of
    10     10    * this file, and for a DISCLAIMER OF ALL WARRANTIES.
    11     11    */
    12     12   
    13     13   #ifdef HAVE_CONFIG_H
    14     14   #include "config.h"
................................................................................
    56     56   #define PUBLIC_PATTERN		"[a-z]*"
    57     57   
    58     58   /*
    59     59    * Forward declarations.
    60     60    */
    61     61   
    62     62   static inline void	BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
           63  +static inline void	BumpInstanceEpoch(Object *oPtr);
    63     64   static Tcl_Command	FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
    64     65   			    Tcl_Namespace *const namespacePtr);
    65     66   static inline void	GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr,
    66     67   			    Tcl_Obj *savedNameObj, const char *typeOfSubject);
    67     68   static inline int	MagicDefinitionInvoke(Tcl_Interp *interp,
    68     69   			    Tcl_Namespace *nsPtr, int cmdIndex,
    69     70   			    int objc, Tcl_Obj *const *objv);
................................................................................
    74     75   static inline int	InitDefineContext(Tcl_Interp *interp,
    75     76   			    Tcl_Namespace *namespacePtr, Object *oPtr,
    76     77   			    int objc, Tcl_Obj *const objv[]);
    77     78   static inline void	RecomputeClassCacheFlag(Object *oPtr);
    78     79   static int		RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
    79     80   			    int useClass, Tcl_Obj *const fromPtr,
    80     81   			    Tcl_Obj *const toPtr);
    81         -static int		ClassFilterGet(ClientData clientData,
    82         -			    Tcl_Interp *interp, Tcl_ObjectContext context,
    83         -			    int objc, Tcl_Obj *const *objv);
    84         -static int		ClassFilterSet(ClientData clientData,
    85         -			    Tcl_Interp *interp, Tcl_ObjectContext context,
    86         -			    int objc, Tcl_Obj *const *objv);
    87         -static int		ClassMixinGet(ClientData clientData,
    88         -			    Tcl_Interp *interp, Tcl_ObjectContext context,
    89         -			    int objc, Tcl_Obj *const *objv);
    90         -static int		ClassMixinSet(ClientData clientData,
    91         -			    Tcl_Interp *interp, Tcl_ObjectContext context,
    92         -			    int objc, Tcl_Obj *const *objv);
    93         -static int		ClassSuperGet(ClientData clientData,
    94         -			    Tcl_Interp *interp, Tcl_ObjectContext context,
    95         -			    int objc, Tcl_Obj *const *objv);
    96         -static int		ClassSuperSet(ClientData clientData,
    97         -			    Tcl_Interp *interp, Tcl_ObjectContext context,
    98         -			    int objc, Tcl_Obj *const *objv);
    99         -static int		ClassVarsGet(ClientData clientData,
   100         -			    Tcl_Interp *interp, Tcl_ObjectContext context,
   101         -			    int objc, Tcl_Obj *const *objv);
   102         -static int		ClassVarsSet(ClientData clientData,
   103         -			    Tcl_Interp *interp, Tcl_ObjectContext context,
   104         -			    int objc, Tcl_Obj *const *objv);
   105         -static int		ObjFilterGet(ClientData clientData,
   106         -			    Tcl_Interp *interp, Tcl_ObjectContext context,
   107         -			    int objc, Tcl_Obj *const *objv);
   108         -static int		ObjFilterSet(ClientData clientData,
   109         -			    Tcl_Interp *interp, Tcl_ObjectContext context,
   110         -			    int objc, Tcl_Obj *const *objv);
   111         -static int		ObjMixinGet(ClientData clientData,
   112         -			    Tcl_Interp *interp, Tcl_ObjectContext context,
   113         -			    int objc, Tcl_Obj *const *objv);
   114         -static int		ObjMixinSet(ClientData clientData,
   115         -			    Tcl_Interp *interp, Tcl_ObjectContext context,
   116         -			    int objc, Tcl_Obj *const *objv);
   117         -static int		ObjVarsGet(ClientData clientData,
   118         -			    Tcl_Interp *interp, Tcl_ObjectContext context,
   119         -			    int objc, Tcl_Obj *const *objv);
   120         -static int		ObjVarsSet(ClientData clientData,
   121         -			    Tcl_Interp *interp, Tcl_ObjectContext context,
   122         -			    int objc, Tcl_Obj *const *objv);
   123         -static int		ResolveClass(ClientData clientData,
   124         -			    Tcl_Interp *interp, Tcl_ObjectContext context,
   125         -			    int objc, Tcl_Obj *const *objv);
           82  +static Tcl_MethodCallProc ClassFilterGet, ClassFilterSet;
           83  +static Tcl_MethodCallProc ClassMixinGet, ClassMixinSet;
           84  +static Tcl_MethodCallProc ClassRPropsGet, ClassRPropsSet;
           85  +static Tcl_MethodCallProc ClassSuperGet, ClassSuperSet;
           86  +static Tcl_MethodCallProc ClassVarsGet, ClassVarsSet;
           87  +static Tcl_MethodCallProc ClassWPropsGet, ClassWPropsSet;
           88  +static Tcl_MethodCallProc ObjFilterGet, ObjFilterSet;
           89  +static Tcl_MethodCallProc ObjMixinGet, ObjMixinSet;
           90  +static Tcl_MethodCallProc ObjRPropsGet, ObjRPropsSet;
           91  +static Tcl_MethodCallProc ObjVarsGet, ObjVarsSet;
           92  +static Tcl_MethodCallProc ObjWPropsGet, ObjWPropsSet;
           93  +static Tcl_MethodCallProc ResolveClass;
   126     94   
   127     95   /*
   128     96    * Now define the slots used in declarations.
   129     97    */
   130     98   
   131     99   static const struct DeclaredSlot slots[] = {
   132    100       SLOT("define::filter",      ClassFilterGet, ClassFilterSet, NULL),
   133    101       SLOT("define::mixin",       ClassMixinGet,  ClassMixinSet, ResolveClass),
   134    102       SLOT("define::superclass",  ClassSuperGet,  ClassSuperSet, ResolveClass),
   135    103       SLOT("define::variable",    ClassVarsGet,   ClassVarsSet, NULL),
   136    104       SLOT("objdefine::filter",   ObjFilterGet,   ObjFilterSet, NULL),
   137    105       SLOT("objdefine::mixin",    ObjMixinGet,    ObjMixinSet, ResolveClass),
   138    106       SLOT("objdefine::variable", ObjVarsGet,     ObjVarsSet, NULL),
          107  +    SLOT("configuresupport::readableproperties",
          108  +	    ClassRPropsGet, ClassRPropsSet, NULL),
          109  +    SLOT("configuresupport::writableproperties",
          110  +	    ClassWPropsGet, ClassWPropsSet, NULL),
          111  +    SLOT("configuresupport::objreadableproperties",
          112  +	    ObjRPropsGet, ObjRPropsSet, NULL),
          113  +    SLOT("configuresupport::objwritableproperties",
          114  +	    ObjWPropsGet, ObjWPropsSet, NULL),
   139    115       {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
   140    116   };
   141    117   
   142    118   /*
   143    119    * How to build the in-namespace name of a private variable. This is a pattern
   144    120    * used with Tcl_ObjPrintf().
   145    121    */
................................................................................
   197    173   	 * invalidate any call chains. Note that we still bump our object's
   198    174   	 * epoch if it has any mixins; the relation between a class and its
   199    175   	 * representative object is special. But it won't hurt.
   200    176   	 */
   201    177   
   202    178   	if (classPtr->thisPtr->mixins.num > 0) {
   203    179   	    classPtr->thisPtr->epoch++;
          180  +
          181  +	    /*
          182  +	     * Invalidate the property caches directly.
          183  +	     */
          184  +
          185  +	    if (classPtr->properties.allReadableCache) {
          186  +		Tcl_DecrRefCount(classPtr->properties.allReadableCache);
          187  +		classPtr->properties.allReadableCache = NULL;
          188  +	    }
          189  +	    if (classPtr->properties.allWritableCache) {
          190  +		Tcl_DecrRefCount(classPtr->properties.allWritableCache);
          191  +		classPtr->properties.allWritableCache = NULL;
          192  +	    }
   204    193   	}
   205    194   	return;
   206    195       }
   207    196   
   208    197       /*
   209    198        * Either there's no class (?!) or we're reconfiguring something that is
   210         -     * in use. Force regeneration of call chains.
          199  +     * in use. Force regeneration of call chains and properties.
   211    200        */
   212    201   
   213    202       TclOOGetFoundation(interp)->epoch++;
   214    203   }
          204  +
          205  +/*
          206  + * ----------------------------------------------------------------------
          207  + *
          208  + * BumpInstanceEpoch --
          209  + *
          210  + *	Advances the epoch and clears the property cache of an object. The
          211  + *	equivalent for classes is BumpGlobalEpoch(), as classes have a more
          212  + *	complex set of relationships to other entities.
          213  + *
          214  + * ----------------------------------------------------------------------
          215  + */
          216  +
          217  +static inline void
          218  +BumpInstanceEpoch(
          219  +    Object *oPtr)
          220  +{
          221  +    oPtr->epoch++;
          222  +    if (oPtr->properties.allReadableCache) {
          223  +	Tcl_DecrRefCount(oPtr->properties.allReadableCache);
          224  +	oPtr->properties.allReadableCache = NULL;
          225  +    }
          226  +    if (oPtr->properties.allWritableCache) {
          227  +	Tcl_DecrRefCount(oPtr->properties.allWritableCache);
          228  +	oPtr->properties.allWritableCache = NULL;
          229  +    }
          230  +}
   215    231   
   216    232   /*
   217    233    * ----------------------------------------------------------------------
   218    234    *
   219    235    * RecomputeClassCacheFlag --
   220    236    *
   221    237    *	Determine whether the object is prototypical of its class, and hence
................................................................................
   288    304   	    filtersList[i] = filters[i];
   289    305   	    Tcl_IncrRefCount(filters[i]);
   290    306   	}
   291    307   	oPtr->filters.list = filtersList;
   292    308   	oPtr->filters.num = numFilters;
   293    309   	oPtr->flags &= ~USE_CLASS_CACHE;
   294    310       }
   295         -    oPtr->epoch++;		/* Only this object can be affected. */
          311  +    BumpInstanceEpoch(oPtr);	/* Only this object can be affected. */
   296    312   }
   297    313   
   298    314   /*
   299    315    * ----------------------------------------------------------------------
   300    316    *
   301    317    * TclOOClassSetFilters --
   302    318    *
................................................................................
   411    427   		 * For the new copy created by memcpy().
   412    428   		 */
   413    429   
   414    430   		AddRef(mixinPtr->thisPtr);
   415    431   	    }
   416    432   	}
   417    433       }
   418         -    oPtr->epoch++;
          434  +    BumpInstanceEpoch(oPtr);
   419    435   }
   420    436   
   421    437   /*
   422    438    * ----------------------------------------------------------------------
   423    439    *
   424    440    * TclOOClassSetMixins --
   425    441    *
................................................................................
   478    494    *
   479    495    * InstallStandardVariableMapping, InstallPrivateVariableMapping --
   480    496    *
   481    497    *	Helpers for installing standard and private variable maps.
   482    498    *
   483    499    * ----------------------------------------------------------------------
   484    500    */
          501  +
   485    502   static inline void
   486    503   InstallStandardVariableMapping(
   487    504       VariableNameList *vnlPtr,
   488    505       int varc,
   489    506       Tcl_Obj *const *varv)
   490    507   {
   491    508       Tcl_Obj *variableObj;
................................................................................
  1501   1518   	} else if (!wasClass && willBeClass) {
  1502   1519   	    TclOOAllocClass(interp, oPtr);
  1503   1520   	}
  1504   1521   
  1505   1522   	if (oPtr->classPtr != NULL) {
  1506   1523   	    BumpGlobalEpoch(interp, oPtr->classPtr);
  1507   1524   	} else {
  1508         -	    oPtr->epoch++;
         1525  +	    BumpInstanceEpoch(oPtr);
  1509   1526   	}
  1510   1527       }
  1511   1528       return TCL_OK;
  1512   1529   }
  1513   1530   
  1514   1531   /*
  1515   1532    * ----------------------------------------------------------------------
................................................................................
  1711   1728   	if (RenameDeleteMethod(interp, oPtr, !isInstanceDeleteMethod,
  1712   1729   		objv[i], NULL) != TCL_OK) {
  1713   1730   	    return TCL_ERROR;
  1714   1731   	}
  1715   1732       }
  1716   1733   
  1717   1734       if (isInstanceDeleteMethod) {
  1718         -	oPtr->epoch++;
         1735  +	BumpInstanceEpoch(oPtr);
  1719   1736       } else {
  1720   1737   	BumpGlobalEpoch(interp, oPtr->classPtr);
  1721   1738       }
  1722   1739       return TCL_OK;
  1723   1740   }
  1724   1741   
  1725   1742   /*
................................................................................
  1871   1888   
  1872   1889       /*
  1873   1890        * Bump the right epoch if we actually changed anything.
  1874   1891        */
  1875   1892   
  1876   1893       if (changed) {
  1877   1894   	if (isInstanceExport) {
  1878         -	    oPtr->epoch++;
         1895  +	    BumpInstanceEpoch(oPtr);
  1879   1896   	} else {
  1880   1897   	    BumpGlobalEpoch(interp, clsPtr);
  1881   1898   	}
  1882   1899       }
  1883   1900       return TCL_OK;
  1884   1901   }
  1885   1902   
................................................................................
  2089   2106   
  2090   2107       if (RenameDeleteMethod(interp, oPtr, !isInstanceRenameMethod,
  2091   2108   	    objv[1], objv[2]) != TCL_OK) {
  2092   2109   	return TCL_ERROR;
  2093   2110       }
  2094   2111   
  2095   2112       if (isInstanceRenameMethod) {
  2096         -	oPtr->epoch++;
         2113  +	BumpInstanceEpoch(oPtr);
  2097   2114       } else {
  2098   2115   	BumpGlobalEpoch(interp, oPtr->classPtr);
  2099   2116       }
  2100   2117       return TCL_OK;
  2101   2118   }
  2102   2119   
  2103   2120   /*
................................................................................
  2183   2200   
  2184   2201       /*
  2185   2202        * Bump the right epoch if we actually changed anything.
  2186   2203        */
  2187   2204   
  2188   2205       if (changed) {
  2189   2206   	if (isInstanceUnexport) {
  2190         -	    oPtr->epoch++;
         2207  +	    BumpInstanceEpoch(oPtr);
  2191   2208   	} else {
  2192   2209   	    BumpGlobalEpoch(interp, clsPtr);
  2193   2210   	}
  2194   2211       }
  2195   2212       return TCL_OK;
  2196   2213   }
  2197   2214   
................................................................................
  3073   3090   	Tcl_SetObjResult(interp, objv[idx]);
  3074   3091       } else {
  3075   3092   	Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
  3076   3093       }
  3077   3094   
  3078   3095       return TCL_OK;
  3079   3096   }
         3097  +
         3098  +/*
         3099  + * ----------------------------------------------------------------------
         3100  + *
         3101  + * ClassRPropsGet, ClassRPropsSet, ObjRPropsGet, ObjRPropsSet --
         3102  + *
         3103  + *	Implementations of the "readableproperties" slot accessors for classes
         3104  + *	and instances.
         3105  + *
         3106  + * ----------------------------------------------------------------------
         3107  + */
         3108  +
         3109  +static void
         3110  +InstallReadableProps(
         3111  +    PropertyStorage *props,
         3112  +    int objc,
         3113  +    Tcl_Obj *const objv[])
         3114  +{
         3115  +    Tcl_Obj *propObj;
         3116  +    int i, n, created;
         3117  +    Tcl_HashTable uniqueTable;
         3118  +
         3119  +    if (props->allReadableCache) {
         3120  +	Tcl_DecrRefCount(props->allReadableCache);
         3121  +	props->allReadableCache = NULL;
         3122  +    }
         3123  +
         3124  +    for (i=0 ; i<objc ; i++) {
         3125  +	Tcl_IncrRefCount(objv[i]);
         3126  +    }
         3127  +    FOREACH(propObj, props->readable) {
         3128  +	Tcl_DecrRefCount(propObj);
         3129  +    }
         3130  +    if (i != objc) {
         3131  +	if (objc == 0) {
         3132  +	    ckfree(props->readable.list);
         3133  +	} else if (i) {
         3134  +	    props->readable.list = ckrealloc(props->readable.list,
         3135  +		    sizeof(Tcl_Obj *) * objc);
         3136  +	} else {
         3137  +	    props->readable.list = ckalloc(sizeof(Tcl_Obj *) * objc);
         3138  +	}
         3139  +    }
         3140  +    props->readable.num = 0;
         3141  +    if (objc > 0) {
         3142  +	Tcl_InitObjHashTable(&uniqueTable);
         3143  +	for (i=n=0 ; i<objc ; i++) {
         3144  +	    Tcl_CreateHashEntry(&uniqueTable, objv[i], &created);
         3145  +	    if (created) {
         3146  +		props->readable.list[n++] = objv[i];
         3147  +	    } else {
         3148  +		Tcl_DecrRefCount(objv[i]);
         3149  +	    }
         3150  +	}
         3151  +	props->readable.num = n;
         3152  +
         3153  +	/*
         3154  +	 * Shouldn't be necessary, but maintain num/list invariant.
         3155  +	 */
         3156  +
         3157  +	if (n != objc) {
         3158  +	    props->readable.list = ckrealloc(props->readable.list,
         3159  +		    sizeof(Tcl_Obj *) * n);
         3160  +	}
         3161  +	Tcl_DeleteHashTable(&uniqueTable);
         3162  +    }
         3163  +}
         3164  +
         3165  +static int
         3166  +ClassRPropsGet(
         3167  +    ClientData clientData,
         3168  +    Tcl_Interp *interp,
         3169  +    Tcl_ObjectContext context,
         3170  +    int objc,
         3171  +    Tcl_Obj *const *objv)
         3172  +{
         3173  +    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
         3174  +    Tcl_Obj *resultObj, *propNameObj;
         3175  +    int i;
         3176  +
         3177  +    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
         3178  +	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
         3179  +		NULL);
         3180  +	return TCL_ERROR;
         3181  +    }
         3182  +    if (oPtr == NULL) {
         3183  +	return TCL_ERROR;
         3184  +    } else if (!oPtr->classPtr) {
         3185  +	Tcl_SetObjResult(interp, Tcl_NewStringObj(
         3186  +		"attempt to misuse API", -1));
         3187  +	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
         3188  +	return TCL_ERROR;
         3189  +    }
         3190  +
         3191  +    resultObj = Tcl_NewObj();
         3192  +    FOREACH(propNameObj, oPtr->classPtr->properties.readable) {
         3193  +	Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
         3194  +    }
         3195  +    Tcl_SetObjResult(interp, resultObj);
         3196  +    return TCL_OK;
         3197  +}
         3198  +
         3199  +static int
         3200  +ClassRPropsSet(
         3201  +    ClientData clientData,
         3202  +    Tcl_Interp *interp,
         3203  +    Tcl_ObjectContext context,
         3204  +    int objc,
         3205  +    Tcl_Obj *const *objv)
         3206  +{
         3207  +    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
         3208  +    int varc;
         3209  +    Tcl_Obj **varv;
         3210  +
         3211  +    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
         3212  +	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
         3213  +		"filterList");
         3214  +	return TCL_ERROR;
         3215  +    }
         3216  +    objv += Tcl_ObjectContextSkippedArgs(context);
         3217  +
         3218  +    if (oPtr == NULL) {
         3219  +	return TCL_ERROR;
         3220  +    } else if (!oPtr->classPtr) {
         3221  +	Tcl_SetObjResult(interp, Tcl_NewStringObj(
         3222  +		"attempt to misuse API", -1));
         3223  +	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
         3224  +	return TCL_ERROR;
         3225  +    } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
         3226  +	    &varv) != TCL_OK) {
         3227  +	return TCL_ERROR;
         3228  +    }
         3229  +
         3230  +    InstallReadableProps(&oPtr->classPtr->properties, varc, varv);
         3231  +    BumpGlobalEpoch(interp, oPtr->classPtr);
         3232  +    return TCL_OK;
         3233  +}
         3234  +
         3235  +static int
         3236  +ObjRPropsGet(
         3237  +    ClientData clientData,
         3238  +    Tcl_Interp *interp,
         3239  +    Tcl_ObjectContext context,
         3240  +    int objc,
         3241  +    Tcl_Obj *const *objv)
         3242  +{
         3243  +    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
         3244  +    Tcl_Obj *resultObj, *propNameObj;
         3245  +    int i;
         3246  +
         3247  +    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
         3248  +	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
         3249  +		NULL);
         3250  +	return TCL_ERROR;
         3251  +    }
         3252  +    if (oPtr == NULL) {
         3253  +	return TCL_ERROR;
         3254  +    }
         3255  +
         3256  +    resultObj = Tcl_NewObj();
         3257  +    FOREACH(propNameObj, oPtr->properties.readable) {
         3258  +	Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
         3259  +    }
         3260  +    Tcl_SetObjResult(interp, resultObj);
         3261  +    return TCL_OK;
         3262  +}
         3263  +
         3264  +static int
         3265  +ObjRPropsSet(
         3266  +    ClientData clientData,
         3267  +    Tcl_Interp *interp,
         3268  +    Tcl_ObjectContext context,
         3269  +    int objc,
         3270  +    Tcl_Obj *const *objv)
         3271  +{
         3272  +    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
         3273  +    int varc;
         3274  +    Tcl_Obj **varv;
         3275  +
         3276  +    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
         3277  +	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
         3278  +		"filterList");
         3279  +	return TCL_ERROR;
         3280  +    }
         3281  +    objv += Tcl_ObjectContextSkippedArgs(context);
         3282  +
         3283  +    if (oPtr == NULL) {
         3284  +	return TCL_ERROR;
         3285  +    } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
         3286  +	    &varv) != TCL_OK) {
         3287  +	return TCL_ERROR;
         3288  +    }
         3289  +
         3290  +    InstallReadableProps(&oPtr->properties, varc, varv);
         3291  +    return TCL_OK;
         3292  +}
         3293  +
         3294  +/*
         3295  + * ----------------------------------------------------------------------
         3296  + *
         3297  + * ClassWPropsGet, ClassWPropsSet, ObjWPropsGet, ObjWPropsSet --
         3298  + *
         3299  + *	Implementations of the "writableproperties" slot accessors for classes
         3300  + *	and instances.
         3301  + *
         3302  + * ----------------------------------------------------------------------
         3303  + */
         3304  +
         3305  +static void
         3306  +InstallWritableProps(
         3307  +    PropertyStorage *props,
         3308  +    int objc,
         3309  +    Tcl_Obj *const objv[])
         3310  +{
         3311  +    Tcl_Obj *propObj;
         3312  +    int i, n, created;
         3313  +    Tcl_HashTable uniqueTable;
         3314  +
         3315  +    if (props->allWritableCache) {
         3316  +	Tcl_DecrRefCount(props->allWritableCache);
         3317  +	props->allWritableCache = NULL;
         3318  +    }
         3319  +
         3320  +    for (i=0 ; i<objc ; i++) {
         3321  +	Tcl_IncrRefCount(objv[i]);
         3322  +    }
         3323  +    FOREACH(propObj, props->writable) {
         3324  +	Tcl_DecrRefCount(propObj);
         3325  +    }
         3326  +    if (i != objc) {
         3327  +	if (objc == 0) {
         3328  +	    ckfree(props->writable.list);
         3329  +	} else if (i) {
         3330  +	    props->writable.list = ckrealloc(props->writable.list,
         3331  +		    sizeof(Tcl_Obj *) * objc);
         3332  +	} else {
         3333  +	    props->writable.list = ckalloc(sizeof(Tcl_Obj *) * objc);
         3334  +	}
         3335  +    }
         3336  +    props->writable.num = 0;
         3337  +    if (objc > 0) {
         3338  +	Tcl_InitObjHashTable(&uniqueTable);
         3339  +	for (i=n=0 ; i<objc ; i++) {
         3340  +	    Tcl_CreateHashEntry(&uniqueTable, objv[i], &created);
         3341  +	    if (created) {
         3342  +		props->writable.list[n++] = objv[i];
         3343  +	    } else {
         3344  +		Tcl_DecrRefCount(objv[i]);
         3345  +	    }
         3346  +	}
         3347  +	props->writable.num = n;
         3348  +
         3349  +	/*
         3350  +	 * Shouldn't be necessary, but maintain num/list invariant.
         3351  +	 */
         3352  +
         3353  +	if (n != objc) {
         3354  +	    props->writable.list = ckrealloc(props->writable.list,
         3355  +		    sizeof(Tcl_Obj *) * n);
         3356  +	}
         3357  +	Tcl_DeleteHashTable(&uniqueTable);
         3358  +    }
         3359  +}
         3360  +
         3361  +static int
         3362  +ClassWPropsGet(
         3363  +    ClientData clientData,
         3364  +    Tcl_Interp *interp,
         3365  +    Tcl_ObjectContext context,
         3366  +    int objc,
         3367  +    Tcl_Obj *const *objv)
         3368  +{
         3369  +    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
         3370  +    Tcl_Obj *resultObj, *propNameObj;
         3371  +    int i;
         3372  +
         3373  +    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
         3374  +	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
         3375  +		NULL);
         3376  +	return TCL_ERROR;
         3377  +    }
         3378  +    if (oPtr == NULL) {
         3379  +	return TCL_ERROR;
         3380  +    } else if (!oPtr->classPtr) {
         3381  +	Tcl_SetObjResult(interp, Tcl_NewStringObj(
         3382  +		"attempt to misuse API", -1));
         3383  +	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
         3384  +	return TCL_ERROR;
         3385  +    }
         3386  +
         3387  +    resultObj = Tcl_NewObj();
         3388  +    FOREACH(propNameObj, oPtr->classPtr->properties.writable) {
         3389  +	Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
         3390  +    }
         3391  +    Tcl_SetObjResult(interp, resultObj);
         3392  +    return TCL_OK;
         3393  +}
         3394  +
         3395  +static int
         3396  +ClassWPropsSet(
         3397  +    ClientData clientData,
         3398  +    Tcl_Interp *interp,
         3399  +    Tcl_ObjectContext context,
         3400  +    int objc,
         3401  +    Tcl_Obj *const *objv)
         3402  +{
         3403  +    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
         3404  +    int varc;
         3405  +    Tcl_Obj **varv;
         3406  +
         3407  +    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
         3408  +	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
         3409  +		"propertyList");
         3410  +	return TCL_ERROR;
         3411  +    }
         3412  +    objv += Tcl_ObjectContextSkippedArgs(context);
         3413  +
         3414  +    if (oPtr == NULL) {
         3415  +	return TCL_ERROR;
         3416  +    } else if (!oPtr->classPtr) {
         3417  +	Tcl_SetObjResult(interp, Tcl_NewStringObj(
         3418  +		"attempt to misuse API", -1));
         3419  +	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
         3420  +	return TCL_ERROR;
         3421  +    } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
         3422  +	    &varv) != TCL_OK) {
         3423  +	return TCL_ERROR;
         3424  +    }
         3425  +
         3426  +    InstallWritableProps(&oPtr->classPtr->properties, varc, varv);
         3427  +    BumpGlobalEpoch(interp, oPtr->classPtr);
         3428  +    return TCL_OK;
         3429  +}
         3430  +
         3431  +static int
         3432  +ObjWPropsGet(
         3433  +    ClientData clientData,
         3434  +    Tcl_Interp *interp,
         3435  +    Tcl_ObjectContext context,
         3436  +    int objc,
         3437  +    Tcl_Obj *const *objv)
         3438  +{
         3439  +    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
         3440  +    Tcl_Obj *resultObj, *propNameObj;
         3441  +    int i;
         3442  +
         3443  +    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
         3444  +	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
         3445  +		NULL);
         3446  +	return TCL_ERROR;
         3447  +    }
         3448  +    if (oPtr == NULL) {
         3449  +	return TCL_ERROR;
         3450  +    }
         3451  +
         3452  +    resultObj = Tcl_NewObj();
         3453  +    FOREACH(propNameObj, oPtr->properties.writable) {
         3454  +	Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
         3455  +    }
         3456  +    Tcl_SetObjResult(interp, resultObj);
         3457  +    return TCL_OK;
         3458  +}
         3459  +
         3460  +static int
         3461  +ObjWPropsSet(
         3462  +    ClientData clientData,
         3463  +    Tcl_Interp *interp,
         3464  +    Tcl_ObjectContext context,
         3465  +    int objc,
         3466  +    Tcl_Obj *const *objv)
         3467  +{
         3468  +    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
         3469  +    int varc;
         3470  +    Tcl_Obj **varv;
         3471  +
         3472  +    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
         3473  +	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
         3474  +		"propertyList");
         3475  +	return TCL_ERROR;
         3476  +    }
         3477  +    objv += Tcl_ObjectContextSkippedArgs(context);
         3478  +
         3479  +    if (oPtr == NULL) {
         3480  +	return TCL_ERROR;
         3481  +    } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
         3482  +	    &varv) != TCL_OK) {
         3483  +	return TCL_ERROR;
         3484  +    }
         3485  +
         3486  +    InstallWritableProps(&oPtr->properties, varc, varv);
         3487  +    return TCL_OK;
         3488  +}
  3080   3489   
  3081   3490   /*
  3082   3491    * Local Variables:
  3083   3492    * mode: c
  3084   3493    * c-basic-offset: 4
  3085   3494    * fill-column: 78
  3086   3495    * End:
  3087   3496    */

Changes to generic/tclOOInfo.c.

     1      1   /*
     2      2    * tclOODefineCmds.c --
     3      3    *
     4      4    *	This file contains the implementation of the ::oo-related [info]
     5      5    *	subcommands.
     6      6    *
     7         - * Copyright (c) 2006-2011 by Donal K. Fellows
            7  + * Copyright (c) 2006-2019 by Donal K. Fellows
     8      8    *
     9      9    * See the file "license.terms" for information on usage and redistribution of
    10     10    * this file, and for a DISCLAIMER OF ALL WARRANTIES.
    11     11    */
    12     12   
    13     13   #ifdef HAVE_CONFIG_H
    14     14   #include "config.h"
    15     15   #endif
    16     16   #include "tclInt.h"
    17     17   #include "tclOOInt.h"
    18     18   
    19     19   static inline Class *	GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
           20  +static void		SortPropList(Tcl_Obj *list);
    20     21   static Tcl_ObjCmdProc InfoObjectCallCmd;
    21     22   static Tcl_ObjCmdProc InfoObjectClassCmd;
    22     23   static Tcl_ObjCmdProc InfoObjectDefnCmd;
    23     24   static Tcl_ObjCmdProc InfoObjectFiltersCmd;
    24     25   static Tcl_ObjCmdProc InfoObjectForwardCmd;
    25     26   static Tcl_ObjCmdProc InfoObjectIdCmd;
    26     27   static Tcl_ObjCmdProc InfoObjectIsACmd;
    27     28   static Tcl_ObjCmdProc InfoObjectMethodsCmd;
    28     29   static Tcl_ObjCmdProc InfoObjectMethodTypeCmd;
    29     30   static Tcl_ObjCmdProc InfoObjectMixinsCmd;
    30     31   static Tcl_ObjCmdProc InfoObjectNsCmd;
           32  +static Tcl_ObjCmdProc InfoObjectPropCmd;
    31     33   static Tcl_ObjCmdProc InfoObjectVarsCmd;
    32     34   static Tcl_ObjCmdProc InfoObjectVariablesCmd;
    33     35   static Tcl_ObjCmdProc InfoClassCallCmd;
    34     36   static Tcl_ObjCmdProc InfoClassConstrCmd;
    35     37   static Tcl_ObjCmdProc InfoClassDefnCmd;
    36     38   static Tcl_ObjCmdProc InfoClassDefnNsCmd;
    37     39   static Tcl_ObjCmdProc InfoClassDestrCmd;
    38     40   static Tcl_ObjCmdProc InfoClassFiltersCmd;
    39     41   static Tcl_ObjCmdProc InfoClassForwardCmd;
    40     42   static Tcl_ObjCmdProc InfoClassInstancesCmd;
    41     43   static Tcl_ObjCmdProc InfoClassMethodsCmd;
    42     44   static Tcl_ObjCmdProc InfoClassMethodTypeCmd;
    43     45   static Tcl_ObjCmdProc InfoClassMixinsCmd;
           46  +static Tcl_ObjCmdProc InfoClassPropCmd;
    44     47   static Tcl_ObjCmdProc InfoClassSubsCmd;
    45     48   static Tcl_ObjCmdProc InfoClassSupersCmd;
    46     49   static Tcl_ObjCmdProc InfoClassVariablesCmd;
    47     50   
    48     51   /*
    49     52    * List of commands that are used to implement the [info object] subcommands.
    50     53    */
................................................................................
    57     60       {"filters",	   InfoObjectFiltersCmd,    TclCompileBasic1ArgCmd, NULL, NULL, 0},
    58     61       {"forward",	   InfoObjectForwardCmd,    TclCompileBasic2ArgCmd, NULL, NULL, 0},
    59     62       {"isa",	   InfoObjectIsACmd,	    TclCompileInfoObjectIsACmd, NULL, NULL, 0},
    60     63       {"methods",	   InfoObjectMethodsCmd,    TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
    61     64       {"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
    62     65       {"mixins",	   InfoObjectMixinsCmd,	    TclCompileBasic1ArgCmd, NULL, NULL, 0},
    63     66       {"namespace",  InfoObjectNsCmd,	    TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0},
           67  +    {"properties", InfoObjectPropCmd,	    TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
    64     68       {"variables",  InfoObjectVariablesCmd,  TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    65     69       {"vars",	   InfoObjectVarsCmd,	    TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    66     70       {NULL, NULL, NULL, NULL, NULL, 0}
    67     71   };
    68     72   
    69     73   /*
    70     74    * List of commands that are used to implement the [info class] subcommands.
................................................................................
    78     82       {"destructor",   InfoClassDestrCmd,		TclCompileBasic1ArgCmd, NULL, NULL, 0},
    79     83       {"filters",	     InfoClassFiltersCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
    80     84       {"forward",	     InfoClassForwardCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
    81     85       {"instances",    InfoClassInstancesCmd,	TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    82     86       {"methods",	     InfoClassMethodsCmd,	TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
    83     87       {"methodtype",   InfoClassMethodTypeCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
    84     88       {"mixins",	     InfoClassMixinsCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
           89  +    {"properties",   InfoClassPropCmd,		TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
    85     90       {"subclasses",   InfoClassSubsCmd,		TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    86     91       {"superclasses", InfoClassSupersCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
    87     92       {"variables",    InfoClassVariablesCmd,	TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    88     93       {NULL, NULL, NULL, NULL, NULL, 0}
    89     94   };
    90     95   
    91     96   /*
................................................................................
  1708   1713   		"cannot construct any call chain", -1));
  1709   1714   	return TCL_ERROR;
  1710   1715       }
  1711   1716       Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr));
  1712   1717       TclOODeleteChain(callPtr);
  1713   1718       return TCL_OK;
  1714   1719   }
         1720  +
         1721  +/*
         1722  + * ----------------------------------------------------------------------
         1723  + *
         1724  + * InfoClassPropCmd, InfoObjectPropCmd --
         1725  + *
         1726  + *	Implements [info class properties $clsName ?$option...?] and
         1727  + *	[info object properties $objName ?$option...?]
         1728  + *
         1729  + * ----------------------------------------------------------------------
         1730  + */
         1731  +
         1732  +enum PropOpt {
         1733  +    PROP_ALL, PROP_READABLE, PROP_WRITABLE
         1734  +};
         1735  +static const char *const propOptNames[] = {
         1736  +    "-all", "-readable", "-writable",
         1737  +    NULL
         1738  +};
         1739  +
         1740  +static int
         1741  +InfoClassPropCmd(
         1742  +    ClientData clientData,
         1743  +    Tcl_Interp *interp,
         1744  +    int objc,
         1745  +    Tcl_Obj *const objv[])
         1746  +{
         1747  +    Class *clsPtr;
         1748  +    int i, idx, all = 0, writable = 0, allocated = 0;
         1749  +    Tcl_Obj *result, *propObj;
         1750  +
         1751  +    if (objc < 2) {
         1752  +	Tcl_WrongNumArgs(interp, 1, objv, "className ?options...?");
         1753  +	return TCL_ERROR;
         1754  +    }
         1755  +    clsPtr = GetClassFromObj(interp, objv[1]);
         1756  +    if (clsPtr == NULL) {
         1757  +	return TCL_ERROR;
         1758  +    }
         1759  +    for (i = 2; i < objc; i++) {
         1760  +	if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
         1761  +		&idx) != TCL_OK) {
         1762  +	    return TCL_ERROR;
         1763  +	}
         1764  +	switch (idx) {
         1765  +	case PROP_ALL:
         1766  +	    all = 1;
         1767  +	    break;
         1768  +	case PROP_READABLE:
         1769  +	    writable = 0;
         1770  +	    break;
         1771  +	case PROP_WRITABLE:
         1772  +	    writable = 1;
         1773  +	    break;
         1774  +	}
         1775  +    }
         1776  +
         1777  +    /*
         1778  +     * Get the properties.
         1779  +     */
         1780  +
         1781  +    if (all) {
         1782  +	result = TclOOGetAllClassProperties(clsPtr, writable, &allocated);
         1783  +	if (allocated) {
         1784  +	    SortPropList(result);
         1785  +	}
         1786  +    } else {
         1787  +	result = Tcl_NewObj();
         1788  +	if (writable) {
         1789  +	    FOREACH(propObj, clsPtr->properties.writable) {
         1790  +		Tcl_ListObjAppendElement(NULL, result, propObj);
         1791  +	    }
         1792  +	} else {
         1793  +	    FOREACH(propObj, clsPtr->properties.readable) {
         1794  +		Tcl_ListObjAppendElement(NULL, result, propObj);
         1795  +	    }
         1796  +	}
         1797  +	SortPropList(result);
         1798  +    }
         1799  +    Tcl_SetObjResult(interp, result);
         1800  +    return TCL_OK;
         1801  +}
         1802  +
         1803  +static int
         1804  +InfoObjectPropCmd(
         1805  +    ClientData clientData,
         1806  +    Tcl_Interp *interp,
         1807  +    int objc,
         1808  +    Tcl_Obj *const objv[])
         1809  +{
         1810  +    Object *oPtr;
         1811  +    int i, idx, all = 0, writable = 0, allocated = 0;
         1812  +    Tcl_Obj *result, *propObj;
         1813  +
         1814  +    if (objc < 2) {
         1815  +	Tcl_WrongNumArgs(interp, 1, objv, "objName ?options...?");
         1816  +	return TCL_ERROR;
         1817  +    }
         1818  +    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
         1819  +    if (oPtr == NULL) {
         1820  +	return TCL_ERROR;
         1821  +    }
         1822  +    for (i = 2; i < objc; i++) {
         1823  +	if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
         1824  +		&idx) != TCL_OK) {
         1825  +	    return TCL_ERROR;
         1826  +	}
         1827  +	switch (idx) {
         1828  +	case PROP_ALL:
         1829  +	    all = 1;
         1830  +	    break;
         1831  +	case PROP_READABLE:
         1832  +	    writable = 0;
         1833  +	    break;
         1834  +	case PROP_WRITABLE:
         1835  +	    writable = 1;
         1836  +	    break;
         1837  +	}
         1838  +    }
         1839  +
         1840  +    /*
         1841  +     * Get the properties.
         1842  +     */
         1843  +
         1844  +    if (all) {
         1845  +	result = TclOOGetAllObjectProperties(oPtr, writable, &allocated);
         1846  +	if (allocated) {
         1847  +	    SortPropList(result);
         1848  +	}
         1849  +    } else {
         1850  +	result = Tcl_NewObj();
         1851  +	if (writable) {
         1852  +	    FOREACH(propObj, oPtr->properties.writable) {
         1853  +		Tcl_ListObjAppendElement(NULL, result, propObj);
         1854  +	    }
         1855  +	} else {
         1856  +	    FOREACH(propObj, oPtr->properties.readable) {
         1857  +		Tcl_ListObjAppendElement(NULL, result, propObj);
         1858  +	    }
         1859  +	}
         1860  +	SortPropList(result);
         1861  +    }
         1862  +    Tcl_SetObjResult(interp, result);
         1863  +    return TCL_OK;
         1864  +}
         1865  +
         1866  +/*
         1867  + * ----------------------------------------------------------------------
         1868  + *
         1869  + * SortPropList --
         1870  + *	Sort a list of names of properties. Simple support function. Assumes
         1871  + *	that the list Tcl_Obj is unshared and doesn't have a string
         1872  + *	representation.
         1873  + *
         1874  + * ----------------------------------------------------------------------
         1875  + */
         1876  +
         1877  +static int
         1878  +PropNameCompare(
         1879  +    const void *a,
         1880  +    const void *b)
         1881  +{
         1882  +    Tcl_Obj *first = *(Tcl_Obj **) a;
         1883  +    Tcl_Obj *second = *(Tcl_Obj **) b;
         1884  +
         1885  +    return strcmp(Tcl_GetString(first), Tcl_GetString(second));
         1886  +}
         1887  +
         1888  +static void
         1889  +SortPropList(
         1890  +    Tcl_Obj *list)
         1891  +{
         1892  +    int ec;
         1893  +    Tcl_Obj **ev;
         1894  +
         1895  +    Tcl_ListObjGetElements(NULL, list, &ec, &ev);
         1896  +    qsort(ev, ec, sizeof(Tcl_Obj *), PropNameCompare);
         1897  +}
  1715   1898   
  1716   1899   /*
  1717   1900    * Local Variables:
  1718   1901    * mode: c
  1719   1902    * c-basic-offset: 4
  1720   1903    * fill-column: 78
  1721   1904    * End:
  1722   1905    */

Changes to generic/tclOOInt.h.

   156    156   /*
   157    157    * These types are needed in function arguments.
   158    158    */
   159    159   
   160    160   typedef LIST_STATIC(Tcl_Obj *) VariableNameList;
   161    161   typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList;
   162    162   
          163  +/*
          164  + * This type is used in various places.
          165  + */
          166  +
          167  +typedef struct {
          168  +    LIST_STATIC(Tcl_Obj *) readable;
          169  +				/* The readable properties slot. */
          170  +    LIST_STATIC(Tcl_Obj *) writable;
          171  +				/* The writable properties slot. */
          172  +    Tcl_Obj *allReadableCache;	/* The cache of all readable properties
          173  +				 * exposed by this object or class (in its
          174  +				 * stereotypical instancs). Contains a sorted
          175  +				 * unique list if not NULL. */
          176  +    Tcl_Obj *allWritableCache;	/* The cache of all writable properties
          177  +				 * exposed by this object or class (in its
          178  +				 * stereotypical instances). Contains a sorted
          179  +				 * unique list if not NULL. */
          180  +    int epoch;			/* The epoch that the caches are valid for. */
          181  +} PropertyStorage;
          182  +
   163    183   /*
   164    184    * Now, the definition of what an object actually is.
   165    185    */
   166    186   
   167    187   typedef struct Object {
   168    188       struct Foundation *fPtr;	/* The basis for the object system. Putting
   169    189   				 * this here allows the avoidance of quite a
................................................................................
   178    198       Tcl_HashTable *methodsPtr;	/* Object-local Tcl_Obj (method name) to
   179    199   				 * Method* mapping. */
   180    200       LIST_STATIC(struct Class *) mixins;
   181    201   				/* Classes mixed into this object. */
   182    202       LIST_STATIC(Tcl_Obj *) filters;
   183    203   				/* List of filter names. */
   184    204       struct Class *classPtr;	/* This is non-NULL for all classes, and NULL
   185         -				 *  for everything else. It points to the class
   186         -				 *  structure. */
          205  +				 * for everything else. It points to the class
          206  +				 * structure. */
   187    207       int refCount;		/* Number of strong references to this object.
   188    208   				 * Note that there may be many more weak
   189    209   				 * references; this mechanism exists to
   190    210   				 * avoid Tcl_Preserve. */
   191    211       int flags;
   192    212       int creationEpoch;		/* Unique value to make comparisons of objects
   193    213   				 * easier. */
................................................................................
   207    227   				 * names. For itcl-ng. */
   208    228       VariableNameList variables;
   209    229       PrivateVariableList privateVariables;
   210    230   				/* Configurations for the variable resolver
   211    231   				 * used inside methods. */
   212    232       Tcl_Command myclassCommand;	/* Reference to this object's class dispatcher
   213    233   				 * command. */
          234  +    PropertyStorage properties;	/* Information relating to the lists of
          235  +				 * properties that this object *claims* to
          236  +				 * support. */
   214    237   } Object;
   215    238   
   216         -#define OBJECT_DESTRUCTING	1	/* Indicates that an object is being or has
   217         -								 *  been destroyed  */
   218         -#define DESTRUCTOR_CALLED 2	/* Indicates that evaluation of destructor script for the
   219         -							   object has began */
          239  +#define OBJECT_DESTRUCTING 1	/* Indicates that an object is being or has
          240  +				 *  been destroyed  */
          241  +#define DESTRUCTOR_CALLED 2	/* Indicates that evaluation of destructor
          242  +				 * script for the object has began */
   220    243   #define OO_UNUSED_4	4	/* No longer used.  */
   221    244   #define ROOT_OBJECT 0x1000	/* Flag to say that this object is the root of
   222    245   				 * the class hierarchy and should be treated
   223    246   				 * specially during teardown. */
   224    247   #define FILTER_HANDLING 0x2000	/* Flag set when the object is processing a
   225    248   				 * filter; when set, filters are *not*
   226    249   				 * processed on the object, preventing nasty
................................................................................
   315    338   				 * class in when those instances are defined
   316    339   				 * as instances. If NULL, use the value from
   317    340   				 * the class hierarchy. It's an error at
   318    341   				 * [oo::objdefine]/[self] call time if this
   319    342   				 * namespace is defined but doesn't exist; we
   320    343   				 * also check at setting time but don't check
   321    344   				 * between times. */
          345  +    PropertyStorage properties;	/* Information relating to the lists of
          346  +				 * properties that this class *claims* to
          347  +				 * support. */
   322    348   } Class;
   323    349   
   324    350   /*
   325    351    * The foundation of the object system within an interpreter contains
   326    352    * references to the key classes and namespaces, together with a few other
   327    353    * useful bits and pieces. Probably ought to eventually go in the Interp
   328    354    * structure itself.
................................................................................
   564    590   MODULE_SCOPE int	TclOODefineSlots(Foundation *fPtr);
   565    591   MODULE_SCOPE void	TclOODeleteChain(CallChain *callPtr);
   566    592   MODULE_SCOPE void	TclOODeleteChainCache(Tcl_HashTable *tablePtr);
   567    593   MODULE_SCOPE void	TclOODeleteContext(CallContext *contextPtr);
   568    594   MODULE_SCOPE void	TclOODeleteDescendants(Tcl_Interp *interp,
   569    595   			    Object *oPtr);
   570    596   MODULE_SCOPE void	TclOODelMethodRef(Method *method);
          597  +MODULE_SCOPE Tcl_Obj *	TclOOGetAllClassProperties(Class *clsPtr,
          598  +			    int writable, int *allocated);
          599  +MODULE_SCOPE Tcl_Obj *	TclOOGetAllObjectProperties(Object *oPtr,
          600  +			    int writable, int *allocated);
   571    601   MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
   572    602   			    Tcl_Obj *methodNameObj, int flags,
   573    603   			    Object *contextObjPtr, Class *contextClsPtr,
   574    604   			    Tcl_Obj *cacheInThisObj);
   575    605   MODULE_SCOPE Tcl_Namespace *TclOOGetDefineContextNamespace(
   576    606   			    Tcl_Interp *interp, Object *oPtr, int forClass);
   577    607   MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr,

Changes to generic/tclOOScript.h.

    25     25    */
    26     26   
    27     27   static const char *tclOOSetupScript =
    28     28   /* !BEGIN!: Do not edit below this line. */
    29     29   "::namespace eval ::oo {\n"
    30     30   "\t::namespace path {}\n"
    31     31   "\tnamespace eval Helpers {\n"
    32         -"\t\t::namespace path {}\n"
           32  +"\t\tnamespace path {}\n"
    33     33   "\t\tproc callback {method args} {\n"
    34     34   "\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n"
    35     35   "\t\t}\n"
    36     36   "\t\tnamespace export callback\n"
    37     37   "\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n"
    38     38   "\t\tnamespace export -clear\n"
    39     39   "\t\trename tmp::callback mymethod\n"
................................................................................
    94     94   "\t\t\treturn\n"
    95     95   "\t\t}\n"
    96     96   "\t\tforeach c [info class superclass $class] {\n"
    97     97   "\t\t\tset d [DelegateName $c]\n"
    98     98   "\t\t\tif {![info object isa class $d]} {\n"
    99     99   "\t\t\t\tcontinue\n"
   100    100   "\t\t\t}\n"
   101         -"\t\t\tdefine $delegate ::oo::define::superclass -append $d\n"
          101  +"\t\t\tdefine $delegate ::oo::define::superclass -appendifnew $d\n"
   102    102   "\t\t}\n"
   103         -"\t\tobjdefine $class ::oo::objdefine::mixin -append $delegate\n"
          103  +"\t\tobjdefine $class ::oo::objdefine::mixin -appendifnew $delegate\n"
   104    104   "\t}\n"
   105    105   "\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
   106    106   "\t\tset originDelegate [DelegateName $originObject]\n"
   107    107   "\t\tset targetDelegate [DelegateName $targetObject]\n"
   108    108   "\t\tif {\n"
   109    109   "\t\t\t[info object isa class $originDelegate]\n"
   110    110   "\t\t\t&& ![info object isa class $targetDelegate]\n"
................................................................................
   137    137   "\t\t::namespace export initialise\n"
   138    138   "\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n"
   139    139   "\t\t::namespace export -clear\n"
   140    140   "\t\t::rename tmp::initialise initialize\n"
   141    141   "\t\t::namespace delete tmp\n"
   142    142   "\t}\n"
   143    143   "\tdefine Slot {\n"
   144         -"\t\tmethod Get {} {\n"
          144  +"\t\tmethod Get -unexport {} {\n"
   145    145   "\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
   146    146   "\t\t}\n"
   147         -"\t\tmethod Set list {\n"
          147  +"\t\tmethod Set -unexport list {\n"
   148    148   "\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
   149    149   "\t\t}\n"
   150         -"\t\tmethod Resolve list {\n"
          150  +"\t\tmethod Resolve -unexport list {\n"
   151    151   "\t\t\treturn $list\n"
   152    152   "\t\t}\n"
   153         -"\t\tmethod -set args {\n"
          153  +"\t\tmethod -set -export args {\n"
   154    154   "\t\t\tset my [namespace which my]\n"
   155    155   "\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
   156    156   "\t\t\ttailcall my Set $args\n"
   157    157   "\t\t}\n"
   158         -"\t\tmethod -append args {\n"
          158  +"\t\tmethod -append -export args {\n"
   159    159   "\t\t\tset my [namespace which my]\n"
   160    160   "\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
   161    161   "\t\t\tset current [uplevel 1 [list $my Get]]\n"
   162    162   "\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
   163    163   "\t\t}\n"
   164         -"\t\tmethod -clear {} {tailcall my Set {}}\n"
   165         -"\t\tmethod -prepend args {\n"
          164  +"\t\tmethod -appendifnew -export args {\n"
          165  +"\t\t\tset my [namespace which my]\n"
          166  +"\t\t\tset current [uplevel 1 [list $my Get]]\n"
          167  +"\t\t\tset args [lmap a $args {\n"
          168  +"\t\t\t\tset a [uplevel 1 [list $my Resolve $a]]\n"
          169  +"\t\t\t\tif {$a in $current} continue\n"
          170  +"\t\t\t\tset a\n"
          171  +"\t\t\t}]\n"
          172  +"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
          173  +"\t\t}\n"
          174  +"\t\tmethod -clear -export {} {tailcall my Set {}}\n"
          175  +"\t\tmethod -prepend -export args {\n"
   166    176   "\t\t\tset my [namespace which my]\n"
   167    177   "\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
   168    178   "\t\t\tset current [uplevel 1 [list $my Get]]\n"
   169    179   "\t\t\ttailcall my Set [list {*}$args {*}$current]\n"
   170    180   "\t\t}\n"
   171         -"\t\tmethod -remove args {\n"
          181  +"\t\tmethod -remove -export args {\n"
   172    182   "\t\t\tset my [namespace which my]\n"
   173    183   "\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
   174    184   "\t\t\tset current [uplevel 1 [list $my Get]]\n"
   175    185   "\t\t\ttailcall my Set [lmap val $current {\n"
   176    186   "\t\t\t\tif {$val in $args} continue else {set val}\n"
   177    187   "\t\t\t}]\n"
   178    188   "\t\t}\n"
   179    189   "\t\tforward --default-operation my -append\n"
   180         -"\t\tmethod unknown {args} {\n"
          190  +"\t\tmethod unknown -unexport {args} {\n"
   181    191   "\t\t\tset def --default-operation\n"
   182    192   "\t\t\tif {[llength $args] == 0} {\n"
   183    193   "\t\t\t\ttailcall my $def\n"
   184    194   "\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n"
   185    195   "\t\t\t\ttailcall my $def {*}$args\n"
   186    196   "\t\t\t}\n"
   187    197   "\t\t\tnext {*}$args\n"
   188    198   "\t\t}\n"
   189         -"\t\texport -set -append -clear -prepend -remove\n"
   190         -"\t\tunexport unknown destroy\n"
          199  +"\t\tunexport destroy\n"
   191    200   "\t}\n"
   192    201   "\tobjdefine define::superclass forward --default-operation my -set\n"
   193    202   "\tobjdefine define::mixin forward --default-operation my -set\n"
   194    203   "\tobjdefine objdefine::mixin forward --default-operation my -set\n"
   195         -"\tdefine object method <cloned> {originObject} {\n"
          204  +"\tdefine object method <cloned> -unexport {originObject} {\n"
   196    205   "\t\tforeach p [info procs [info object namespace $originObject]::*] {\n"
   197    206   "\t\t\tset args [info args $p]\n"
   198    207   "\t\t\tset idx -1\n"
   199    208   "\t\t\tforeach a $args {\n"
   200    209   "\t\t\t\tif {[info default $p $a d]} {\n"
   201    210   "\t\t\t\t\tlset args [incr idx] [list $a $d]\n"
   202    211   "\t\t\t\t} else {\n"
................................................................................
   215    224   "\t\t\t\t\tarray set vNew [array get vOrigin]\n"
   216    225   "\t\t\t\t} else {\n"
   217    226   "\t\t\t\t\tset vNew $vOrigin\n"
   218    227   "\t\t\t\t}\n"
   219    228   "\t\t\t}\n"
   220    229   "\t\t}\n"
   221    230   "\t}\n"
   222         -"\tdefine class method <cloned> {originObject} {\n"
          231  +"\tdefine class method <cloned> -unexport {originObject} {\n"
   223    232   "\t\tnext $originObject\n"
   224    233   "\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
   225    234   "\t}\n"
   226    235   "\tclass create singleton {\n"
   227    236   "\t\tsuperclass class\n"
   228    237   "\t\tvariable object\n"
   229    238   "\t\tunexport create createWithNamespace\n"
................................................................................
   231    240   "\t\t\tif {![info exists object] || ![info object isa object $object]} {\n"
   232    241   "\t\t\t\tset object [next {*}$args]\n"
   233    242   "\t\t\t\t::oo::objdefine $object {\n"
   234    243   "\t\t\t\t\tmethod destroy {} {\n"
   235    244   "\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
   236    245   "\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n"
   237    246   "\t\t\t\t\t}\n"
   238         -"\t\t\t\t\tmethod <cloned> {originObject} {\n"
          247  +"\t\t\t\t\tmethod <cloned> -unexport {originObject} {\n"
   239    248   "\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
   240    249   "\t\t\t\t\t\t\t\"may not clone a singleton object\"\n"
   241    250   "\t\t\t\t\t}\n"
   242    251   "\t\t\t\t}\n"
   243    252   "\t\t\t}\n"
   244    253   "\t\t\treturn $object\n"
   245    254   "\t\t}\n"
   246    255   "\t}\n"
   247    256   "\tclass create abstract {\n"
   248    257   "\t\tsuperclass class\n"
   249    258   "\t\tunexport create createWithNamespace new\n"
   250    259   "\t}\n"
          260  +"\t::namespace eval configuresupport {\n"
          261  +"\t\tnamespace path ::tcl\n"
          262  +"\t\tproc PropertyImpl {readslot writeslot args} {\n"
          263  +"\t\t\tfor {set i 0} {$i < [llength $args]} {incr i} {\n"
          264  +"\t\t\t\tset prop [lindex $args $i]\n"
          265  +"\t\t\t\tif {[string match \"-*\" $prop]} {\n"
          266  +"\t\t\t\t\treturn -code error -level 2 \\\n"
          267  +"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
          268  +"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not begin with -\"\n"
          269  +"\t\t\t\t}\n"
          270  +"\t\t\t\tif {$prop ne [list $prop]} {\n"
          271  +"\t\t\t\t\treturn -code error -level 2 \\\n"
          272  +"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
          273  +"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must be a simple word\"\n"
          274  +"\t\t\t\t}\n"
          275  +"\t\t\t\tif {[string first \"::\" $prop] != -1} {\n"
          276  +"\t\t\t\t\treturn -code error -level 2 \\\n"
          277  +"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
          278  +"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not contain namespace separators\"\n"
          279  +"\t\t\t\t}\n"
          280  +"\t\t\t\tif {[string match {*[()]*} $prop]} {\n"
          281  +"\t\t\t\t\treturn -code error -level 2 \\\n"
          282  +"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
          283  +"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not contain parentheses\"\n"
          284  +"\t\t\t\t}\n"
          285  +"\t\t\t\tset realprop [string cat \"-\" $prop]\n"
          286  +"\t\t\t\tset getter [format {::set [my varname %s]} $prop]\n"
          287  +"\t\t\t\tset setter [format {::set [my varname %s] $value} $prop]\n"
          288  +"\t\t\t\tset kind readwrite\n"
          289  +"\t\t\t\twhile {[set next [lindex $args [expr {$i + 1}]]\n"
          290  +"\t\t\t\t\t\tstring match \"-*\" $next]} {\n"
          291  +"\t\t\t\t\tset arg [lindex $args [incr i 2]]\n"
          292  +"\t\t\t\t\tswitch [prefix match -error [list -level 2 -errorcode \\\n"
          293  +"\t\t\t\t\t\t\t[list TCL LOOKUP INDEX option $next]] {-get -kind -set} $next] {\n"
          294  +"\t\t\t\t\t\t-get {\n"
          295  +"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
          296  +"\t\t\t\t\t\t\t\treturn -code error -level 2 \\\n"
          297  +"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n"
          298  +"\t\t\t\t\t\t\t\t\t\"missing body to go with -get option\"\n"
          299  +"\t\t\t\t\t\t\t}\n"
          300  +"\t\t\t\t\t\t\tset getter $arg\n"
          301  +"\t\t\t\t\t\t}\n"
          302  +"\t\t\t\t\t\t-set {\n"
          303  +"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
          304  +"\t\t\t\t\t\t\t\treturn -code error -level 2 \\\n"
          305  +"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n"
          306  +"\t\t\t\t\t\t\t\t\t\"missing body to go with -set option\"\n"
          307  +"\t\t\t\t\t\t\t}\n"
          308  +"\t\t\t\t\t\t\tset setter $arg\n"
          309  +"\t\t\t\t\t\t}\n"
          310  +"\t\t\t\t\t\t-kind {\n"
          311  +"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
          312  +"\t\t\t\t\t\t\t\treturn -code error -level 2\\\n"
          313  +"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n"
          314  +"\t\t\t\t\t\t\t\t\t\"missing kind value to go with -kind option\"\n"
          315  +"\t\t\t\t\t\t\t}\n"
          316  +"\t\t\t\t\t\t\tset kind [prefix match -message \"kind\" -error [list \\\n"
          317  +"\t\t\t\t\t\t\t\t\t-level 2 \\\n"
          318  +"\t\t\t\t\t\t\t\t\t-errorcode [list TCL LOOKUP INDEX kind $arg]] {\n"
          319  +"\t\t\t\t\t\t\t\treadable readwrite writable\n"
          320  +"\t\t\t\t\t\t\t} $arg]\n"
          321  +"\t\t\t\t\t\t}\n"
          322  +"\t\t\t\t\t}\n"
          323  +"\t\t\t\t}\n"
          324  +"\t\t\t\tset reader <ReadProp$realprop>\n"
          325  +"\t\t\t\tset writer <WriteProp$realprop>\n"
          326  +"\t\t\t\tswitch $kind {\n"
          327  +"\t\t\t\t\treadable {\n"
          328  +"\t\t\t\t\t\tuplevel 2 [list $readslot -append $realprop]\n"
          329  +"\t\t\t\t\t\tuplevel 2 [list $writeslot -remove $realprop]\n"
          330  +"\t\t\t\t\t\tuplevel 2 [list method $reader -unexport {} $getter]\n"
          331  +"\t\t\t\t\t}\n"
          332  +"\t\t\t\t\twritable {\n"
          333  +"\t\t\t\t\t\tuplevel 2 [list $readslot -remove $realprop]\n"
          334  +"\t\t\t\t\t\tuplevel 2 [list $writeslot -append $realprop]\n"
          335  +"\t\t\t\t\t\tuplevel 2 [list method $writer -unexport {value} $setter]\n"
          336  +"\t\t\t\t\t}\n"
          337  +"\t\t\t\t\treadwrite {\n"
          338  +"\t\t\t\t\t\tuplevel 2 [list $readslot -append $realprop]\n"
          339  +"\t\t\t\t\t\tuplevel 2 [list $writeslot -append $realprop]\n"
          340  +"\t\t\t\t\t\tuplevel 2 [list method $reader -unexport {} $getter]\n"
          341  +"\t\t\t\t\t\tuplevel 2 [list method $writer -unexport {value} $setter]\n"
          342  +"\t\t\t\t\t}\n"
          343  +"\t\t\t\t}\n"
          344  +"\t\t\t}\n"
          345  +"\t\t}\n"
          346  +"\t\tnamespace eval configurableclass {\n"
          347  +"\t\t\t::proc property args {\n"
          348  +"\t\t\t\t::oo::configuresupport::PropertyImpl \\\n"
          349  +"\t\t\t\t\t::oo::configuresupport::readableproperties \\\n"
          350  +"\t\t\t\t\t::oo::configuresupport::writableproperties {*}$args\n"
          351  +"\t\t\t}\n"
          352  +"\t\t\t::proc properties args {::tailcall property {*}$args}\n"
          353  +"\t\t\t::namespace path ::oo::define\n"
          354  +"\t\t\t::namespace export property\n"
          355  +"\t\t}\n"
          356  +"\t\tnamespace eval configurableobject {\n"
          357  +"\t\t\t::proc property args {\n"
          358  +"\t\t\t\t::oo::configuresupport::PropertyImpl \\\n"
          359  +"\t\t\t\t\t::oo::configuresupport::objreadableproperties \\\n"
          360  +"\t\t\t\t\t::oo::configuresupport::objwritableproperties {*}$args\n"
          361  +"\t\t\t}\n"
          362  +"\t\t\t::proc properties args {::tailcall property {*}$args}\n"
          363  +"\t\t\t::namespace path ::oo::objdefine\n"
          364  +"\t\t\t::namespace export property\n"
          365  +"\t\t}\n"
          366  +"\t\tproc ReadAll {object my} {\n"
          367  +"\t\t\tset result {}\n"
          368  +"\t\t\tforeach prop [info object properties $object -all -readable] {\n"
          369  +"\t\t\t\ttry {\n"
          370  +"\t\t\t\t\tdict set result $prop [$my <ReadProp$prop>]\n"
          371  +"\t\t\t\t} on error {msg opt} {\n"
          372  +"\t\t\t\t\tdict set opt -level 2\n"
          373  +"\t\t\t\t\treturn -options $opt $msg\n"
          374  +"\t\t\t\t} on return {msg opt} {\n"
          375  +"\t\t\t\t\tdict incr opt -level 2\n"
          376  +"\t\t\t\t\treturn -options $opt $msg\n"
          377  +"\t\t\t\t} on break {} {\n"
          378  +"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
          379  +"\t\t\t\t\t\t\"property getter for $prop did a break\"\n"
          380  +"\t\t\t\t} on continue {} {\n"
          381  +"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
          382  +"\t\t\t\t\t\t\"property getter for $prop did a continue\"\n"
          383  +"\t\t\t\t}\n"
          384  +"\t\t\t}\n"
          385  +"\t\t\treturn $result\n"
          386  +"\t\t}\n"
          387  +"\t\tproc ReadOne {object my propertyName} {\n"
          388  +"\t\t\tset props [info object properties $object -all -readable]\n"
          389  +"\t\t\ttry {\n"
          390  +"\t\t\t\tset prop [prefix match -message \"property\" $props $propertyName]\n"
          391  +"\t\t\t} on error {msg} {\n"
          392  +"\t\t\t\tcatch {\n"
          393  +"\t\t\t\t\tset wps [info object properties $object -all -writable]\n"
          394  +"\t\t\t\t\tset wprop [prefix match $wps $propertyName]\n"
          395  +"\t\t\t\t\tset msg \"property \\\"$wprop\\\" is write only\"\n"
          396  +"\t\t\t\t}\n"
          397  +"\t\t\t\treturn -code error -level 2 -errorcode [list \\\n"
          398  +"\t\t\t\t\t\tTCL LOOKUP INDEX property $propertyName] $msg\n"
          399  +"\t\t\t}\n"
          400  +"\t\t\ttry {\n"
          401  +"\t\t\t\tset value [$my <ReadProp$prop>]\n"
          402  +"\t\t\t} on error {msg opt} {\n"
          403  +"\t\t\t\tdict set opt -level 2\n"
          404  +"\t\t\t\treturn -options $opt $msg\n"
          405  +"\t\t\t} on return {msg opt} {\n"
          406  +"\t\t\t\tdict incr opt -level 2\n"
          407  +"\t\t\t\treturn -options $opt $msg\n"
          408  +"\t\t\t} on break {} {\n"
          409  +"\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
          410  +"\t\t\t\t\t\"property getter for $prop did a break\"\n"
          411  +"\t\t\t} on continue {} {\n"
          412  +"\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
          413  +"\t\t\t\t\t\"property getter for $prop did a continue\"\n"
          414  +"\t\t\t}\n"
          415  +"\t\t\treturn $value\n"
          416  +"\t\t}\n"
          417  +"\t\tproc WriteMany {object my setterMap} {\n"
          418  +"\t\t\tset props [info object properties $object -all -writable]\n"
          419  +"\t\t\tforeach {prop value} $setterMap {\n"
          420  +"\t\t\t\ttry {\n"
          421  +"\t\t\t\t\tset prop [prefix match -message \"property\" $props $prop]\n"
          422  +"\t\t\t\t} on error {msg} {\n"
          423  +"\t\t\t\t\tcatch {\n"
          424  +"\t\t\t\t\t\tset rps [info object properties $object -all -readable]\n"
          425  +"\t\t\t\t\t\tset rprop [prefix match $rps $prop]\n"
          426  +"\t\t\t\t\t\tset msg \"property \\\"$rprop\\\" is read only\"\n"
          427  +"\t\t\t\t\t}\n"
          428  +"\t\t\t\t\treturn -code error -level 2 -errorcode [list \\\n"
          429  +"\t\t\t\t\t\t\tTCL LOOKUP INDEX property $prop] $msg\n"
          430  +"\t\t\t\t}\n"
          431  +"\t\t\t\ttry {\n"
          432  +"\t\t\t\t\t$my <WriteProp$prop> $value\n"
          433  +"\t\t\t\t} on error {msg opt} {\n"
          434  +"\t\t\t\t\tdict set opt -level 2\n"
          435  +"\t\t\t\t\treturn -options $opt $msg\n"
          436  +"\t\t\t\t} on return {msg opt} {\n"
          437  +"\t\t\t\t\tdict incr opt -level 2\n"
          438  +"\t\t\t\t\treturn -options $opt $msg\n"
          439  +"\t\t\t\t} on break {} {\n"
          440  +"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
          441  +"\t\t\t\t\t\t\"property setter for $prop did a break\"\n"
          442  +"\t\t\t\t} on continue {} {\n"
          443  +"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
          444  +"\t\t\t\t\t\t\"property setter for $prop did a continue\"\n"
          445  +"\t\t\t\t}\n"
          446  +"\t\t\t}\n"
          447  +"\t\t\treturn\n"
          448  +"\t\t}\n"
          449  +"\t\t::oo::class create configurable {\n"
          450  +"\t\t\tprivate variable my\n"
          451  +"\t\t\tmethod configure -export args {\n"
          452  +"\t\t\t\t::if {![::info exists my]} {\n"
          453  +"\t\t\t\t\t::set my [::namespace which my]\n"
          454  +"\t\t\t\t}\n"
          455  +"\t\t\t\t::if {[::llength $args] == 0} {\n"
          456  +"\t\t\t\t\t::oo::configuresupport::ReadAll [self] $my\n"
          457  +"\t\t\t\t} elseif {[::llength $args] == 1} {\n"
          458  +"\t\t\t\t\t::oo::configuresupport::ReadOne [self] $my \\\n"
          459  +"\t\t\t\t\t\t[::lindex $args 0]\n"
          460  +"\t\t\t\t} elseif {[::llength $args] % 2 == 0} {\n"
          461  +"\t\t\t\t\t::oo::configuresupport::WriteMany [self] $my $args\n"
          462  +"\t\t\t\t} else {\n"
          463  +"\t\t\t\t\t::return -code error -errorcode {TCL WRONGARGS} \\\n"
          464  +"\t\t\t\t\t\t[::format {wrong # args: should be \"%s\"} \\\n"
          465  +"\t\t\t\t\t\t\t\"[self] configure \?-option value ...\?\"]\n"
          466  +"\t\t\t\t}\n"
          467  +"\t\t\t}\n"
          468  +"\t\t\tdefinitionnamespace -instance configurableobject\n"
          469  +"\t\t\tdefinitionnamespace -class configurableclass\n"
          470  +"\t\t}\n"
          471  +"\t}\n"
          472  +"\tclass create configurable {\n"
          473  +"\t\tsuperclass class\n"
          474  +"\t\tconstructor {{definitionScript \"\"}} {\n"
          475  +"\t\t\tnext {mixin ::oo::configuresupport::configurable}\n"
          476  +"\t\t\tnext $definitionScript\n"
          477  +"\t\t}\n"
          478  +"\t\tdefinitionnamespace -class configuresupport::configurableclass\n"
          479  +"\t}\n"
   251    480   "}\n"
   252    481   /* !END!: Do not edit above this line. */
   253    482   ;
   254    483   
   255    484   #endif /* TCL_OO_SCRIPT_H */
   256    485   
   257    486   /*
   258    487    * Local Variables:
   259    488    * mode: c
   260    489    * c-basic-offset: 4
   261    490    * fill-column: 78
   262    491    * End:
   263    492    */

Changes to tests/oo.test.

   372    372   	foreach initial $initials {
   373    373   	    lappend x [info object class $initial]
   374    374   	}
   375    375   	return $x
   376    376       }] {lsort [lsearch -all -not -inline $x *::delegate]}
   377    377   } -cleanup {
   378    378       interp delete $fresh
   379         -} -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}
          379  +} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::configurable ::oo::configuresupport::configurable ::oo::object ::oo::singleton} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::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::configuresupport::configurable} {::oo::abstract ::oo::configurable ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}
   380    380   
   381    381   test oo-2.1 {basic test of OO functionality: constructor} -setup {
   382    382       # This is a bit complex because it needs to run in a sub-interp as
   383    383       # we're modifying the root object class's constructor
   384    384       interp create subinterp
   385    385       subinterp eval {
   386    386   	package require TclOO
................................................................................
  2454   2454       while executing
  2455   2455   \"info object\""
  2456   2456   test oo-16.2 {OO: object introspection} -body {
  2457   2457       info object class NOTANOBJECT
  2458   2458   } -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
  2459   2459   test oo-16.3 {OO: object introspection} -body {
  2460   2460       info object gorp oo::object
  2461         -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, creationid, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars}
         2461  +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, creationid, definition, filters, forward, isa, methods, methodtype, mixins, namespace, properties, variables, or vars}
  2462   2462   test oo-16.4 {OO: object introspection} -setup {
  2463   2463       oo::class create meta { superclass oo::class }
  2464   2464       [meta create instance1] create instance2
  2465   2465   } -body {
  2466   2466       list [list [info object class oo::object] \
  2467   2467   	      [info object class oo::class] \
  2468   2468   	      [info object class meta] \
................................................................................
  2673   2673   } -body {
  2674   2674       info class superclass foo
  2675   2675   } -returnCodes 1 -cleanup {
  2676   2676       foo destroy
  2677   2677   } -result {"foo" is not a class}
  2678   2678   test oo-17.4 {OO: class introspection} -body {
  2679   2679       info class gorp oo::object
  2680         -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, definitionnamespace, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables}
         2680  +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, definitionnamespace, destructor, filters, forward, instances, methods, methodtype, mixins, properties, subclasses, superclasses, or variables}
  2681   2681   test oo-17.5 {OO: class introspection} -setup {
  2682   2682       oo::class create testClass
  2683   2683   } -body {
  2684   2684       testClass create foo
  2685   2685       testClass create bar
  2686   2686       testClass create spong
  2687   2687       lsort [info class instances testClass]
................................................................................
  4193   4193       set s [SampleSlot new]
  4194   4194   }] -body {
  4195   4195       # Method names beginning with "-" are special to slots
  4196   4196       $s -grill q
  4197   4197   } -returnCodes error -cleanup [SampleSlotCleanup {
  4198   4198       rename $s {}
  4199   4199   }] -result \
  4200         -    {unknown method "-grill": must be -append, -clear, -prepend, -remove, -set, contents or ops}
         4200  +    {unknown method "-grill": must be -append, -appendifnew, -clear, -prepend, -remove, -set, contents or ops}
  4201   4201   
  4202   4202   test oo-34.1 {TIP 380: slots - presence} -setup {
  4203   4203       set obj [oo::object new]
  4204   4204       set result {}
  4205   4205   } -body {
  4206   4206       oo::define oo::object {
  4207   4207   	::lappend ::result [::info object class filter]
................................................................................
  4216   4216       }
  4217   4217       return $result
  4218   4218   } -cleanup {
  4219   4219       $obj destroy
  4220   4220   } -result {::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot}
  4221   4221   test oo-34.2 {TIP 380: slots - presence} {
  4222   4222       lsort [info class instances oo::Slot]
  4223         -} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable}
         4223  +} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable}
  4224   4224   proc getMethods obj {
  4225   4225       list [lsort [info object methods $obj -all]] \
  4226   4226   	[lsort [info object methods $obj -private]]
  4227   4227   }
  4228   4228   test oo-34.3 {TIP 380: slots - presence} {
  4229   4229       getMethods oo::define::filter
  4230         -} {{-append -clear -prepend -remove -set} {Get Set}}
         4230  +} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
  4231   4231   test oo-34.4 {TIP 380: slots - presence} {
  4232   4232       getMethods oo::define::mixin
  4233         -} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
         4233  +} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
  4234   4234   test oo-34.5 {TIP 380: slots - presence} {
  4235   4235       getMethods oo::define::superclass
  4236         -} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
         4236  +} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
  4237   4237   test oo-34.6 {TIP 380: slots - presence} {
  4238   4238       getMethods oo::define::variable
  4239         -} {{-append -clear -prepend -remove -set} {Get Set}}
         4239  +} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
  4240   4240   test oo-34.7 {TIP 380: slots - presence} {
  4241   4241       getMethods oo::objdefine::filter
  4242         -} {{-append -clear -prepend -remove -set} {Get Set}}
         4242  +} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
  4243   4243   test oo-34.8 {TIP 380: slots - presence} {
  4244   4244       getMethods oo::objdefine::mixin
  4245         -} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
         4245  +} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
  4246   4246   test oo-34.9 {TIP 380: slots - presence} {
  4247   4247       getMethods oo::objdefine::variable
  4248         -} {{-append -clear -prepend -remove -set} {Get Set}}
         4248  +} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
  4249   4249   test oo-34.10 {TIP 516: slots - resolution} -setup {
  4250   4250       oo::class create parent
  4251   4251       set result {}
  4252   4252       oo::class create 516a { superclass parent }
  4253   4253       oo::class create 516b { superclass parent }
  4254   4254       oo::class create 516c { superclass parent }
  4255   4255       namespace eval 516test {

Added tests/ooProp.test.

            1  +# This file contains a collection of tests for Tcl's built-in object system,
            2  +# specifically the parts that support configurable properties on objects.
            3  +# Sourcing this file into Tcl runs the tests and generates output for errors.
            4  +# No output means no errors were found.
            5  +#
            6  +# Copyright (c) 2019-2020 Donal K. Fellows
            7  +#
            8  +# See the file "license.terms" for information on usage and redistribution of
            9  +# this file, and for a DISCLAIMER OF ALL WARRANTIES.
           10  +
           11  +package require TclOO 1.0.3
           12  +package require tcltest 2
           13  +if {"::tcltest" in [namespace children]} {
           14  +    namespace import -force ::tcltest::*
           15  +}
           16  +
           17  +test ooProp-1.1 {TIP 558: properties: core support} -setup {
           18  +    oo::class create parent
           19  +    unset -nocomplain result
           20  +    set result {}
           21  +} -body {
           22  +    oo::class create c {superclass parent}
           23  +    lappend result [info class properties c] [info class properties c -writable]
           24  +    oo::define c ::oo::configuresupport::readableproperties -set a b c
           25  +    lappend result [info class properties c] [info class properties c -writable]
           26  +    oo::define c ::oo::configuresupport::readableproperties -set f e d
           27  +    lappend result [info class properties c] [info class properties c -writable]
           28  +    oo::define c ::oo::configuresupport::readableproperties -set a a a
           29  +    lappend result [info class properties c] [info class properties c -writable]
           30  +    oo::define c ::oo::configuresupport::readableproperties -set
           31  +    lappend result [info class properties c] [info class properties c -writable]
           32  +} -cleanup {
           33  +    parent destroy
           34  +} -result {{} {} {a b c} {} {d e f} {} a {} {} {}}
           35  +test ooProp-1.2 {TIP 558: properties: core support} -setup {
           36  +    oo::class create parent
           37  +    unset -nocomplain result
           38  +    set result {}
           39  +} -body {
           40  +    oo::class create c {superclass parent}
           41  +    lappend result [info class properties c -all] [info class properties c -writable -all]
           42  +    oo::define c ::oo::configuresupport::readableproperties -set a b c
           43  +    lappend result [info class properties c -all] [info class properties c -writable -all]
           44  +    oo::define c ::oo::configuresupport::readableproperties -set f e d
           45  +    lappend result [info class properties c -all] [info class properties c -writable -all]
           46  +    oo::define c ::oo::configuresupport::readableproperties -set a a a
           47  +    lappend result [info class properties c -all] [info class properties c -writable -all]
           48  +    oo::define c ::oo::configuresupport::readableproperties -set
           49  +    lappend result [info class properties c -all] [info class properties c -writable -all]
           50  +} -cleanup {
           51  +    parent destroy
           52  +} -result {{} {} {a b c} {} {d e f} {} a {} {} {}}
           53  +test ooProp-1.3 {TIP 558: properties: core support} -setup {
           54  +    oo::class create parent
           55  +    unset -nocomplain result
           56  +    set result {}
           57  +} -body {
           58  +    oo::class create c {superclass parent}
           59  +    lappend result [info class properties c] [info class properties c -writable]
           60  +    oo::define c ::oo::configuresupport::writableproperties -set a b c
           61  +    lappend result [info class properties c] [info class properties c -writable]
           62  +    oo::define c ::oo::configuresupport::writableproperties -set f e d
           63  +    lappend result [info class properties c] [info class properties c -writable]
           64  +    oo::define c ::oo::configuresupport::writableproperties -set a a a
           65  +    lappend result [info class properties c] [info class properties c -writable]
           66  +    oo::define c ::oo::configuresupport::writableproperties -set
           67  +    lappend result [info class properties c] [info class properties c -writable]
           68  +} -cleanup {
           69  +    parent destroy
           70  +} -result {{} {} {} {a b c} {} {d e f} {} a {} {}}
           71  +test ooProp-1.4 {TIP 558: properties: core support} -setup {
           72  +    oo::class create parent
           73  +    unset -nocomplain result
           74  +    set result {}
           75  +} -body {
           76  +    oo::class create c {superclass parent}
           77  +    lappend result [info class properties c -all] [info class properties c -writable -all]
           78  +    oo::define c ::oo::configuresupport::writableproperties -set a b c
           79  +    lappend result [info class properties c -all] [info class properties c -writable -all]
           80  +    oo::define c ::oo::configuresupport::writableproperties -set f e d
           81  +    lappend result [info class properties c -all] [info class properties c -writable -all]
           82  +    oo::define c ::oo::configuresupport::writableproperties -set a a a
           83  +    lappend result [info class properties c -all] [info class properties c -writable -all]
           84  +    oo::define c ::oo::configuresupport::writableproperties -set
           85  +    lappend result [info class properties c -all] [info class properties c -writable -all]
           86  +} -cleanup {
           87  +    parent destroy
           88  +} -result {{} {} {} {a b c} {} {d e f} {} a {} {}}
           89  +test ooProp-1.5 {TIP 558: properties: core support} -setup {
           90  +    oo::class create parent
           91  +    unset -nocomplain result
           92  +    set result {}
           93  +} -body {
           94  +    oo::class create c {superclass parent}
           95  +    oo::class create d {superclass c}
           96  +    lappend result [info class properties d -all] [info class properties d -writable -all]
           97  +    oo::define c ::oo::configuresupport::readableproperties -set a b c
           98  +    oo::define d ::oo::configuresupport::readableproperties -set x y z
           99  +    lappend result [info class properties d -all] [info class properties d -writable -all]
          100  +    oo::define c ::oo::configuresupport::readableproperties -set f e d
          101  +    oo::define d ::oo::configuresupport::readableproperties -set r p q
          102  +    lappend result [info class properties d -all] [info class properties d -writable -all]
          103  +    oo::define c ::oo::configuresupport::readableproperties -set a a h
          104  +    oo::define d ::oo::configuresupport::readableproperties -set g h g
          105  +    lappend result [info class properties d -all] [info class properties d -writable -all]
          106  +    oo::define c ::oo::configuresupport::readableproperties -set
          107  +    lappend result [info class properties d -all] [info class properties d -writable -all]
          108  +    oo::define d ::oo::configuresupport::readableproperties -set
          109  +    lappend result [info class properties d -all] [info class properties d -writable -all]
          110  +} -cleanup {
          111  +    parent destroy
          112  +} -result {{} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {} {}}
          113  +test ooProp-1.6 {TIP 558: properties: core support} -setup {
          114  +    oo::class create parent
          115  +    unset -nocomplain result
          116  +    set result {}
          117  +} -body {
          118  +    oo::class create c {superclass parent}
          119  +    oo::class create d {superclass c}
          120  +    lappend result [info class properties d -all] [info class properties d -writable -all]
          121  +    oo::define c ::oo::configuresupport::writableproperties -set a b c
          122  +    oo::define d ::oo::configuresupport::writableproperties -set x y z
          123  +    lappend result [info class properties d -all] [info class properties d -writable -all]
          124  +    oo::define c ::oo::configuresupport::writableproperties -set f e d
          125  +    oo::define d ::oo::configuresupport::writableproperties -set r p q
          126  +    lappend result [info class properties d -all] [info class properties d -writable -all]
          127  +    oo::define c ::oo::configuresupport::writableproperties -set a a h
          128  +    oo::define d ::oo::configuresupport::writableproperties -set g h g
          129  +    lappend result [info class properties d -all] [info class properties d -writable -all]
          130  +    oo::define c ::oo::configuresupport::writableproperties -set
          131  +    lappend result [info class properties d -all] [info class properties d -writable -all]
          132  +    oo::define d ::oo::configuresupport::writableproperties -set
          133  +    lappend result [info class properties d -all] [info class properties d -writable -all]
          134  +} -cleanup {
          135  +    parent destroy
          136  +} -result {{} {} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {}}
          137  +test ooProp-1.7 {TIP 558: properties: core support} -setup {
          138  +    oo::class create parent
          139  +    unset -nocomplain result
          140  +    set result {}
          141  +} -body {
          142  +    oo::class create c {superclass parent}
          143  +    c create o
          144  +    lappend result [info object properties o] [info object properties o -writable]
          145  +    oo::objdefine o ::oo::configuresupport::objreadableproperties -set a b c
          146  +    lappend result [info object properties o] [info object properties o -writable]
          147  +    oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d
          148  +    lappend result [info object properties o] [info object properties o -writable]
          149  +    oo::objdefine o ::oo::configuresupport::objreadableproperties -set a a h
          150  +    lappend result [info object properties o] [info object properties o -writable]
          151  +    oo::objdefine o ::oo::configuresupport::objreadableproperties -set
          152  +    lappend result [info object properties o] [info object properties o -writable]
          153  +} -cleanup {
          154  +    parent destroy
          155  +} -result {{} {} {a b c} {} {d e f} {} {a h} {} {} {}}
          156  +test ooProp-1.8 {TIP 558: properties: core support} -setup {
          157  +    oo::class create parent
          158  +    unset -nocomplain result
          159  +    set result {}
          160  +} -body {
          161  +    oo::class create c {superclass parent}
          162  +    c create o
          163  +    lappend result [info object properties o] [info object properties o -writable]
          164  +    oo::objdefine o ::oo::configuresupport::objwritableproperties -set a b c
          165  +    lappend result [info object properties o] [info object properties o -writable]
          166  +    oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d
          167  +    lappend result [info object properties o] [info object properties o -writable]
          168  +    oo::objdefine o ::oo::configuresupport::objwritableproperties -set a a h
          169  +    lappend result [info object properties o] [info object properties o -writable]
          170  +    oo::objdefine o ::oo::configuresupport::objwritableproperties -set
          171  +    lappend result [info object properties o] [info object properties o -writable]
          172  +} -cleanup {
          173  +    parent destroy
          174  +} -result {{} {} {} {a b c} {} {d e f} {} {a h} {} {}}
          175  +test ooProp-1.9 {TIP 558: properties: core support} -setup {
          176  +    oo::class create parent
          177  +    unset -nocomplain result
          178  +    set result {}
          179  +} -body {
          180  +    oo::class create c {superclass parent}
          181  +    oo::class create d {superclass c}
          182  +    d create o
          183  +    lappend result [info object properties o -all] [info object properties o -writable -all]
          184  +    oo::define c ::oo::configuresupport::readableproperties -set a b
          185  +    oo::define d ::oo::configuresupport::readableproperties -set c d
          186  +    oo::objdefine o ::oo::configuresupport::objreadableproperties -set e f
          187  +    lappend result [info object properties o -all] [info object properties o -writable -all]
          188  +    oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d b e
          189  +    lappend result [info object properties o -all] [info object properties o -writable -all]
          190  +} -cleanup {
          191  +    parent destroy
          192  +} -result {{} {} {a b c d e f} {} {a b c d e f} {}}
          193  +test ooProp-1.10 {TIP 558: properties: core support} -setup {
          194  +    oo::class create parent
          195  +    unset -nocomplain result
          196  +    set result {}
          197  +} -body {
          198  +    oo::class create c {superclass parent}
          199  +    oo::class create d {superclass c}
          200  +    d create o
          201  +    lappend result [info object properties o -all] [info object properties o -writable -all]
          202  +    oo::define c ::oo::configuresupport::writableproperties -set a b
          203  +    oo::define d ::oo::configuresupport::writableproperties -set c d
          204  +    oo::objdefine o ::oo::configuresupport::objwritableproperties -set e f
          205  +    lappend result [info object properties o -all] [info object properties o -writable -all]
          206  +    oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d b e
          207  +    lappend result [info object properties o -all] [info object properties o -writable -all]
          208  +} -cleanup {
          209  +    parent destroy
          210  +} -result {{} {} {} {a b c d e f} {} {a b c d e f}}
          211  +test ooProp-1.11 {TIP 558: properties: core support cache} -setup {
          212  +    oo::class create parent
          213  +    unset -nocomplain result
          214  +} -body {
          215  +    oo::class create m {
          216  +	superclass parent
          217  +	::oo::configuresupport::readableproperties -set a
          218  +	::oo::configuresupport::writableproperties -set c
          219  +    }
          220  +    oo::class create c {
          221  +	superclass parent
          222  +	::oo::configuresupport::readableproperties -set b
          223  +	::oo::configuresupport::writableproperties -set d
          224  +    }
          225  +    c create o
          226  +    lappend result [info object properties o -all -readable] \
          227  +	[info object properties o -all -writable]
          228  +    oo::objdefine o mixin m
          229  +    lappend result [info object properties o -all -readable] \
          230  +	[info object properties o -all -writable]
          231  +} -cleanup {
          232  +    parent destroy
          233  +} -result {b d {a b} {c d}}
          234  +
          235  +test ooProp-2.1 {TIP 558: properties: configurable class system} -setup {
          236  +    oo::class create parent
          237  +    unset -nocomplain result
          238  +    set result {}
          239  +} -body {
          240  +    oo::configurable create Point {
          241  +	superclass parent
          242  +	property x y
          243  +        constructor args {
          244  +            my configure -x 0 -y 0 {*}$args
          245  +        }
          246  +        variable x y
          247  +        method report {} {
          248  +            lappend ::result "x=$x, y=$y"
          249  +        }
          250  +    }
          251  +    set pt [Point new -x 3]
          252  +    $pt report
          253  +    $pt configure -y 4
          254  +    $pt report
          255  +    lappend result [$pt configure -x],[$pt configure -y] [$pt configure]
          256  +} -cleanup {
          257  +    parent destroy
          258  +} -result {{x=3, y=0} {x=3, y=4} 3,4 {-x 3 -y 4}}
          259  +test ooProp-2.2 {TIP 558: properties: configurable class system} -setup {
          260  +    oo::class create parent
          261  +} -body {
          262  +    oo::configurable create Point {
          263  +	superclass parent
          264  +	property x y
          265  +        constructor args {
          266  +            my configure -x 0 -y 0 {*}$args
          267  +        }
          268  +    }
          269  +    oo::configurable create 3DPoint {
          270  +	superclass Point
          271  +	property z
          272  +	constructor args {
          273  +	    next -z 0 {*}$args
          274  +	}
          275  +    }
          276  +    set pt [3DPoint new -x 3 -y 4 -z 5]
          277  +    list [$pt configure -x],[$pt configure -y],[$pt configure -z] \
          278  +	[$pt configure]
          279  +} -cleanup {
          280  +    parent destroy
          281  +} -result {3,4,5 {-x 3 -y 4 -z 5}}
          282  +test ooProp-2.3 {TIP 558: properties: configurable class system} -setup {
          283  +    oo::class create parent
          284  +} -body {
          285  +    oo::configurable create Point {
          286  +	superclass parent
          287  +	property x y
          288  +        constructor args {
          289  +            my configure -x 0 -y 0 {*}$args
          290  +        }
          291  +    }
          292  +    set pt [Point new -x 3 -y 4]
          293  +    oo::objdefine $pt property z
          294  +    $pt configure -z 5
          295  +    list [$pt configure -x],[$pt configure -y],[$pt configure -z] \
          296  +	[$pt configure]
          297  +} -cleanup {
          298  +    parent destroy
          299  +} -result {3,4,5 {-x 3 -y 4 -z 5}}
          300  +test ooProp-2.4 {TIP 558: properties: configurable class system} -setup {
          301  +    oo::class create parent
          302  +} -body {
          303  +    oo::configurable create Point {
          304  +	superclass parent
          305  +	property x y
          306  +        constructor args {
          307  +            my configure -x 0 -y 0 {*}$args
          308  +        }
          309  +    }
          310  +    [Point new] configure gorp
          311  +} -returnCodes error -cleanup {
          312  +    parent destroy
          313  +} -result {bad property "gorp": must be -x or -y}
          314  +test ooProp-2.5 {TIP 558: properties: configurable class system} -setup {
          315  +    oo::class create parent
          316  +} -body {
          317  +    oo::configurable create Point {
          318  +	superclass parent
          319  +	property x y
          320  +        constructor args {
          321  +            my configure -x 0 -y 0 {*}$args
          322  +        }
          323  +    }
          324  +    oo::configurable create 3DPoint {
          325  +	superclass Point
          326  +	property z
          327  +	constructor args {
          328  +	    next -z 0 {*}$args
          329  +	}
          330  +    }
          331  +    [3DPoint new] configure gorp
          332  +} -returnCodes error -cleanup {
          333  +    parent destroy
          334  +} -result {bad property "gorp": must be -x, -y, or -z}
          335  +test ooProp-2.6 {TIP 558: properties: configurable class system} -setup {
          336  +    oo::class create parent
          337  +} -body {
          338  +    oo::configurable create Point {
          339  +	superclass parent
          340  +	property x y
          341  +        constructor args {
          342  +            my configure -x 0 -y 0 {*}$args
          343  +        }
          344  +    }
          345  +    [Point create p] configure -x 1 -y
          346  +} -returnCodes error -cleanup {
          347  +    parent destroy
          348  +} -result {wrong # args: should be "::p configure ?-option value ...?"}
          349  +test ooProp-2.7 {TIP 558: properties: configurable class system} -setup {
          350  +    oo::class create parent
          351  +    unset -nocomplain msg
          352  +} -body {
          353  +    oo::configurable create Point {
          354  +	superclass parent
          355  +	property x y -kind writable
          356  +        constructor args {
          357  +            my configure -x 0 -y 0 {*}$args
          358  +        }
          359  +    }
          360  +    Point create p
          361  +    list [p configure -y ok] [catch {p configure -y} msg] $msg
          362  +} -cleanup {
          363  +    parent destroy
          364  +} -result {{} 1 {property "-y" is write only}}
          365  +test ooProp-2.8 {TIP 558: properties: configurable class system} -setup {
          366  +    oo::class create parent
          367  +    unset -nocomplain msg
          368  +} -body {
          369  +    oo::configurable create Point {
          370  +	superclass parent
          371  +	property x y -kind readable
          372  +        constructor args {
          373  +            my configure -x 0 {*}$args
          374  +	    variable y 123
          375  +        }
          376  +    }
          377  +    Point create p
          378  +    list [p configure] [p configure -y] [catch {p configure -y foo} msg] $msg
          379  +} -cleanup {
          380  +    parent destroy
          381  +} -result {{-x 0 -y 123} 123 1 {property "-y" is read only}}
          382  +
          383  +test ooProp-3.1 {TIP 558: properties: declaration semantics} -setup {
          384  +    oo::class create parent
          385  +    unset -nocomplain result
          386  +    set result {}
          387  +} -body {
          388  +    oo::configurable create Point {superclass parent}
          389  +    oo::define Point {
          390  +	variable xyz
          391  +	property x -get {
          392  +	    global result
          393  +	    lappend result "get"
          394  +	    return [lrepeat 3 $xyz]
          395  +	} -set {
          396  +	    global result
          397  +	    lappend result [list set $value]
          398  +	    set xyz [expr {$value * 3}]
          399  +	}
          400  +    }
          401  +    Point create pt
          402  +    pt configure -x 5
          403  +    lappend result >[pt configure -x]<
          404  +} -cleanup {
          405  +    parent destroy
          406  +} -result {{set 5} get {>15 15 15<}}
          407  +test ooProp-3.2 {TIP 558: properties: declaration semantics} -setup {
          408  +    oo::class create parent
          409  +    unset -nocomplain result
          410  +    set result {}
          411  +} -body {
          412  +    oo::configurable create Point {superclass parent}
          413  +    oo::define Point {
          414  +	variable xyz
          415  +	property x -get {
          416  +	    global result
          417  +	    lappend result "get"
          418  +	    return [lrepeat 3 $xyz]
          419  +	} -set {
          420  +	    global result
          421  +	    lappend result [list set $value]
          422  +	    set xyz [expr {$value * 3}]
          423  +	} y -kind readable -get {return $xyz}
          424  +    }
          425  +    Point create pt
          426  +    pt configure -x 5
          427  +    lappend result >[pt configure -x]< [pt configure -y]
          428  +} -cleanup {
          429  +    parent destroy
          430  +} -result {{set 5} get {>15 15 15<} 15}
          431  +test ooProp-3.3 {TIP 558: properties: declaration semantics} -setup {
          432  +    oo::class create parent
          433  +} -body {
          434  +    oo::configurable create Point {superclass parent}
          435  +    oo::define Point {
          436  +	variable xyz
          437  +	property -x -get {return $xyz}
          438  +    }
          439  +} -returnCodes error -cleanup {
          440  +    parent destroy
          441  +} -result {bad property name "-x": must not begin with -}
          442  +test ooProp-3.4 {TIP 558: properties: declaration semantics} -setup {
          443  +    oo::class create parent
          444  +} -body {
          445  +    oo::configurable create Point {superclass parent}
          446  +    oo::define Point {
          447  +	property "x y"
          448  +    }
          449  +} -returnCodes error -cleanup {
          450  +    parent destroy
          451  +} -result {bad property name "x y": must be a simple word}
          452  +test ooProp-3.5 {TIP 558: properties: declaration semantics} -setup {
          453  +    oo::class create parent
          454  +} -body {
          455  +    oo::configurable create Point {superclass parent}
          456  +    oo::define Point {
          457  +	property ::x
          458  +    }
          459  +} -returnCodes error -cleanup {
          460  +    parent destroy
          461  +} -result {bad property name "::x": must not contain namespace separators}
          462  +test ooProp-3.6 {TIP 558: properties: declaration semantics} -setup {
          463  +    oo::class create parent
          464  +} -body {
          465  +    oo::configurable create Point {superclass parent}
          466  +    oo::define Point {
          467  +	property x(
          468  +    }
          469  +} -returnCodes error -cleanup {
          470  +    parent destroy
          471  +} -result {bad property name "x(": must not contain parentheses}
          472  +test ooProp-3.7 {TIP 558: properties: declaration semantics} -setup {
          473  +    oo::class create parent
          474  +} -body {
          475  +    oo::configurable create Point {superclass parent}
          476  +    oo::define Point {
          477  +	property x)
          478  +    }
          479  +} -returnCodes error -cleanup {
          480  +    parent destroy
          481  +} -result {bad property name "x)": must not contain parentheses}
          482  +test ooProp-3.8 {TIP 558: properties: declaration semantics} -setup {
          483  +    oo::class create parent
          484  +} -body {
          485  +    oo::configurable create Point {superclass parent}
          486  +    oo::define Point {
          487  +	property x -get
          488  +    }
          489  +} -returnCodes error -cleanup {
          490  +    parent destroy
          491  +} -result {missing body to go with -get option}
          492  +test ooProp-3.9 {TIP 558: properties: declaration semantics} -setup {
          493  +    oo::class create parent
          494  +} -body {
          495  +    oo::configurable create Point {superclass parent}
          496  +    oo::define Point {
          497  +	property x -set
          498  +    }
          499  +} -returnCodes error -cleanup {
          500  +    parent destroy
          501  +} -result {missing body to go with -set option}
          502  +test ooProp-3.10 {TIP 558: properties: declaration semantics} -setup {
          503  +    oo::class create parent
          504  +} -body {
          505  +    oo::configurable create Point {superclass parent}
          506  +    oo::define Point {
          507  +	property x -kind
          508  +    }
          509  +} -returnCodes error -cleanup {
          510  +    parent destroy
          511  +} -result {missing kind value to go with -kind option}
          512  +test ooProp-3.11 {TIP 558: properties: declaration semantics} -setup {
          513  +    oo::class create parent
          514  +} -body {
          515  +    oo::configurable create Point {superclass parent}
          516  +    oo::define Point {
          517  +	property x -get {} -set
          518  +    }
          519  +} -returnCodes error -cleanup {
          520  +    parent destroy
          521  +} -result {missing body to go with -set option}
          522  +test ooProp-3.12 {TIP 558: properties: declaration semantics} -setup {
          523  +    oo::class create parent
          524  +} -body {
          525  +    oo::configurable create Point {
          526  +	superclass parent
          527  +	property x -get {} -get {return ok}
          528  +    }
          529  +    [Point new] configure -x
          530  +} -cleanup {
          531  +    parent destroy
          532  +} -result ok
          533  +test ooProp-3.13 {TIP 558: properties: declaration semantics} -setup {
          534  +    oo::class create parent
          535  +} -body {
          536  +    oo::configurable create Point {
          537  +	superclass parent
          538  +	property x -kind gorp
          539  +    }
          540  +} -returnCodes error -cleanup {
          541  +    parent destroy
          542  +} -result {bad kind "gorp": must be readable, readwrite, or writable}
          543  +test ooProp-3.14 {TIP 558: properties: declaration semantics} -setup {
          544  +    oo::class create parent
          545  +} -body {
          546  +    oo::configurable create Point {
          547  +	superclass parent
          548  +	property x -k reada -g {return ok}
          549  +    }
          550  +    [Point new] configure -x
          551  +} -cleanup {
          552  +    parent destroy
          553  +} -result ok
          554  +test ooProp-3.15 {TIP 558: properties: declaration semantics} -setup {
          555  +    oo::class create parent
          556  +} -body {
          557  +    oo::configurable create Point {
          558  +	superclass parent
          559  +	property {*}{
          560  +	    x -kind writable
          561  +	    y -get {return ok}
          562  +	}
          563  +    }
          564  +    [Point new] configure -y
          565  +} -cleanup {
          566  +    parent destroy
          567  +} -result ok
          568  +test ooProp-3.16 {TIP 558: properties: declaration semantics} -setup {
          569  +    oo::class create parent
          570  +    unset -nocomplain msg
          571  +} -body {
          572  +    oo::configurable create Point {
          573  +	superclass parent
          574  +	variable xy
          575  +	property x -kind readable -get {return $xy}
          576  +	property x -kind writable -set {set xy $value}
          577  +    }
          578  +    Point create pt
          579  +    list [catch {
          580  +	pt configure -x ok
          581  +    } msg] $msg [catch {
          582  +	pt configure -x
          583  +    } msg] $msg [catch {
          584  +	pt configure -y 1
          585  +    } msg] $msg
          586  +} -cleanup {
          587  +    parent destroy
          588  +} -result {0 {} 1 {property "-x" is write only} 1 {bad property "-y": must be -x}}
          589  +test ooProp-3.17 {TIP 558: properties: declaration semantics} -setup {
          590  +    oo::class create parent
          591  +} -body {
          592  +    oo::configurable create Point {
          593  +	superclass parent
          594  +	property x -get {return -code break}
          595  +    }
          596  +    while 1 {
          597  +	[Point new] configure -x
          598  +	break
          599  +    }
          600  +} -returnCodes error -cleanup {
          601  +    parent destroy
          602  +} -result {property getter for -x did a break}
          603  +test ooProp-3.18 {TIP 558: properties: declaration semantics} -setup {
          604  +    oo::class create parent
          605  +} -body {
          606  +    oo::configurable create Point {
          607  +	superclass parent
          608  +	property x -get {return -code break}
          609  +    }
          610  +    while 1 {
          611  +	[Point new] configure
          612  +	break
          613  +    }
          614  +} -returnCodes error -cleanup {
          615  +    parent destroy
          616  +} -result {property getter for -x did a break}
          617  +test ooProp-3.19 {TIP 558: properties: declaration semantics} -setup {
          618  +    oo::class create parent
          619  +} -body {
          620  +    oo::configurable create Point {
          621  +	superclass parent
          622  +	property x -get {error "boo"}
          623  +    }
          624  +    while 1 {
          625  +	[Point new] configure -x
          626  +	break
          627  +    }
          628  +} -returnCodes error -cleanup {
          629  +    parent destroy
          630  +} -result boo
          631  +test ooProp-3.20 {TIP 558: properties: declaration semantics} -setup {
          632  +    oo::class create parent
          633  +} -body {
          634  +    oo::configurable create Point {
          635  +	superclass parent
          636  +	property x -get {error "boo"}
          637  +    }
          638  +    while 1 {
          639  +	[Point new] configure
          640  +	break
          641  +    }
          642  +} -returnCodes error -cleanup {
          643  +    parent destroy
          644  +} -result boo
          645  +test ooProp-3.21 {TIP 558: properties: declaration semantics} -setup {
          646  +    oo::class create parent
          647  +} -body {
          648  +    oo::configurable create Point {
          649  +	superclass parent
          650  +	property x -get {return -code continue}
          651  +    }
          652  +    while 1 {
          653  +	[Point new] configure -x
          654  +	break
          655  +    }
          656  +} -returnCodes error -cleanup {
          657  +    parent destroy
          658  +} -result {property getter for -x did a continue}
          659  +test ooProp-3.22 {TIP 558: properties: declaration semantics} -setup {
          660  +    oo::class create parent
          661  +} -body {
          662  +    oo::configurable create Point {
          663  +	superclass parent
          664  +	property x -get {return -level 2 ok}
          665  +    }
          666  +    apply {{} {
          667  +	[Point new] configure
          668  +	return bad
          669  +    }}
          670  +} -cleanup {
          671  +    parent destroy
          672  +} -result ok
          673  +test ooProp-3.23 {TIP 558: properties: declaration semantics} -setup {
          674  +    oo::class create parent
          675  +} -body {
          676  +    oo::configurable create Point {
          677  +	superclass parent
          678  +	property x -get {return -level 2 ok}
          679  +    }
          680  +    apply {{} {
          681  +	[Point new] configure -x
          682  +	return bad
          683  +    }}
          684  +} -cleanup {
          685  +    parent destroy
          686  +} -result ok
          687  +test ooProp-3.24 {TIP 558: properties: declaration semantics} -setup {
          688  +    oo::class create parent
          689  +} -body {
          690  +    oo::configurable create Point {
          691  +	superclass parent
          692  +	property x -set {return -code break}
          693  +    }
          694  +    while 1 {
          695  +	[Point new] configure -x gorp
          696  +	break
          697  +    }
          698  +} -returnCodes error -cleanup {
          699  +    parent destroy
          700  +} -result {property setter for -x did a break}
          701  +test ooProp-3.25 {TIP 558: properties: declaration semantics} -setup {
          702  +    oo::class create parent
          703  +} -body {
          704  +    oo::configurable create Point {
          705  +	superclass parent
          706  +	property x -set {return -code continue}
          707  +    }
          708  +    while 1 {
          709  +	[Point new] configure -x gorp
          710  +	break
          711  +    }
          712  +} -returnCodes error -cleanup {
          713  +    parent destroy
          714  +} -result {property setter for -x did a continue}
          715  +test ooProp-3.26 {TIP 558: properties: declaration semantics} -setup {
          716  +    oo::class create parent
          717  +} -body {
          718  +    oo::configurable create Point {
          719  +	superclass parent
          720  +	property x -set {error "boo"}
          721  +    }
          722  +    while 1 {
          723  +	[Point new] configure -x gorp
          724  +	break
          725  +    }
          726  +} -returnCodes error -cleanup {
          727  +    parent destroy
          728  +} -result boo
          729  +test ooProp-3.27 {TIP 558: properties: declaration semantics} -setup {
          730  +    oo::class create parent
          731  +} -body {
          732  +    oo::configurable create Point {
          733  +	superclass parent
          734  +	property x -set {return -level 2 ok}
          735  +    }
          736  +    apply {{} {
          737  +	[Point new] configure -x gorp
          738  +	return bad
          739  +    }}
          740  +} -cleanup {
          741  +    parent destroy
          742  +} -result ok
          743  +test ooProp-3.28 {TIP 558: properties: declaration semantics} -setup {
          744  +    oo::class create parent
          745  +} -body {
          746  +    oo::configurable create Point {
          747  +	superclass parent
          748  +	private property var
          749  +    }
          750  +    Point create pt
          751  +    pt configure -var ok
          752  +    pt configure -var
          753  +} -cleanup {
          754  +    parent destroy
          755  +} -result ok
          756  +
          757  +test ooProp-4.1 {TIP 558: properties: error details} -setup {
          758  +    oo::class create parent
          759  +    unset -nocomplain msg opt
          760  +} -body {
          761  +    oo::configurable create Point {superclass parent}
          762  +    list [catch {oo::define Point {property -x}} msg opt] \
          763  +	[dict get $opt -errorinfo] [dict get $opt -errorcode]
          764  +} -cleanup {
          765  +    parent destroy
          766  +} -result {1 {bad property name "-x": must not begin with -
          767  +    while executing
          768  +"property -x"
          769  +    (in definition script for class "::Point" line 1)
          770  +    invoked from within
          771  +"oo::define Point {property -x}"} {TCLOO PROPERTY_FORMAT}}
          772  +test ooProp-4.2 {TIP 558: properties: error details} -setup {
          773  +    oo::class create parent
          774  +    unset -nocomplain msg opt
          775  +} -body {
          776  +    oo::configurable create Point {superclass parent}
          777  +    list [catch {oo::define Point {property x -get}} msg opt] \
          778  +	[dict get $opt -errorinfo] [dict get $opt -errorcode]
          779  +} -cleanup {
          780  +    parent destroy
          781  +} -result {1 {missing body to go with -get option
          782  +    while executing
          783  +"property x -get"
          784  +    (in definition script for class "::Point" line 1)
          785  +    invoked from within
          786  +"oo::define Point {property x -get}"} {TCL WRONGARGS}}
          787  +test ooProp-4.3 {TIP 558: properties: error details} -setup {
          788  +    oo::class create parent
          789  +    unset -nocomplain msg opt
          790  +} -body {
          791  +    oo::configurable create Point {superclass parent}
          792  +    list [catch {oo::define Point {property x -set}} msg opt] \
          793  +	[dict get $opt -errorinfo] [dict get $opt -errorcode]
          794  +} -cleanup {
          795  +    parent destroy
          796  +} -result {1 {missing body to go with -set option
          797  +    while executing
          798  +"property x -set"
          799  +    (in definition script for class "::Point" line 1)
          800  +    invoked from within
          801  +"oo::define Point {property x -set}"} {TCL WRONGARGS}}
          802  +test ooProp-4.4 {TIP 558: properties: error details} -setup {
          803  +    oo::class create parent
          804  +    unset -nocomplain msg opt
          805  +} -body {
          806  +    oo::configurable create Point {superclass parent}
          807  +    list [catch {oo::define Point {property x -kind}} msg opt] \
          808  +	[dict get $opt -errorinfo] [dict get $opt -errorcode]
          809  +} -cleanup {
          810  +    parent destroy
          811  +} -result {1 {missing kind value to go with -kind option
          812  +    while executing
          813  +"property x -kind"
          814  +    (in definition script for class "::Point" line 1)
          815  +    invoked from within
          816  +"oo::define Point {property x -kind}"} {TCL WRONGARGS}}
          817  +test ooProp-4.5 {TIP 558: properties: error details} -setup {
          818  +    oo::class create parent
          819  +    unset -nocomplain msg opt
          820  +} -body {
          821  +    oo::configurable create Point {superclass parent}
          822  +    list [catch {oo::define Point {property x -kind gorp}} msg opt] \
          823  +	[dict get $opt -errorinfo] [dict get $opt -errorcode]
          824  +} -cleanup {
          825  +    parent destroy
          826  +} -result {1 {bad kind "gorp": must be readable, readwrite, or writable
          827  +    while executing
          828  +"property x -kind gorp"
          829  +    (in definition script for class "::Point" line 1)
          830  +    invoked from within
          831  +"oo::define Point {property x -kind gorp}"} {TCL LOOKUP INDEX kind gorp}}
          832  +test ooProp-4.6 {TIP 558: properties: error details} -setup {
          833  +    oo::class create parent
          834  +    unset -nocomplain msg opt
          835  +} -body {
          836  +    oo::configurable create Point {superclass parent}
          837  +    list [catch {oo::define Point {property x -gorp}} msg opt] \
          838  +	[dict get $opt -errorinfo] [dict get $opt -errorcode]
          839  +} -cleanup {
          840  +    parent destroy
          841  +} -result {1 {bad option "-gorp": must be -get, -kind, or -set
          842  +    while executing
          843  +"property x -gorp"
          844  +    (in definition script for class "::Point" line 1)
          845  +    invoked from within
          846  +"oo::define Point {property x -gorp}"} {TCL LOOKUP INDEX option -gorp}}
          847  +test ooProp-4.7 {TIP 558: properties: error details} -setup {
          848  +    oo::class create parent
          849  +    unset -nocomplain msg opt
          850  +} -body {
          851  +    oo::configurable create Point {
          852  +	superclass parent
          853  +	property x
          854  +    }
          855  +    Point create pt
          856  +    list [catch {pt configure -gorp} msg opt] \
          857  +	[dict get $opt -errorinfo] [dict get $opt -errorcode]
          858  +} -cleanup {
          859  +    parent destroy
          860  +} -result {1 {bad property "-gorp": must be -x
          861  +    while executing
          862  +"pt configure -gorp"} {TCL LOOKUP INDEX property -gorp}}
          863  +test ooProp-4.8 {TIP 558: properties: error details} -setup {
          864  +    oo::class create parent
          865  +    unset -nocomplain msg opt
          866  +} -body {
          867  +    oo::configurable create Point {
          868  +	superclass parent
          869  +	property x
          870  +    }
          871  +    Point create pt
          872  +    list [catch {pt configure -gorp blarg} msg opt] \
          873  +	[dict get $opt -errorinfo] [dict get $opt -errorcode]
          874  +} -cleanup {
          875  +    parent destroy
          876  +} -result {1 {bad property "-gorp": must be -x
          877  +    while executing
          878  +"pt configure -gorp blarg"} {TCL LOOKUP INDEX property -gorp}}
          879  +
          880  +cleanupTests
          881  +return
          882  +
          883  +# Local Variables:
          884  +# mode: tcl
          885  +# End:

Changes to tools/tclOOScript.tcl.

     1      1   # tclOOScript.h --
     2      2   #
     3      3   # 	This file contains support scripts for TclOO. They are defined here so
     4      4   # 	that the code can be definitely run even in safe interpreters; TclOO's
     5      5   # 	core setup is safe.
     6      6   #
     7         -# Copyright (c) 2012-2018 Donal K. Fellows
            7  +# Copyright (c) 2012-2019 Donal K. Fellows
     8      8   # Copyright (c) 2013 Andreas Kupries
     9      9   # Copyright (c) 2017 Gerald Lester
    10     10   #
    11     11   # See the file "license.terms" for information on usage and redistribution of
    12     12   # this file, and for a DISCLAIMER OF ALL WARRANTIES.
    13     13   
    14     14   ::namespace eval ::oo {
    15     15       ::namespace path {}
    16     16   
    17     17       #
    18     18       # Commands that are made available to objects by default.
    19     19       #
    20     20       namespace eval Helpers {
    21         -	::namespace path {}
           21  +	namespace path {}
    22     22   
    23     23   	# ------------------------------------------------------------------
    24     24   	#
    25     25   	# callback, mymethod --
    26     26   	#
    27     27   	#	Create a script prefix that calls a method on the current
    28     28   	#	object. Same operation, two names.
................................................................................
   149    149   	    return
   150    150   	}
   151    151   	foreach c [info class superclass $class] {
   152    152   	    set d [DelegateName $c]
   153    153   	    if {![info object isa class $d]} {
   154    154   		continue
   155    155   	    }
   156         -	    define $delegate ::oo::define::superclass -append $d
          156  +	    define $delegate ::oo::define::superclass -appendifnew $d
   157    157   	}
   158         -	objdefine $class ::oo::objdefine::mixin -append $delegate
          158  +	objdefine $class ::oo::objdefine::mixin -appendifnew $delegate
   159    159       }
   160    160   
   161    161       # ----------------------------------------------------------------------
   162    162       #
   163    163       # UpdateClassDelegatesAfterClone --
   164    164       #
   165    165       #	Support code that is like [MixinClassDelegates] except for when a
................................................................................
   253    253   	#
   254    254   	#	Basic slot getter. Retrieves the contents of the slot.
   255    255   	#	Particular slots must provide concrete non-erroring
   256    256   	#	implementation.
   257    257   	#
   258    258   	# ------------------------------------------------------------------
   259    259   
   260         -	method Get {} {
          260  +	method Get -unexport {} {
   261    261   	    return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
   262    262   	}
   263    263   
   264    264   	# ------------------------------------------------------------------
   265    265   	#
   266    266   	# Slot Set --
   267    267   	#
   268    268   	#	Basic slot setter. Sets the contents of the slot.  Particular
   269    269   	#	slots must provide concrete non-erroring implementation.
   270    270   	#
   271    271   	# ------------------------------------------------------------------
   272    272   
   273         -	method Set list {
          273  +	method Set -unexport list {
   274    274   	    return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
   275    275   	}
   276    276   
   277    277   	# ------------------------------------------------------------------
   278    278   	#
   279    279   	# Slot Resolve --
   280    280   	#
   281    281   	#	Helper that lets a slot convert a list of arguments of a
   282    282   	#	particular type to their canonical forms. Defaults to doing
   283    283   	#	nothing (suitable for simple strings).
   284    284   	#
   285    285   	# ------------------------------------------------------------------
   286    286   
   287         -	method Resolve list {
          287  +	method Resolve -unexport list {
   288    288   	    return $list
   289    289   	}
   290    290   
   291    291   	# ------------------------------------------------------------------
   292    292   	#
   293    293   	# Slot -set, -append, -clear, --default-operation --
   294    294   	#
   295    295   	#	Standard public slot operations. If a slot can't figure out
   296    296   	#	what method to call directly, it uses --default-operation.
   297    297   	#
   298    298   	# ------------------------------------------------------------------
   299    299   
   300         -	method -set args {
          300  +	method -set -export args {
   301    301   	    set my [namespace which my]
   302    302   	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
   303    303   	    tailcall my Set $args
   304    304   	}
   305         -	method -append args {
          305  +	method -append -export args {
   306    306   	    set my [namespace which my]
   307    307   	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
   308    308   	    set current [uplevel 1 [list $my Get]]
   309    309   	    tailcall my Set [list {*}$current {*}$args]
   310    310   	}
   311         -	method -clear {} {tailcall my Set {}}
   312         -	method -prepend args {
          311  +	method -appendifnew -export args {
          312  +	    set my [namespace which my]
          313  +	    set current [uplevel 1 [list $my Get]]
          314  +	    foreach a $args {
          315  +		set a [uplevel 1 [list $my Resolve $a]]
          316  +		if {$a ni $current} {
          317  +		    lappend current $a
          318  +		}
          319  +	    }
          320  +	    tailcall my Set $current
          321  +	}
          322  +	method -clear -export {} {tailcall my Set {}}
          323  +	method -prepend -export args {
   313    324   	    set my [namespace which my]
   314    325   	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
   315    326   	    set current [uplevel 1 [list $my Get]]
   316    327   	    tailcall my Set [list {*}$args {*}$current]
   317    328   	}
   318         -	method -remove args {
          329  +	method -remove -export args {
   319    330   	    set my [namespace which my]
   320    331   	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
   321    332   	    set current [uplevel 1 [list $my Get]]
   322    333   	    tailcall my Set [lmap val $current {
   323    334   		if {$val in $args} continue else {set val}
   324    335   	    }]
   325    336   	}
   326    337   
   327    338   	# Default handling
   328    339   	forward --default-operation my -append
   329         -	method unknown {args} {
          340  +	method unknown -unexport {args} {
   330    341   	    set def --default-operation
   331    342   	    if {[llength $args] == 0} {
   332    343   		tailcall my $def
   333    344   	    } elseif {![string match -* [lindex $args 0]]} {
   334    345   		tailcall my $def {*}$args
   335    346   	    }
   336    347   	    next {*}$args
   337    348   	}
   338    349   
   339         -	# Set up what is exported and what isn't
   340         -	export -set -append -clear -prepend -remove
   341         -	unexport unknown destroy
          350  +	# Hide destroy
          351  +	unexport destroy
   342    352       }
   343    353   
   344    354       # Set the default operation differently for these slots
   345    355       objdefine define::superclass forward --default-operation my -set
   346    356       objdefine define::mixin forward --default-operation my -set
   347    357       objdefine objdefine::mixin forward --default-operation my -set
   348    358   
................................................................................
   352    362       #
   353    363       #	Handler for cloning objects that clones basic bits (only!) of the
   354    364       #	object's namespace. Non-procedures, traces, sub-namespaces, etc. need
   355    365       #	more complex (and class-specific) handling.
   356    366       #
   357    367       # ----------------------------------------------------------------------
   358    368   
   359         -    define object method <cloned> {originObject} {
          369  +    define object method <cloned> -unexport {originObject} {
   360    370   	# Copy over the procedures from the original namespace
   361    371   	foreach p [info procs [info object namespace $originObject]::*] {
   362    372   	    set args [info args $p]
   363    373   	    set idx -1
   364    374   	    foreach a $args {
   365    375   		if {[info default $p $a d]} {
   366    376   		    lset args [incr idx] [list $a $d]
................................................................................
   393    403       #
   394    404       # oo::class <cloned> --
   395    405       #
   396    406       #	Handler for cloning classes, which fixes up the delegates.
   397    407       #
   398    408       # ----------------------------------------------------------------------
   399    409   
   400         -    define class method <cloned> {originObject} {
          410  +    define class method <cloned> -unexport {originObject} {
   401    411   	next $originObject
   402    412   	# Rebuild the class inheritance delegation class
   403    413   	::oo::UpdateClassDelegatesAfterClone $originObject [self]
   404    414       }
   405    415   
   406    416       # ----------------------------------------------------------------------
   407    417       #
................................................................................
   420    430   	    if {![info exists object] || ![info object isa object $object]} {
   421    431   		set object [next {*}$args]
   422    432   		::oo::objdefine $object {
   423    433   		    method destroy {} {
   424    434   			::return -code error -errorcode {TCLOO SINGLETON} \
   425    435   			    "may not destroy a singleton object"
   426    436   		    }
   427         -		    method <cloned> {originObject} {
          437  +		    method <cloned> -unexport {originObject} {
   428    438   			::return -code error -errorcode {TCLOO SINGLETON} \
   429    439   			    "may not clone a singleton object"
   430    440   		    }
   431    441   		}
   432    442   	    }
   433    443   	    return $object
   434    444   	}
................................................................................
   443    453       #
   444    454       # ----------------------------------------------------------------------
   445    455   
   446    456       class create abstract {
   447    457   	superclass class
   448    458   	unexport create createWithNamespace new
   449    459       }
          460  +
          461  +    # ----------------------------------------------------------------------
          462  +    #
          463  +    # oo::configuresupport --
          464  +    #
          465  +    #	Namespace that holds all the implementation details of TIP #558.
          466  +    #	Also includes the commands:
          467  +    #
          468  +    #	 * readableproperties
          469  +    #	 * writableproperties
          470  +    #	 * objreadableproperties
          471  +    #	 * objwritableproperties
          472  +    #
          473  +    #	Those are all slot implementations that provide access to the C layer
          474  +    #	of property support (i.e., very fast cached lookup of property names).
          475  +    #
          476  +    # ----------------------------------------------------------------------
          477  +
          478  +    ::namespace eval configuresupport {
          479  +	namespace path ::tcl
          480  +
          481  +	# ------------------------------------------------------------------
          482  +	#
          483  +	# oo::configuresupport --
          484  +	#
          485  +	#	A metaclass that is used to make classes that can be configured.
          486  +	#
          487  +	# ------------------------------------------------------------------
          488  +
          489  +	proc PropertyImpl {readslot writeslot args} {
          490  +	    for {set i 0} {$i < [llength $args]} {incr i} {
          491  +		# Parse the property name
          492  +		set prop [lindex $args $i]
          493  +		if {[string match "-*" $prop]} {
          494  +		    return -code error -level 2 \
          495  +			-errorcode {TCLOO PROPERTY_FORMAT} \
          496  +			"bad property name \"$prop\": must not begin with -"
          497  +		}
          498  +		if {$prop ne [list $prop]} {
          499  +		    return -code error -level 2 \
          500  +			-errorcode {TCLOO PROPERTY_FORMAT} \
          501  +			"bad property name \"$prop\": must be a simple word"
          502  +		}
          503  +		if {[string first "::" $prop] != -1} {
          504  +		    return -code error -level 2 \
          505  +			-errorcode {TCLOO PROPERTY_FORMAT} \
          506  +			"bad property name \"$prop\": must not contain namespace separators"
          507  +		}
          508  +		if {[string match {*[()]*} $prop]} {
          509  +		    return -code error -level 2 \
          510  +			-errorcode {TCLOO PROPERTY_FORMAT} \
          511  +			"bad property name \"$prop\": must not contain parentheses"
          512  +		}
          513  +		set realprop [string cat "-" $prop]
          514  +		set getter [format {::set [my varname %s]} $prop]
          515  +		set setter [format {::set [my varname %s] $value} $prop]
          516  +		set kind readwrite
          517  +
          518  +		# Parse the extra options
          519  +		while {[set next [lindex $args [expr {$i + 1}]]
          520  +			string match "-*" $next]} {
          521  +		    set arg [lindex $args [incr i 2]]
          522  +		    switch [prefix match -error [list -level 2 -errorcode \
          523  +			    [list TCL LOOKUP INDEX option $next]] {-get -kind -set} $next] {
          524  +			-get {
          525  +			    if {$i >= [llength $args]} {
          526  +				return -code error -level 2 \
          527  +				    -errorcode {TCL WRONGARGS} \
          528  +				    "missing body to go with -get option"
          529  +			    }
          530  +			    set getter $arg
          531  +			}
          532  +			-set {
          533  +			    if {$i >= [llength $args]} {
          534  +				return -code error -level 2 \
          535  +				    -errorcode {TCL WRONGARGS} \
          536  +				    "missing body to go with -set option"
          537  +			    }
          538  +			    set setter $arg
          539  +			}
          540  +			-kind {
          541  +			    if {$i >= [llength $args]} {
          542  +				return -code error -level 2\
          543  +				    -errorcode {TCL WRONGARGS} \
          544  +				    "missing kind value to go with -kind option"
          545  +			    }
          546  +			    set kind [prefix match -message "kind" -error [list \
          547  +				    -level 2 \
          548  +				    -errorcode [list TCL LOOKUP INDEX kind $arg]] {
          549  +				readable readwrite writable
          550  +			    } $arg]
          551  +			}
          552  +		    }
          553  +		}
          554  +
          555  +		# Install the option
          556  +		set reader <ReadProp$realprop>
          557  +		set writer <WriteProp$realprop>
          558  +		switch $kind {
          559  +		    readable {
          560  +			uplevel 2 [list $readslot -append $realprop]
          561  +			uplevel 2 [list $writeslot -remove $realprop]
          562  +			uplevel 2 [list method $reader -unexport {} $getter]
          563  +		    }
          564  +		    writable {
          565  +			uplevel 2 [list $readslot -remove $realprop]
          566  +			uplevel 2 [list $writeslot -append $realprop]
          567  +			uplevel 2 [list method $writer -unexport {value} $setter]
          568  +		    }
          569  +		    readwrite {
          570  +			uplevel 2 [list $readslot -append $realprop]
          571  +			uplevel 2 [list $writeslot -append $realprop]
          572  +			uplevel 2 [list method $reader -unexport {} $getter]
          573  +			uplevel 2 [list method $writer -unexport {value} $setter]
          574  +		    }
          575  +		}
          576  +	    }
          577  +	}
          578  +
          579  +	# ------------------------------------------------------------------
          580  +	#
          581  +	# oo::configuresupport::configurableclass,
          582  +	# oo::configuresupport::configurableobject --
          583  +	#
          584  +	#	Namespaces used as implementation vectors for oo::define and
          585  +	#	oo::objdefine when the class/instance is configurable.
          586  +	# 
          587  +	# ------------------------------------------------------------------
          588  +
          589  +	namespace eval configurableclass {
          590  +	    ::proc property args {
          591  +		::oo::configuresupport::PropertyImpl \
          592  +		    ::oo::configuresupport::readableproperties \
          593  +		    ::oo::configuresupport::writableproperties {*}$args
          594  +	    }
          595  +	    # Plural alias just in case; deliberately NOT documented!
          596  +	    ::proc properties args {::tailcall property {*}$args}
          597  +	    ::namespace path ::oo::define
          598  +	    ::namespace export property
          599  +	}
          600  +
          601  +	namespace eval configurableobject {
          602  +	    ::proc property args {
          603  +		::oo::configuresupport::PropertyImpl \
          604  +		    ::oo::configuresupport::objreadableproperties \
          605  +		    ::oo::configuresupport::objwritableproperties {*}$args
          606  +	    }
          607  +	    # Plural alias just in case; deliberately NOT documented!
          608  +	    ::proc properties args {::tailcall property {*}$args}
          609  +	    ::namespace path ::oo::objdefine
          610  +	    ::namespace export property
          611  +	}
          612  +
          613  +	# ------------------------------------------------------------------
          614  +	#
          615  +	# oo::configuresupport::ReadAll --
          616  +	#
          617  +	#	The implementation of [$o configure] with no extra arguments.
          618  +	#
          619  +	# ------------------------------------------------------------------
          620  +
          621  +	proc ReadAll {object my} {
          622  +	    set result {}
          623  +	    foreach prop [info object properties $object -all -readable] {
          624  +		try {
          625  +		    dict set result $prop [$my <ReadProp$prop>]
          626  +		} on error {msg opt} {
          627  +		    dict set opt -level 2
          628  +		    return -options $opt $msg
          629  +		} on return {msg opt} {
          630  +		    dict incr opt -level 2
          631  +		    return -options $opt $msg
          632  +		} on break {} {
          633  +		    return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
          634  +			"property getter for $prop did a break"
          635  +		} on continue {} {
          636  +		    return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
          637  +			"property getter for $prop did a continue"
          638  +		}
          639  +	    }
          640  +	    return $result
          641  +	}
          642  +
          643  +	# ------------------------------------------------------------------
          644  +	#
          645  +	# oo::configuresupport::ReadOne --
          646  +	#
          647  +	#	The implementation of [$o configure -prop] with that single
          648  +	#	extra argument.
          649  +	#
          650  +	# ------------------------------------------------------------------
          651  +
          652  +	proc ReadOne {object my propertyName} {
          653  +	    set props [info object properties $object -all -readable]
          654  +	    try {
          655  +		set prop [prefix match -message "property" $props $propertyName]
          656  +	    } on error {msg} {
          657  +		catch {
          658  +		    set wps [info object properties $object -all -writable]
          659  +		    set wprop [prefix match $wps $propertyName]
          660  +		    set msg "property \"$wprop\" is write only"
          661  +		}
          662  +		return -code error -level 2 -errorcode [list \
          663  +			TCL LOOKUP INDEX property $propertyName] $msg
          664  +	    }
          665  +	    try {
          666  +		set value [$my <ReadProp$prop>]
          667  +	    } on error {msg opt} {
          668  +		dict set opt -level 2
          669  +		return -options $opt $msg
          670  +	    } on return {msg opt} {
          671  +		dict incr opt -level 2
          672  +		return -options $opt $msg
          673  +	    } on break {} {
          674  +		return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
          675  +		    "property getter for $prop did a break"
          676  +	    } on continue {} {
          677  +		return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
          678  +		    "property getter for $prop did a continue"
          679  +	    }
          680  +	    return $value
          681  +	}
          682  +
          683  +	# ------------------------------------------------------------------
          684  +	#
          685  +	# oo::configuresupport::WriteMany --
          686  +	#
          687  +	#	The implementation of [$o configure -prop val ?-prop val...?].
          688  +	#
          689  +	# ------------------------------------------------------------------
          690  +
          691  +	proc WriteMany {object my setterMap} {
          692  +	    set props [info object properties $object -all -writable]
          693  +	    foreach {prop value} $setterMap {
          694  +		try {
          695  +		    set prop [prefix match -message "property" $props $prop]
          696  +		} on error {msg} {
          697  +		    catch {
          698  +			set rps [info object properties $object -all -readable]
          699  +			set rprop [prefix match $rps $prop]
          700  +			set msg "property \"$rprop\" is read only"
          701  +		    }
          702  +		    return -code error -level 2 -errorcode [list \
          703  +			    TCL LOOKUP INDEX property $prop] $msg
          704  +		}
          705  +		try {
          706  +		    $my <WriteProp$prop> $value
          707  +		} on error {msg opt} {
          708  +		    dict set opt -level 2
          709  +		    return -options $opt $msg
          710  +		} on return {msg opt} {
          711  +		    dict incr opt -level 2
          712  +		    return -options $opt $msg
          713  +		} on break {} {
          714  +		    return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
          715  +			"property setter for $prop did a break"
          716  +		} on continue {} {
          717  +		    return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
          718  +			"property setter for $prop did a continue"
          719  +		}
          720  +	    }
          721  +	    return
          722  +	}
          723  +
          724  +	# ------------------------------------------------------------------
          725  +	#
          726  +	# oo::configuresupport::configurable --
          727  +	#
          728  +	#	The class that contains the implementation of the actual
          729  +	#	'configure' method (mixed into actually configurable classes).
          730  +	#	Great care needs to be taken in these methods as they are
          731  +	#	potentially used in classes where the current namespace is set
          732  +	#	up very strangely.
          733  +	#
          734  +	# ------------------------------------------------------------------
          735  +
          736  +	::oo::class create configurable {
          737  +	    private variable my
          738  +	    #
          739  +	    # configure --
          740  +	    #	Method for providing client access to the property mechanism.
          741  +	    #	Has a user-facing API similar to that of [chan configure].
          742  +	    # 
          743  +	    method configure -export args {
          744  +		::if {![::info exists my]} {
          745  +		    ::set my [::namespace which my]
          746  +		}
          747  +		::if {[::llength $args] == 0} {
          748  +		    # Read all properties
          749  +		    ::oo::configuresupport::ReadAll [self] $my
          750  +		} elseif {[::llength $args] == 1} {
          751  +		    # Read a single property
          752  +		    ::oo::configuresupport::ReadOne [self] $my \
          753  +			[::lindex $args 0]
          754  +		} elseif {[::llength $args] % 2 == 0} {
          755  +		    # Set properties, one or several
          756  +		    ::oo::configuresupport::WriteMany [self] $my $args
          757  +		} else {
          758  +		    # Invalid call
          759  +		    ::return -code error -errorcode {TCL WRONGARGS} \
          760  +			[::format {wrong # args: should be "%s"} \
          761  +			    "[self] configure ?-option value ...?"]
          762  +		}
          763  +	    }
          764  +
          765  +	    definitionnamespace -instance configurableobject
          766  +	    definitionnamespace -class configurableclass
          767  +	}
          768  +    }
          769  +
          770  +    # ----------------------------------------------------------------------
          771  +    #
          772  +    # oo::configurable --
          773  +    #
          774  +    #	A metaclass that is used to make classes that can be configured in
          775  +    #	their creation phase (and later too). All the metaclass itself does is
          776  +    #	arrange for the class created to have a 'configure' method and for
          777  +    #	oo::define and oo::objdefine (on the class and its instances) to have
          778  +    #	a property definition for setting things up for 'configure'.
          779  +    #
          780  +    # ----------------------------------------------------------------------
          781  +
          782  +    class create configurable {
          783  +	superclass class
          784  +
          785  +	constructor {{definitionScript ""}} {
          786  +	    next {mixin ::oo::configuresupport::configurable}
          787  +	    next $definitionScript
          788  +	}
          789  +
          790  +	definitionnamespace -class configuresupport::configurableclass
          791  +    }
   450    792   }
   451    793   
   452    794   # Local Variables:
   453    795   # mode: tcl
   454    796   # c-basic-offset: 4
   455    797   # fill-column: 78
   456    798   # End: