Tcl Source Code

Changes On Branch tip-500
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-500 Excluding Merge-Ins

This is equivalent to a diff from dade30b4a0 to 3419afb49d

2018-06-03
11:44
TIP 500: Private Methods and Variables in TclOO check-in: 86262924a2 user: dkf tags: core-8-branch
2018-06-02
14:19
merge core-8-branch Closed-Leaf check-in: 3419afb49d user: dkf tags: tip-500
2018-06-01
16:04
Rebase the sebres clock bounty work to the 8.7 branch. check-in: 3e943144b9 user: dgp tags: dgp-sebres-clock-review
2018-05-31
19:23
merge 8.7 check-in: 0a613bfb94 user: dgp tags: core_zip_vfs
07:21
Merge 8.7 check-in: 3fb815ef5f user: jan.nijtmans tags: initsubsystems
07:18
merge 8.7 check-in: 7173f591b6 user: jan.nijtmans tags: trunk
07:17
Neither use --disable-threads on MacOS builds, and don't mention it any more in the README check-in: dade30b4a0 user: jan.nijtmans tags: core-8-branch
2018-05-30
09:38
Tweaking the documentation check-in: d65f77c5b5 user: dkf tags: tip-500
07:15
No longer pass "--enable-threads" to battery-included sub-packages, since it's the default, even wh... check-in: 552b9e73d7 user: jan.nijtmans tags: core-8-branch

Changes to doc/Method.3.

     5      5   '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
     6      6   '\"
     7      7   .TH Tcl_Method 3 0.1 TclOO "TclOO Library Functions"
     8      8   .so man.macros
     9      9   .BS
    10     10   '\" Note:  do not modify the .SH NAME line immediately below!
    11     11   .SH NAME
    12         -Tcl_ClassSetConstructor, Tcl_ClassSetDestructor, Tcl_MethodDeclarerClass, Tcl_MethodDeclarerObject, Tcl_MethodIsPublic, Tcl_MethodIsType, Tcl_MethodName, Tcl_NewInstanceMethod, Tcl_NewMethod, Tcl_ObjectContextInvokeNext, Tcl_ObjectContextIsFiltering, Tcl_ObjectContextMethod, Tcl_ObjectContextObject, Tcl_ObjectContextSkippedArgs \- manipulate methods and method-call contexts
           12  +Tcl_ClassSetConstructor, Tcl_ClassSetDestructor, Tcl_MethodDeclarerClass, Tcl_MethodDeclarerObject, Tcl_MethodIsPublic, Tcl_MethodIsPrivate, Tcl_MethodIsType, Tcl_MethodName, Tcl_NewInstanceMethod, Tcl_NewMethod, Tcl_ObjectContextInvokeNext, Tcl_ObjectContextIsFiltering, Tcl_ObjectContextMethod, Tcl_ObjectContextObject, Tcl_ObjectContextSkippedArgs \- manipulate methods and method-call contexts
    13     13   .SH SYNOPSIS
    14     14   .nf
    15     15   \fB#include <tclOO.h>\fR
    16     16   .sp
    17     17   Tcl_Method
    18         -\fBTcl_NewMethod\fR(\fIinterp, class, nameObj, isPublic,
    19         -              methodTypePtr, clientData\fR)
           18  +\fBTcl_NewMethod\fR(\fIinterp, class, nameObj, flags, methodTypePtr,
           19  +              clientData\fR)
    20     20   .sp
    21     21   Tcl_Method
    22         -\fBTcl_NewInstanceMethod\fR(\fIinterp, object, nameObj, isPublic,
    23         -                      methodTypePtr, clientData\fR)
           22  +\fBTcl_NewInstanceMethod\fR(\fIinterp, object, nameObj, flags, methodTypePtr,
           23  +                      clientData\fR)
    24     24   .sp
    25     25   \fBTcl_ClassSetConstructor\fR(\fIinterp, class, method\fR)
    26     26   .sp
    27     27   \fBTcl_ClassSetDestructor\fR(\fIinterp, class, method\fR)
    28     28   .sp
    29     29   Tcl_Class
    30     30   \fBTcl_MethodDeclarerClass\fR(\fImethod\fR)
................................................................................
    31     31   .sp
    32     32   Tcl_Object
    33     33   \fBTcl_MethodDeclarerObject\fR(\fImethod\fR)
    34     34   .sp
    35     35   Tcl_Obj *
    36     36   \fBTcl_MethodName\fR(\fImethod\fR)
    37     37   .sp
           38  +.VS TIP500
    38     39   int
    39     40   \fBTcl_MethodIsPublic\fR(\fImethod\fR)
           41  +.VE TIP500
           42  +.sp
           43  +int
           44  +\fBTcl_MethodIsPrivate\fR(\fImethod\fR)
    40     45   .sp
    41     46   int
    42     47   \fBTcl_MethodIsType\fR(\fImethod, methodTypePtr, clientDataPtr\fR)
    43     48   .sp
    44     49   int
    45     50   \fBTcl_ObjectContextInvokeNext\fR(\fIinterp, context, objc, objv, skip\fR)
    46     51   .sp
................................................................................
    62     67   .AP Tcl_Object object in
    63     68   The object to create the method in.
    64     69   .AP Tcl_Class class in
    65     70   The class to create the method in.
    66     71   .AP Tcl_Obj *nameObj in
    67     72   The name of the method to create. Should not be NULL unless creating
    68     73   constructors or destructors.
    69         -.AP int isPublic in
    70         -A flag saying what the visibility of the method is. The only supported public
    71         -values of this flag are 0 for a non-exported method, and 1 for an exported
    72         -method.
           74  +.AP int flags in
           75  +A flag saying (currently) what the visibility of the method is. The supported
           76  +public values of this flag are \fBTCL_OO_METHOD_PUBLIC\fR (which is fixed at 1
           77  +for backward compatibility) for an exported method,
           78  +\fBTCL_OO_METHOD_UNEXPORTED\fR (which is fixed at 0 for backward
           79  +compatibility) for a non-exported method,
           80  +.VS TIP500
           81  +and \fBTCL_OO_METHOD_PRIVATE\fR for a private method.
           82  +.VE TIP500
    73     83   .AP Tcl_MethodType *methodTypePtr in
    74     84   A description of the type of the method to create, or the type of method to
    75     85   compare against.
    76     86   .AP ClientData clientData in
    77     87   A piece of data that is passed to the implementation of the method without
    78     88   interpretation.
    79     89   .AP ClientData *clientDataPtr out
................................................................................
   101    111   that class.
   102    112   .PP
   103    113   Given a method, the entity that declared it can be found using
   104    114   \fBTcl_MethodDeclarerClass\fR which returns the class that the method is
   105    115   attached to (or NULL if the method is not attached to any class) and
   106    116   \fBTcl_MethodDeclarerObject\fR which returns the object that the method is
   107    117   attached to (or NULL if the method is not attached to an object). The name of
   108         -the method can be retrieved with \fBTcl_MethodName\fR and whether the method
   109         -is exported is retrieved with \fBTcl_MethodIsPublic\fR. The type of the method
          118  +the method can be retrieved with \fBTcl_MethodName\fR, whether the method
          119  +is exported is retrieved with \fBTcl_MethodIsPublic\fR,
          120  +.VS TIP500
          121  +and whether the method is private is retrieved with \fBTcl_MethodIsPrivate\fR.
          122  +.VE TIP500
          123  +The type of the method
   110    124   can also be introspected upon to a limited degree; the function
   111    125   \fBTcl_MethodIsType\fR returns whether a method is of a particular type,
   112    126   assigning the per-method \fIclientData\fR to the variable pointed to by
   113    127   \fIclientDataPtr\fR if (that is non-NULL) if the type is matched.
   114    128   .SS "METHOD CREATION"
   115    129   .PP
   116    130   Methods are created by \fBTcl_NewMethod\fR and \fBTcl_NewInstanceMethod\fR,
   117    131   which
   118    132   create a method attached to a class or an object respectively. In both cases,
   119    133   the \fInameObj\fR argument gives the name of the method to create, the
   120         -\fIisPublic\fR argument states whether the method should be exported
   121         -initially, the \fImethodTypePtr\fR argument describes the implementation of
          134  +\fIflags\fR argument states whether the method should be exported
          135  +initially
          136  +.VS TIP500
          137  +or be marked as a private method,
          138  +.VE TIP500
          139  +the \fImethodTypePtr\fR argument describes the implementation of
   122    140   the method (see the \fBMETHOD TYPES\fR section below) and the \fIclientData\fR
   123    141   argument gives some implementation-specific data that is passed on to the
   124    142   implementation of the method when it is called.
   125    143   .PP
   126    144   When the \fInameObj\fR argument to \fBTcl_NewMethod\fR is NULL, an
   127    145   unnamed method is created, which is used for constructors and destructors.
   128    146   Constructors should be installed into their class using the

Changes to doc/define.n.

    78     78   This arranges for each of the named methods, \fIname\fR, to be exported
    79     79   (i.e. usable outside an instance through the instance object's command) by the
    80     80   class being defined. Note that the methods themselves may be actually defined
    81     81   by a superclass; subclass exports override superclass visibility, and may in
    82     82   turn be overridden by instances.
    83     83   .TP
    84     84   \fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
    85         -.VS
           85  +.
    86     86   This slot (see \fBSLOTTED DEFINITIONS\fR below)
    87         -.VE
    88     87   sets or updates the list of method names that are used to guard whether
    89     88   method call to instances of the class may be called and what the method's
    90     89   results are. Each \fImethodName\fR names a single filtering method (which may
    91     90   be exposed or not exposed); it is not an error for a non-existent method to be
    92     91   named since they may be defined by subclasses.
    93         -.VS
    94     92   By default, this slot works by appending.
    95         -.VE
    96     93   .TP
    97     94   \fBforward\fI name cmdName \fR?\fIarg ...\fR?
    98     95   .
    99     96   This creates or updates a forwarded method called \fIname\fR. The method is
   100     97   defined be forwarded to the command called \fIcmdName\fR, with additional
   101     98   arguments, \fIarg\fR etc., added before those arguments specified by the
   102     99   caller of the method. The \fIcmdName\fR will always be resolved using the
   103    100   rules of the invoking objects' namespaces, i.e., when \fIcmdName\fR is not
   104    101   fully-qualified, the command will be searched for in each object's namespace,
   105    102   using the instances' namespace's path, or by looking in the global namespace.
   106    103   The method will be exported if \fIname\fR starts with a lower-case letter, and
   107    104   non-exported otherwise.
          105  +.RS
          106  +.PP
          107  +.VS TIP500
          108  +If in a private definition context (see the \fBprivate\fR definition command,
          109  +below), this command creates private forwarded methods.
          110  +.VE TIP500
          111  +.RE
   108    112   .TP
   109    113   \fBmethod\fI name argList bodyScript\fR
   110    114   .
   111    115   This creates or updates a method that is implemented as a procedure-like
   112    116   script. The name of the method is \fIname\fR, the formal arguments to the
   113    117   method (defined using the same format as for the Tcl \fBproc\fR command) will
   114    118   be \fIargList\fR, and the body of the method will be \fIbodyScript\fR. When
   115    119   the body of the method is evaluated, the current namespace of the method will
   116    120   be a namespace that is unique to the current object. The method will be
   117    121   exported if \fIname\fR starts with a lower-case letter, and non-exported
   118    122   otherwise; this behavior can be overridden via \fBexport\fR and
   119    123   \fBunexport\fR.
          124  +.RS
          125  +.PP
          126  +.VS TIP500
          127  +If in a private definition context (see the \fBprivate\fR definition command,
          128  +below), this command creates private procedure-like methods.
          129  +.VE TIP500
          130  +.RE
   120    131   .TP
   121    132   \fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR?
   122         -.VS
          133  +.
   123    134   This slot (see \fBSLOTTED DEFINITIONS\fR below)
   124         -.VE
   125    135   sets or updates the list of additional classes that are to be mixed into
   126    136   all the instances of the class being defined. Each \fIclassName\fR argument
   127    137   names a single class that is to be mixed in.
   128         -.VS
   129    138   By default, this slot works by replacement.
   130         -.VE
          139  +.TP
          140  +\fBprivate \fIcmd arg...\fR
          141  +.TP
          142  +\fBprivate \fIscript\fR
          143  +.
          144  +.VS TIP500
          145  +This evaluates the \fIscript\fR (or the list of command and arguments given by
          146  +\fIcmd\fR and \fIarg\fRs) in a context where the definitions made on the
          147  +current class will be private definitions.
          148  +.RS
          149  +.PP
          150  +The following class definition commands are affected by \fBprivate\fR:
          151  +\fBforward\fR, \fBmethod\fR, \fBself\fR, and \fBvariable\fR. Nesting
          152  +\fBprivate\fR inside \fBprivate\fR has no cumulative effect; the innermost
          153  +definition context is just a private definition context. All other definition
          154  +commands have no difference in behavior when used in a private definition
          155  +context.
          156  +.RE
          157  +.VE TIP500
   131    158   .TP
   132    159   \fBrenamemethod\fI fromName toName\fR
   133    160   .
   134    161   This renames the method called \fIfromName\fR in a class to \fItoName\fR. The
   135    162   method must have previously existed in the class, and \fItoName\fR must not
   136    163   previously refer to a method in that class. Does not affect the superclasses
   137    164   of the class, nor does it affect the subclasses or instances of the class
................................................................................
   155    182   .QW "\fBoo::objdefine \fIcls subcommand ...\fR" .
   156    183   .RS
   157    184   .PP
   158    185   .VS TIP470
   159    186   If no arguments at all are used, this gives the name of the class currently
   160    187   being configured.
   161    188   .VE TIP470
          189  +.VS TIP500
          190  +If in a private definition context (see the \fBprivate\fR definition command,
          191  +below), the definitions on the class object will also be made in a private
          192  +definition context.
          193  +.VE TIP500
   162    194   .RE
   163    195   .TP
   164    196   \fBsuperclass\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR?
   165         -.VS
          197  +.
   166    198   This slot (see \fBSLOTTED DEFINITIONS\fR below)
   167         -.VE
   168    199   allows the alteration of the superclasses of the class being defined.
   169    200   Each \fIclassName\fR argument names one class that is to be a superclass of
   170    201   the defined class. Note that objects must not be changed from being classes to
   171    202   being non-classes or vice-versa, that an empty parent class is equivalent to
   172    203   \fBoo::object\fR, and that the parent classes of \fBoo::object\fR and
   173    204   \fBoo::class\fR may not be modified.
   174         -.VS
   175    205   By default, this slot works by replacement.
   176         -.VE
   177    206   .TP
   178    207   \fBunexport\fI name \fR?\fIname ...\fR?
   179    208   .
   180    209   This arranges for each of the named methods, \fIname\fR, to be not exported
   181    210   (i.e. not usable outside the instance through the instance object's command,
   182    211   but instead just through the \fBmy\fR command visible in each object's
   183    212   context) by the class being defined. Note that the methods themselves may be
   184    213   actually defined by a superclass; subclass unexports override superclass
   185    214   visibility, and may be overridden by instance unexports.
   186    215   .TP
   187    216   \fBvariable\fR ?\fI\-slotOperation\fR? ?\fIname ...\fR?
   188         -.VS
          217  +.
   189    218   This slot (see \fBSLOTTED DEFINITIONS\fR below) arranges for each of the named
   190    219   variables to be automatically made
   191    220   available in the methods, constructor and destructor declared by the class
   192    221   being defined. Each variable name must not have any namespace
   193    222   separators and must not look like an array access. All variables will be
   194         -actually present in the instance object on which the method is executed. Note
          223  +actually present in the namespace of the instance object on which the method
          224  +is executed. Note
   195    225   that the variable lists declared by a superclass or subclass are completely
   196    226   disjoint, as are variable lists declared by instances; the list of variable
   197    227   names is just for methods (and constructors and destructors) declared by this
   198    228   class. By default, this slot works by appending.
   199         -.VE
          229  +.RS
          230  +.PP
          231  +.VS TIP500
          232  +If in a private definition context (see the \fBprivate\fR definition command,
          233  +below), this slot manipulates the list of private variable bindings for this
          234  +class. In a private variable binding, the name of the variable within the
          235  +instance object is different to the name given in the definition; the name
          236  +used in the definition is the name that you use to access the variable within
          237  +the methods of this class, and the name of the variable in the instance
          238  +namespace has a unique prefix that makes accidental use from other classes
          239  +extremely unlikely.
          240  +.VE TIP500
          241  +.RE
   200    242   .SS "CONFIGURING OBJECTS"
   201    243   .PP
   202    244   The following commands are supported in the \fIdefScript\fR for
   203    245   \fBoo::objdefine\fR, each of which may also be used in the \fIsubcommand\fR
   204    246   form:
   205    247   .TP
   206    248   \fBclass\fI className\fR
................................................................................
   219    261   .
   220    262   This arranges for each of the named methods, \fIname\fR, to be exported
   221    263   (i.e. usable outside the object through the object's command) by the object
   222    264   being defined. Note that the methods themselves may be actually defined by a
   223    265   class or superclass; object exports override class visibility.
   224    266   .TP
   225    267   \fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
   226         -.VS
          268  +.
   227    269   This slot (see \fBSLOTTED DEFINITIONS\fR below)
   228         -.VE
   229    270   sets or updates the list of method names that are used to guard whether a
   230    271   method call to the object may be called and what the method's results are.
   231    272   Each \fImethodName\fR names a single filtering method (which may be exposed or
   232    273   not exposed); it is not an error for a non-existent method to be named. Note
   233    274   that the actual list of filters also depends on the filters set upon any
   234    275   classes that the object is an instance of.
   235         -.VS
   236    276   By default, this slot works by appending.
   237         -.VE
   238    277   .TP
   239    278   \fBforward\fI name cmdName \fR?\fIarg ...\fR?
   240    279   .
   241    280   This creates or updates a forwarded object method called \fIname\fR. The
   242    281   method is defined be forwarded to the command called \fIcmdName\fR, with
   243    282   additional arguments, \fIarg\fR etc., added before those arguments specified
   244    283   by the caller of the method. Forwarded methods should be deleted using the
   245    284   \fBmethod\fR subcommand. The method will be exported if \fIname\fR starts with
   246    285   a lower-case letter, and non-exported otherwise.
          286  +.RS
          287  +.PP
          288  +.VS TIP500
          289  +If in a private definition context (see the \fBprivate\fR definition command,
          290  +below), this command creates private forwarded methods.
          291  +.VE TIP500
          292  +.RE
   247    293   .TP
   248    294   \fBmethod\fI name argList bodyScript\fR
   249    295   .
   250    296   This creates, updates or deletes an object method. The name of the method is
   251    297   \fIname\fR, the formal arguments to the method (defined using the same format
   252    298   as for the Tcl \fBproc\fR command) will be \fIargList\fR, and the body of the
   253    299   method will be \fIbodyScript\fR. When the body of the method is evaluated, the
   254    300   current namespace of the method will be a namespace that is unique to the
   255    301   object. The method will be exported if \fIname\fR starts with a lower-case
   256    302   letter, and non-exported otherwise.
          303  +.RS
          304  +.PP
          305  +.VS TIP500
          306  +If in a private definition context (see the \fBprivate\fR definition command,
          307  +below), this command creates private procedure-like methods.
          308  +.VE TIP500
          309  +.RE
   257    310   .TP
   258    311   \fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR?
   259         -.VS
          312  +.
   260    313   This slot (see \fBSLOTTED DEFINITIONS\fR below)
   261         -.VE
   262    314   sets or updates a per-object list of additional classes that are to be
   263    315   mixed into the object. Each argument, \fIclassName\fR, names a single class
   264    316   that is to be mixed in.
   265         -.VS
   266    317   By default, this slot works by replacement.
   267         -.VE
          318  +.TP
          319  +\fBprivate \fIcmd arg...\fR
          320  +.TP
          321  +\fBprivate \fIscript\fR
          322  +.VS TIP500
          323  +This evaluates the \fIscript\fR (or the list of command and arguments given by
          324  +\fIcmd\fR and \fIarg\fRs) in a context where the definitions made on the
          325  +current object will be private definitions.
          326  +.RS
          327  +.PP
          328  +The following class definition commands are affected by \fBprivate\fR:
          329  +\fBforward\fR, \fBmethod\fR, and \fBvariable\fR. Nesting \fBprivate\fR inside
          330  +\fBprivate\fR has no cumulative effect; the innermost definition context is
          331  +just a private definition context. All other definition commands have no
          332  +difference in behavior when used in a private definition context.
          333  +.RE
          334  +.VE TIP500
   268    335   .TP
   269    336   \fBrenamemethod\fI fromName toName\fR
   270    337   .
   271    338   This renames the method called \fIfromName\fR in an object to \fItoName\fR.
   272    339   The method must have previously existed in the object, and \fItoName\fR must
   273    340   not previously refer to a method in that object. Does not affect the classes
   274    341   that the object is an instance of. Does not change the export status of the
   275    342   method; if it was exported before, it will be afterwards.
   276    343   .TP
   277    344   \fBself \fR
   278         -.
   279    345   .VS TIP470
   280    346   This gives the name of the object currently being configured.
   281    347   .VE TIP470
   282    348   .TP
   283    349   \fBunexport\fI name \fR?\fIname ...\fR?
   284    350   .
   285    351   This arranges for each of the named methods, \fIname\fR, to be not exported
   286    352   (i.e. not usable outside the object through the object's command, but instead
   287    353   just through the \fBmy\fR command visible in the object's context) by the
   288    354   object being defined. Note that the methods themselves may be actually defined
   289    355   by a class; instance unexports override class visibility.
   290    356   .TP
   291    357   \fBvariable\fR ?\fI\-slotOperation\fR? ?\fIname ...\fR?
   292         -.VS
          358  +.
   293    359   This slot (see \fBSLOTTED DEFINITIONS\fR below) arranges for each of the named
   294    360   variables to be automatically made available in the methods declared by the
   295    361   object being defined.  Each variable name must not have any namespace
   296    362   separators and must not look like an array access. All variables will be
   297         -actually present in the object on which the method is executed. Note that the
          363  +actually present in the namespace of the object on which the method is
          364  +executed. Note that the
   298    365   variable lists declared by the classes and mixins of which the object is an
   299    366   instance are completely disjoint; the list of variable names is just for
   300    367   methods declared by this object. By default, this slot works by appending.
          368  +.RS
          369  +.PP
          370  +.VS TIP500
          371  +If in a private definition context (see the \fBprivate\fR definition command,
          372  +below), this slot manipulates the list of private variable bindings for this
          373  +object.  In a private variable binding, the name of the variable within the
          374  +instance object is different to the name given in the definition; the name
          375  +used in the definition is the name that you use to access the variable within
          376  +the methods of this instance object, and the name of the variable in the
          377  +instance namespace has a unique prefix that makes accidental use from
          378  +superclass methods extremely unlikely.
          379  +.VE TIP500
          380  +.RE
          381  +.SH "PRIVATE METHODS"
          382  +.VS TIP500
          383  +When a class or instance has a private method, that private method can only be
          384  +invoked from within methods of that class or instance. Other callers of the
          385  +object's methods \fIcannot\fR invoke private methods, it is as if the private
          386  +methods do not exist. However, a private method of a class \fIcan\fR be
          387  +invoked from the class's methods when those methods are being used on another
          388  +instance object; this means that a class can use them to coordinate behaviour
          389  +between several instances of itself without interfering with how other
          390  +classes (especially either subclasses or superclasses) interact. Private
          391  +methods precede all mixed in classes in the method call order (as reported by
          392  +\fBself call\fR).
          393  +.VE TIP500
   301    394   .SH "SLOTTED DEFINITIONS"
   302    395   Some of the configurable definitions of a class or object are \fIslotted
   303    396   definitions\fR. This means that the configuration is implemented by a slot
   304    397   object, that is an instance of the class \fBoo::Slot\fR, which manages a list
   305    398   of values (class names, variable names, etc.) that comprises the contents of
   306    399   the slot. The class defines three operations (as methods) that may be done on
   307    400   the slot:
   308         -.VE
   309    401   .TP
   310    402   \fIslot\fR \fB\-append\fR ?\fImember ...\fR?
   311         -.VS
          403  +.
   312    404   This appends the given \fImember\fR elements to the slot definition.
   313         -.VE
   314    405   .TP
   315    406   \fIslot\fR \fB\-clear\fR
   316         -.VS
          407  +.
   317    408   This sets the slot definition to the empty list.
   318         -.VE
   319    409   .TP
   320    410   \fIslot\fR \fB\-set\fR ?\fImember ...\fR?
   321         -.VS
          411  +.
   322    412   This replaces the slot definition with the given \fImember\fR elements.
   323    413   .PP
   324    414   A consequence of this is that any use of a slot's default operation where the
   325    415   first member argument begins with a hyphen will be an error. One of the above
   326    416   operations should be used explicitly in those circumstances.
   327    417   .SS "SLOT IMPLEMENTATION"
   328    418   Internally, slot objects also define a method \fB\-\-default\-operation\fR
   329    419   which is forwarded to the default operation of the slot (thus, for the class
   330    420   .QW \fBvariable\fR
   331    421   slot, this is forwarded to
   332    422   .QW "\fBmy \-append\fR" ),
   333    423   and these methods which provide the implementation interface:
   334         -.VE
   335    424   .TP
   336    425   \fIslot\fR \fBGet\fR
   337         -.VS
          426  +.
   338    427   Returns a list that is the current contents of the slot. This method must
   339    428   always be called from a stack frame created by a call to \fBoo::define\fR or
   340    429   \fBoo::objdefine\fR.
   341         -.VE
   342    430   .TP
   343    431   \fIslot\fR \fBSet \fIelementList\fR
   344         -.VS
          432  +.
   345    433   Sets the contents of the slot to the list \fIelementList\fR and returns the
   346    434   empty string. This method must always be called from a stack frame created by
   347    435   a call to \fBoo::define\fR or \fBoo::objdefine\fR.
   348    436   .PP
   349    437   The implementation of these methods is slot-dependent (and responsible for
   350    438   accessing the correct part of the class or object definition). Slots also have
   351    439   an unknown method handler to tie all these pieces together, and they hide
   352    440   their \fBdestroy\fR method so that it is not invoked inadvertently. It is
   353    441   \fIrecommended\fR that any user changes to the slot mechanism be restricted to
   354    442   defining new operations whose names start with a hyphen.
   355         -.VE
   356    443   .SH EXAMPLES
   357    444   This example demonstrates how to use both forms of the \fBoo::define\fR and
   358    445   \fBoo::objdefine\fR commands (they work in the same way), as well as
   359    446   illustrating four of the subcommands of them.
   360    447   .PP
   361    448   .CS
   362    449   oo::class create c

Changes to doc/info.n.

    31     31   .TP
    32     32   \fBinfo body \fIprocname\fR
    33     33   .
    34     34   Returns the body of procedure \fIprocname\fR.  \fIProcname\fR must be
    35     35   the name of a Tcl command procedure.
    36     36   .TP
    37     37   \fBinfo class\fI subcommand class\fR ?\fIarg ...\fR
    38         -.VS 8.6
           38  +.
    39     39   Returns information about the class, \fIclass\fR. The \fIsubcommand\fRs are
    40     40   described in \fBCLASS INTROSPECTION\fR below.
    41         -.VE 8.6
    42     41   .TP
    43     42   \fBinfo cmdcount\fR
    44     43   .
    45     44   Returns a count of the total number of commands that have been invoked
    46     45   in this interpreter.
    47     46   .TP
    48     47   \fBinfo commands \fR?\fIpattern\fR?
................................................................................
    74     73   If the command does not appear to be complete then 0 is returned.
    75     74   This command is typically used in line-oriented input environments
    76     75   to allow users to type in commands that span multiple lines;  if the
    77     76   command is not complete, the script can delay evaluating it until additional
    78     77   lines have been typed to complete the command.
    79     78   .TP
    80     79   \fBinfo coroutine\fR
    81         -.VS 8.6
           80  +.
    82     81   Returns the name of the currently executing \fBcoroutine\fR, or the empty
    83     82   string if either no coroutine is currently executing, or the current coroutine
    84     83   has been deleted (but has not yet returned or yielded since deletion).
    85         -.VE 8.6
    86     84   .TP
    87     85   \fBinfo default \fIprocname arg varname\fR
    88     86   .
    89     87   \fIProcname\fR must be the name of a Tcl command procedure and \fIarg\fR
    90     88   must be the name of an argument to that procedure.  If \fIarg\fR
    91     89   does not have a default value then the command returns \fB0\fR.
    92     90   Otherwise it returns \fB1\fR and places the default value of \fIarg\fR
    93     91   into variable \fIvarname\fR.
    94     92   .TP
    95     93   \fBinfo errorstack \fR?\fIinterp\fR?
    96         -.VS 8.6
           94  +.
    97     95   Returns, in a form that is programmatically easy to parse, the function names
    98     96   and arguments at each level from the call stack of the last error in the given
    99     97   \fIinterp\fR, or in the current one if not specified.
   100     98   .RS
   101     99   .PP
   102    100   This form is an even-sized list alternating tokens and parameters. Tokens are
   103    101   currently either \fBCALL\fR, \fBUP\fR, or \fBINNER\fR, but other values may be
................................................................................
   114    112   granularity.
   115    113   .PP
   116    114   This information is also present in the \fB\-errorstack\fR entry of the
   117    115   options dictionary returned by 3-argument \fBcatch\fR; \fBinfo errorstack\fR
   118    116   is a convenient way of retrieving it for uncaught errors at top-level in an
   119    117   interactive \fBtclsh\fR.
   120    118   .RE
   121         -.VE 8.6
   122    119   .TP
   123    120   \fBinfo exists \fIvarName\fR
   124    121   .
   125    122   Returns \fB1\fR if the variable named \fIvarName\fR exists in the
   126    123   current context (either as a global or local variable) and has been
   127    124   defined by being given a value, returns \fB0\fR otherwise.
   128    125   .TP
................................................................................
   325    322   \fBinfo nameofexecutable\fR
   326    323   .
   327    324   Returns the full path name of the binary file from which the application
   328    325   was invoked.  If Tcl was unable to identify the file, then an empty
   329    326   string is returned.
   330    327   .TP
   331    328   \fBinfo object\fI subcommand object\fR ?\fIarg ...\fR
   332         -.VS 8.6
          329  +.
   333    330   Returns information about the object, \fIobject\fR. The \fIsubcommand\fRs are
   334    331   described in \fBOBJECT INTROSPECTION\fR below.
   335         -.VE 8.6
   336    332   .TP
   337    333   \fBinfo patchlevel\fR
   338    334   .
   339    335   Returns the value of the global variable \fBtcl_patchLevel\fR, which holds
   340    336   the exact version of the Tcl library by default.
   341    337   .TP
   342    338   \fBinfo procs \fR?\fIpattern\fR?
................................................................................
   395    391   has each matching namespace variable qualified with the name
   396    392   of its namespace.
   397    393   Note that a currently-visible variable may not yet
   398    394   .QW exist
   399    395   if it has not
   400    396   been set (e.g. a variable declared but not set by \fBvariable\fR).
   401    397   .SS "CLASS INTROSPECTION"
   402         -.VS 8.6
   403    398   .PP
   404    399   The following \fIsubcommand\fR values are supported by \fBinfo class\fR:
   405         -.VE 8.6
   406    400   .TP
   407    401   \fBinfo class call\fI class method\fR
   408         -.VS
          402  +.
   409    403   Returns a description of the method implementations that are used to provide a
   410    404   stereotypical instance of \fIclass\fR's implementation of \fImethod\fR
   411    405   (stereotypical instances being objects instantiated by a class without having
   412    406   any object-specific definitions added). This consists of a list of lists of
   413    407   four elements, where each sublist consists of a word that describes the
   414    408   general type of method implementation (being one of \fBmethod\fR for an
   415         -ordinary method, \fBfilter\fR for an applied filter, and \fBunknown\fR for a
          409  +ordinary method, \fBfilter\fR for an applied filter,
          410  +.VS TIP500
          411  +\fBprivate\fR for a private method,
          412  +.VE TIP500
          413  +and \fBunknown\fR for a
   416    414   method that is invoked as part of unknown method handling), a word giving the
   417    415   name of the particular method invoked (which is always the same as
   418    416   \fImethod\fR for the \fBmethod\fR type, and
   419    417   .QW \fBunknown\fR
   420    418   for the \fBunknown\fR type), a word giving the fully qualified name of the
   421    419   class that defined the method, and a word describing the type of method
   422    420   implementation (see \fBinfo class methodtype\fR).
   423    421   .RS
   424    422   .PP
   425    423   Note that there is no inspection of whether the method implementations
   426         -actually use \fBnext\fR to transfer control along the call chain.
          424  +actually use \fBnext\fR to transfer control along the call chain,
          425  +.VS TIP500
          426  +and the call chains that this command files do not actually contain private
          427  +methods.
          428  +.VE TIP500
   427    429   .RE
   428         -.VE 8.6
   429    430   .TP
   430    431   \fBinfo class constructor\fI class\fR
   431         -.VS 8.6
          432  +.
   432    433   This subcommand returns a description of the definition of the constructor of
   433    434   class \fIclass\fR. The definition is described as a two element list; the first
   434    435   element is the list of arguments to the constructor in a form suitable for
   435    436   passing to another call to \fBproc\fR or a method definition, and the second
   436    437   element is the body of the constructor. If no constructor is present, this
   437    438   returns the empty list.
   438         -.VE 8.6
   439    439   .TP
   440    440   \fBinfo class definition\fI class method\fR
   441         -.VS 8.6
          441  +.
   442    442   This subcommand returns a description of the definition of the method named
   443    443   \fImethod\fR of class \fIclass\fR. The definition is described as a two element
   444    444   list; the first element is the list of arguments to the method in a form
   445    445   suitable for passing to another call to \fBproc\fR or a method definition, and
   446    446   the second element is the body of the method.
   447         -.VE 8.6
   448    447   .TP
   449    448   \fBinfo class destructor\fI class\fR
   450         -.VS 8.6
          449  +.
   451    450   This subcommand returns the body of the destructor of class \fIclass\fR. If no
   452    451   destructor is present, this returns the empty string.
   453         -.VE 8.6
   454    452   .TP
   455    453   \fBinfo class filters\fI class\fR
   456         -.VS 8.6
          454  +.
   457    455   This subcommand returns the list of filter methods set on the class.
   458         -.VE 8.6
   459    456   .TP
   460    457   \fBinfo class forward\fI class method\fR
   461         -.VS 8.6
          458  +.
   462    459   This subcommand returns the argument list for the method forwarding called
   463    460   \fImethod\fR that is set on the class called \fIclass\fR.
   464         -.VE 8.6
   465    461   .TP
   466    462   \fBinfo class instances\fI class\fR ?\fIpattern\fR?
   467         -.VS 8.6
          463  +.
   468    464   This subcommand returns a list of instances of class \fIclass\fR. If the
   469    465   optional \fIpattern\fR argument is present, it constrains the list of returned
   470    466   instances to those that match it according to the rules of \fBstring match\fR.
   471         -.VE 8.6
   472    467   .TP
   473    468   \fBinfo class methods\fI class\fR ?\fIoptions...\fR?
   474         -.VS 8.6
          469  +.
   475    470   This subcommand returns a list of all public (i.e. exported) methods of the
   476    471   class called \fIclass\fR. Any of the following \fIoption\fRs may be
   477    472   specified, controlling exactly which method names are returned:
   478    473   .RS
   479         -.VE 8.6
   480    474   .TP
   481    475   \fB\-all\fR
   482         -.VS 8.6
   483         -If the \fB\-all\fR flag is given, the list of methods will include those
          476  +.
          477  +If the \fB\-all\fR flag is given,
          478  +.VS TIP500
          479  +and the \fB\-scope\fR flag is not given,
          480  +.VE TIP500
          481  +the list of methods will include those
   484    482   methods defined not just by the class, but also by the class's superclasses
   485    483   and mixins.
   486         -.VE 8.6
   487    484   .TP
   488    485   \fB\-private\fR
   489         -.VS 8.6
   490         -If the \fB\-private\fR flag is given, the list of methods will also include
   491         -the private (i.e. non-exported) methods of the class (and superclasses and
          486  +.
          487  +If the \fB\-private\fR flag is given,
          488  +.VS TIP500
          489  +and the \fB\-scope\fR flag is not given,
          490  +.VE TIP500
          491  +the list of methods will also include
          492  +the non-exported methods of the class (and superclasses and
   492    493   mixins, if \fB\-all\fR is also given).
          494  +.VS TIP500
          495  +Note that this naming is an unfortunate clash with true private methods; this
          496  +option name is retained for backward compatibility.
          497  +.VE TIP500
          498  +.TP
          499  +\fB\-scope\fI scope\fR
          500  +.VS TIP500
          501  +Returns a list of all methods on \fIclass\fR that have the given visibility
          502  +\fIscope\fR.  When this option is supplied, both the \fB\-all\fR and
          503  +\fB\-private\fR options are ignored. The valid values for \fIscope\fR are:
          504  +.RS
          505  +.IP \fBpublic\fR 3
          506  +Only methods with \fIpublic\fR scope (i.e., callable from anywhere by any instance
          507  +of this class) are to be returned.
          508  +.IP \fBunexported\fR 3
          509  +Only methods with \fIunexported\fR scope (i.e., only callable via \fBmy\fR) are to
          510  +be returned.
          511  +.IP \fBprivate\fR 3
          512  +Only methods with \fIprivate\fR scope (i.e., only callable from within this class's
          513  +methods) are to be returned.
   493    514   .RE
   494         -.VE 8.6
          515  +.VE TIP500
          516  +.RE
   495    517   .TP
   496    518   \fBinfo class methodtype\fI class method\fR
   497         -.VS 8.6
          519  +.
   498    520   This subcommand returns a description of the type of implementation used for
   499    521   the method named \fImethod\fR of class \fIclass\fR. When the result is
   500    522   \fBmethod\fR, further information can be discovered with \fBinfo class
   501    523   definition\fR, and when the result is \fBforward\fR, further information can
   502    524   be discovered with \fBinfo class forward\fR.
   503         -.VE 8.6
   504    525   .TP
   505    526   \fBinfo class mixins\fI class\fR
   506         -.VS 8.6
          527  +.
   507    528   This subcommand returns a list of all classes that have been mixed into the
   508    529   class named \fIclass\fR.
   509         -.VE 8.6
   510    530   .TP
   511    531   \fBinfo class subclasses\fI class\fR ?\fIpattern\fR?
   512         -.VS 8.6
          532  +.
   513    533   This subcommand returns a list of direct subclasses of class \fIclass\fR. If
   514    534   the optional \fIpattern\fR argument is present, it constrains the list of
   515    535   returned classes to those that match it according to the rules of
   516    536   \fBstring match\fR.
   517         -.VE 8.6
   518    537   .TP
   519    538   \fBinfo class superclasses\fI class\fR
   520         -.VS 8.6
          539  +.
   521    540   This subcommand returns a list of direct superclasses of class \fIclass\fR in
   522    541   inheritance precedence order.
   523         -.VE 8.6
   524    542   .TP
   525         -\fBinfo class variables\fI class\fR
   526         -.VS 8.6
          543  +\fBinfo class variables\fI class\fR ?\fB\-private\fR?
          544  +.
   527    545   This subcommand returns a list of all variables that have been declared for
   528    546   the class named \fIclass\fR (i.e. that are automatically present in the
   529    547   class's methods, constructor and destructor).
          548  +.VS TIP500
          549  +If the \fB\-private\fR option is specified, this lists the private variables
          550  +declared instead.
          551  +.VE TIP500
   530    552   .SS "OBJECT INTROSPECTION"
   531    553   .PP
   532    554   The following \fIsubcommand\fR values are supported by \fBinfo object\fR:
   533         -.VE 8.6
   534    555   .TP
   535    556   \fBinfo object call\fI object method\fR
   536         -.VS 8.6
          557  +.
   537    558   Returns a description of the method implementations that are used to provide
   538    559   \fIobject\fR's implementation of \fImethod\fR.  This consists of a list of
   539    560   lists of four elements, where each sublist consists of a word that describes
   540    561   the general type of method implementation (being one of \fBmethod\fR for an
   541         -ordinary method, \fBfilter\fR for an applied filter, and \fBunknown\fR for a
          562  +ordinary method, \fBfilter\fR for an applied filter,
          563  +.VS TIP500
          564  +\fBprivate\fR for a private method,
          565  +.VE TIP500
          566  +and \fBunknown\fR for a
   542    567   method that is invoked as part of unknown method handling), a word giving the
   543    568   name of the particular method invoked (which is always the same as
   544    569   \fImethod\fR for the \fBmethod\fR type, and
   545    570   .QW \fBunknown\fR
   546    571   for the \fBunknown\fR type), a word giving what defined the method (the fully
   547    572   qualified name of the class, or the literal string \fBobject\fR if the method
   548    573   implementation is on an instance), and a word describing the type of method
   549    574   implementation (see \fBinfo object methodtype\fR).
   550    575   .RS
   551    576   .PP
   552    577   Note that there is no inspection of whether the method implementations
   553         -actually use \fBnext\fR to transfer control along the call chain.
          578  +actually use \fBnext\fR to transfer control along the call chain,
          579  +.VS TIP500
          580  +and the call chains that this command files do not actually contain private
          581  +methods.
          582  +.VE TIP500
   554    583   .RE
   555         -.VE 8.6
   556    584   .TP
   557    585   \fBinfo object class\fI object\fR ?\fIclassName\fR?
   558         -.VS 8.6
          586  +.
   559    587   If \fIclassName\fR is unspecified, this subcommand returns class of the
   560    588   \fIobject\fR object. If \fIclassName\fR is present, this subcommand returns a
   561    589   boolean value indicating whether the \fIobject\fR is of that class.
   562         -.VE 8.6
          590  +.TP
          591  +\fBinfo object creationid\fI object\fR
          592  +.VS TIP500
          593  +Returns the unique creation identifier for the \fIobject\fR object. This
          594  +creation identifier is unique to the object (within a Tcl interpreter) and
          595  +cannot be controlled at object creation time or altered afterwards.
          596  +.RS
          597  +.PP
          598  +\fIImplementation note:\fR the creation identifier is used to generate unique
          599  +identifiers associated with the object, especially for private variables.
          600  +.RE
          601  +.VE TIP500
   563    602   .TP
   564    603   \fBinfo object definition\fI object method\fR
   565         -.VS 8.6
          604  +.
   566    605   This subcommand returns a description of the definition of the method named
   567    606   \fImethod\fR of object \fIobject\fR. The definition is described as a two
   568    607   element list; the first element is the list of arguments to the method in a
   569    608   form suitable for passing to another call to \fBproc\fR or a method definition,
   570    609   and the second element is the body of the method.
   571         -.VE 8.6
   572    610   .TP
   573    611   \fBinfo object filters\fI object\fR
   574         -.VS 8.6
          612  +.
   575    613   This subcommand returns the list of filter methods set on the object.
   576         -.VE 8.6
   577    614   .TP
   578    615   \fBinfo object forward\fI object method\fR
   579         -.VS 8.6
          616  +.
   580    617   This subcommand returns the argument list for the method forwarding called
   581    618   \fImethod\fR that is set on the object called \fIobject\fR.
   582         -.VE 8.6
   583    619   .TP
   584    620   \fBinfo object isa\fI category object\fR ?\fIarg\fR?
   585         -.VS 8.6
          621  +.
   586    622   This subcommand tests whether an object belongs to a particular category,
   587    623   returning a boolean value that indicates whether the \fIobject\fR argument
   588    624   meets the criteria for the category. The supported categories are:
   589         -.VE 8.6
   590    625   .RS
   591    626   .TP
   592    627   \fBinfo object isa class\fI object\fR
   593         -.VS 8.6
          628  +.
   594    629   This returns whether \fIobject\fR is a class (i.e. an instance of
   595    630   \fBoo::class\fR or one of its subclasses).
   596         -.VE 8.6
   597    631   .TP
   598    632   \fBinfo object isa metaclass\fI object\fR
   599         -.VS 8.6
          633  +.
   600    634   This returns whether \fIobject\fR is a class that can manufacture classes
   601    635   (i.e. is \fBoo::class\fR or a subclass of it).
   602         -.VE 8.6
   603    636   .TP
   604    637   \fBinfo object isa mixin\fI object class\fR
   605         -.VS 8.6
          638  +.
   606    639   This returns whether \fIclass\fR is directly mixed into \fIobject\fR.
   607         -.VE 8.6
   608    640   .TP
   609    641   \fBinfo object isa object\fI object\fR
   610         -.VS 8.6
          642  +.
   611    643   This returns whether \fIobject\fR really is an object.
   612         -.VE 8.6
   613    644   .TP
   614    645   \fBinfo object isa typeof\fI object class\fR
   615         -.VS 8.6
          646  +.
   616    647   This returns whether \fIclass\fR is the type of \fIobject\fR (i.e. whether
   617    648   \fIobject\fR is an instance of \fIclass\fR or one of its subclasses, whether
   618    649   direct or indirect).
   619    650   .RE
   620         -.VE 8.6
   621    651   .TP
   622    652   \fBinfo object methods\fI object\fR ?\fIoption...\fR?
   623         -.VS 8.6
          653  +.
   624    654   This subcommand returns a list of all public (i.e. exported) methods of the
   625    655   object called \fIobject\fR. Any of the following \fIoption\fRs may be
   626    656   specified, controlling exactly which method names are returned:
   627    657   .RS
   628         -.VE 8.6
   629    658   .TP
   630    659   \fB\-all\fR
   631         -.VS 8.6
   632         -If the \fB\-all\fR flag is given, the list of methods will include those
          660  +.
          661  +If the \fB\-all\fR flag is given,
          662  +.VS TIP500
          663  +and the \fB\-scope\fR flag is not given,
          664  +.VE TIP500
          665  +the list of methods will include those
   633    666   methods defined not just by the object, but also by the object's class and
   634    667   mixins, plus the superclasses of those classes.
   635         -.VE 8.6
   636    668   .TP
   637    669   \fB\-private\fR
   638         -.VS 8.6
   639         -If the \fB\-private\fR flag is given, the list of methods will also include
   640         -the private (i.e. non-exported) methods of the object (and classes, if
          670  +.
          671  +If the \fB\-private\fR flag is given,
          672  +.VS TIP500
          673  +and the \fB\-scope\fR flag is not given,
          674  +.VE TIP500
          675  +the list of methods will also include
          676  +the non-exported methods of the object (and classes, if
   641    677   \fB\-all\fR is also given).
          678  +.VS TIP500
          679  +Note that this naming is an unfortunate clash with true private methods; this
          680  +option name is retained for backward compatibility.
          681  +.VE TIP500
          682  +.TP
          683  +\fB\-scope\fI scope\fR
          684  +.VS TIP500
          685  +Returns a list of all methods on \fIobject\fR that have the given visibility
          686  +\fIscope\fR.  When this option is supplied, both the \fB\-all\fR and
          687  +\fB\-private\fR options are ignored. The valid values for \fIscope\fR are:
          688  +.RS
          689  +.IP \fBpublic\fR 3
          690  +Only methods with \fIpublic\fR scope (i.e., callable from anywhere) are to be
          691  +returned.
          692  +.IP \fBunexported\fR 3
          693  +Only methods with \fIunexported\fR scope (i.e., only callable via \fBmy\fR) are to
          694  +be returned.
          695  +.IP \fBprivate\fR 3
          696  +Only methods with \fIprivate\fR scope (i.e., only callable from within this object's
          697  +instance methods) are to be returned.
   642    698   .RE
   643         -.VE 8.6
          699  +.VE TIP500
          700  +.RE
   644    701   .TP
   645    702   \fBinfo object methodtype\fI object method\fR
   646         -.VS 8.6
          703  +.
   647    704   This subcommand returns a description of the type of implementation used for
   648    705   the method named \fImethod\fR of object \fIobject\fR. When the result is
   649    706   \fBmethod\fR, further information can be discovered with \fBinfo object
   650    707   definition\fR, and when the result is \fBforward\fR, further information can
   651    708   be discovered with \fBinfo object forward\fR.
   652         -.VE 8.6
   653    709   .TP
   654    710   \fBinfo object mixins\fI object\fR
   655         -.VS 8.6
          711  +.
   656    712   This subcommand returns a list of all classes that have been mixed into the
   657    713   object named \fIobject\fR.
   658         -.VE 8.6
   659    714   .TP
   660    715   \fBinfo object namespace\fI object\fR
   661         -.VS 8.6
          716  +.
   662    717   This subcommand returns the name of the internal namespace of the object named
   663    718   \fIobject\fR.
   664         -.VE 8.6
   665    719   .TP
   666         -\fBinfo object variables\fI object\fR
   667         -.VS 8.6
          720  +\fBinfo object variables\fI object\fRR ?\fB\-private\fR?
          721  +.
   668    722   This subcommand returns a list of all variables that have been declared for
   669    723   the object named \fIobject\fR (i.e. that are automatically present in the
   670    724   object's methods).
   671         -.VE 8.6
          725  +.VS TIP500
          726  +If the \fB\-private\fR option is specified, this lists the private variables
          727  +declared instead.
          728  +.VE TIP500
   672    729   .TP
   673    730   \fBinfo object vars\fI object\fR ?\fIpattern\fR?
   674         -.VS 8.6
          731  +.
   675    732   This subcommand returns a list of all variables in the private namespace of
   676    733   the object named \fIobject\fR. If the optional \fIpattern\fR argument is
   677    734   given, it is a filter (in the syntax of a \fBstring match\fR glob pattern)
   678    735   that constrains the list of variables returned. Note that this is different
   679    736   from the list returned by \fBinfo object variables\fR; that can include
   680    737   variables that are currently unset, whereas this can include variables that
   681    738   are not automatically included by any of \fIobject\fR's methods (or those of
   682    739   its class, superclasses or mixins).
   683         -.VE 8.6
   684    740   .SH EXAMPLES
   685    741   .PP
   686    742   This command prints out a procedure suitable for saving in a Tcl
   687    743   script:
   688    744   .PP
   689    745   .CS
   690    746   proc printProc {procName} {
................................................................................
   699    755               lappend formals [list $var]
   700    756           }
   701    757       }
   702    758       puts [lappend result $formals [\fBinfo body\fR $procName]]
   703    759   }
   704    760   .CE
   705    761   .SS "EXAMPLES WITH OBJECTS"
   706         -.VS 8.6
   707    762   .PP
   708    763   Every object necessarily knows what its class is; this information is
   709    764   trivially extractable through introspection:
   710    765   .PP
   711    766   .CS
   712    767   oo::class create c
   713    768   c create o
................................................................................
   720    775   The introspection capabilities can be used to discover what class implements a
   721    776   method and get how it is defined. This procedure illustrates how:
   722    777   .PP
   723    778   .CS
   724    779   proc getDef {obj method} {
   725    780       foreach inf [\fBinfo object call\fR $obj $method] {
   726    781           lassign $inf calltype name locus methodtype
          782  +
   727    783           # Assume no forwards or filters, and hence no $calltype
   728    784           # or $methodtype checks...
          785  +
   729    786           if {$locus eq "object"} {
   730    787               return [\fBinfo object definition\fR $obj $name]
   731    788           } else {
   732    789               return [\fBinfo class definition\fR $locus $name]
   733    790           }
   734    791       }
   735    792       error "no definition for $method"
................................................................................
   744    801   .PP
   745    802   .CS
   746    803   proc getDef {obj method} {
   747    804       if {$method in [\fBinfo object methods\fR $obj]} {
   748    805           # Assume no forwards
   749    806           return [\fBinfo object definition\fR $obj $method]
   750    807       }
          808  +
   751    809       set cls [\fBinfo object class\fR $obj]
          810  +
   752    811       while {$method ni [\fBinfo class methods\fR $cls]} {
   753    812           # Assume the simple case
   754    813           set cls [lindex [\fBinfo class superclass\fR $cls] 0]
   755    814           if {$cls eq ""} {
   756    815               error "no definition for $method"
   757    816           }
   758    817       }
          818  +
   759    819       # Assume no forwards
   760    820       return [\fBinfo class definition\fR $cls $method]
   761    821   }
   762    822   .CE
   763         -.VE 8.6
   764    823   .SH "SEE ALSO"
   765         -.VS 8.6
   766    824   global(n), oo::class(n), oo::define(n), oo::object(n), proc(n), self(n),
   767         -.VE 8.6
   768    825   tcl_library(n), tcl_patchLevel(n), tcl_version(n)
   769    826   .SH KEYWORDS
   770    827   command, information, interpreter, introspection, level, namespace,
   771         -.VS 8.6
   772         -object,
   773         -.VE 8.6
   774         -procedure, variable
          828  +object, procedure, variable
   775    829   '\" Local Variables:
   776    830   '\" mode: nroff
   777    831   '\" fill-column: 78
   778    832   '\" End:

Changes to doc/my.n.

    15     15   package require TclOO
    16     16   
    17     17   \fBmy\fI methodName\fR ?\fIarg ...\fR?
    18     18   .fi
    19     19   .BE
    20     20   .SH DESCRIPTION
    21     21   .PP
    22         -The \fBmy\fR command is used to allow methods of objects to invoke any method
           22  +The \fBmy\fR command is used to allow methods of objects to invoke methods
    23     23   of the object (or its class). In particular, the set of valid values for
    24     24   \fImethodName\fR is the set of all methods supported by an object and its
    25         -superclasses, including those that are not exported. The object upon which the
    26         -method is invoked is always the one that is the current context of the method
    27         -(i.e. the object that is returned by \fBself object\fR) from which the
    28         -\fBmy\fR command is invoked.
           25  +superclasses, including those that are not exported
           26  +.VS TIP500
           27  +and private methods of the object or class when used within another method
           28  +defined by that object or class.
           29  +.VE TIP500
           30  +The object upon which the method is invoked is the one that owns the namespace
           31  +that the \fBmy\fR command is contained in initially (\fBNB:\fR the link
           32  +remains if the command is renamed), which is the currently invoked object by
           33  +default.
    29     34   .PP
    30     35   Each object has its own \fBmy\fR command, contained in its instance namespace.
    31     36   .SH EXAMPLES
    32     37   .PP
    33     38   This example shows basic use of \fBmy\fR to use the \fBvariables\fR method of
    34     39   the \fBoo::object\fR class, which is not publicly visible by default:
    35     40   .PP
................................................................................
    36     41   .CS
    37     42   oo::class create c {
    38     43       method count {} {
    39     44           \fBmy\fR variable counter
    40     45           puts [incr counter]
    41     46       }
    42     47   }
           48  +
    43     49   c create o
    44     50   o count              \fI\(-> prints "1"\fR
    45     51   o count              \fI\(-> prints "2"\fR
    46     52   o count              \fI\(-> prints "3"\fR
    47     53   .CE
           54  +.PP
           55  +This example shows how you can use \fBmy\fR to make callbacks to private
           56  +methods from outside the object (from a \fBtrace\fR), using
           57  +\fBnamespace code\fR to enter the correct context:
           58  +.PP
           59  +.CS
           60  +oo::class create HasCallback {
           61  +    method makeCallback {} {
           62  +        return [namespace code {
           63  +            \fBmy\fR Callback
           64  +        }]
           65  +    }
           66  +
           67  +    method Callback {args} {
           68  +        puts "callback: $args"
           69  +    }
           70  +}
           71  +
           72  +set o [HasCallback new]
           73  +trace add variable xyz write [$o makeCallback]
           74  +set xyz "called"     \fI\(-> prints "callback: xyz {} write"\fR
           75  +.CE
    48     76   .SH "SEE ALSO"
    49     77   next(n), oo::object(n), self(n)
    50     78   .SH KEYWORDS
    51     79   method, method visibility, object, private method, public method
    52         -
    53     80   .\" Local variables:
    54     81   .\" mode: nroff
    55     82   .\" fill-column: 78
    56     83   .\" End:

Changes to doc/next.n.

   108    108   .PP
   109    109   .CS
   110    110   oo::class create theSuperclass {
   111    111       method example {args} {
   112    112           puts "in the superclass, args = $args"
   113    113       }
   114    114   }
          115  +
   115    116   oo::class create theSubclass {
   116    117       superclass theSuperclass
   117    118       method example {args} {
   118    119           puts "before chaining from subclass, args = $args"
   119    120           \fBnext\fR a {*}$args b
   120    121           \fBnext\fR pureSynthesis
   121    122           puts "after chaining from subclass"
   122    123       }
   123    124   }
          125  +
   124    126   theSubclass create obj
   125    127   oo::objdefine obj method example args {
   126    128       puts "per-object method, args = $args"
   127    129       \fBnext\fR x {*}$args y
   128    130       \fBnext\fR
   129    131   }
   130    132   obj example 1 2 3
................................................................................
   163    165           if {[info exist ValueCache($key)]} {
   164    166               return $ValueCache($key)
   165    167           }
   166    168   
   167    169           \fI# Compute value, insert into cache, and return it\fR
   168    170           return [set ValueCache($key) [\fBnext\fR {*}$args]]
   169    171       }
          172  +
   170    173       method flushCache {} {
   171    174           my variable ValueCache
   172    175           unset ValueCache
   173    176           \fI# Skip the caching\fR
   174    177           return -level 2 ""
   175    178       }
   176    179   }
   177    180   
   178    181   oo::object create demo
   179    182   oo::objdefine demo {
   180    183       mixin cache
          184  +
   181    185       method compute {a b c} {
   182    186           after 3000 \fI;# Simulate deep thought\fR
   183    187           return [expr {$a + $b * $c}]
   184    188       }
          189  +
   185    190       method compute2 {a b c} {
   186    191           after 3000 \fI;# Simulate deep thought\fR
   187    192           return [expr {$a * $b + $c}]
   188    193       }
   189    194   }
   190    195   
   191    196   puts [demo compute  1 2 3]      \fI\(-> prints "7" after delay\fR

Changes to doc/self.n.

    28     28   \fBself call\fR
    29     29   .
    30     30   This returns a two-element list describing the method implementations used to
    31     31   implement the current call chain. The first element is the same as would be
    32     32   reported by \fBinfo object\fR \fBcall\fR for the current method (except that this
    33     33   also reports useful values from within constructors and destructors, whose
    34     34   names are reported as \fB<constructor>\fR and \fB<destructor>\fR
    35         -respectively), and the second element is an index into the first element's
           35  +respectively,
           36  +.VS TIP500
           37  +and for private methods, which are described as being \fBprivate\fR instead of
           38  +being a \fBmethod\fR),
           39  +.VE TIP500
           40  +and the second element is an index into the first element's
    36     41   list that indicates which actual implementation is currently executing (the
    37     42   first implementation to execute is always at index 0).
    38     43   .TP
    39     44   \fBself caller\fR
    40     45   .
    41     46   When the method was invoked from inside another object method, this subcommand
    42     47   returns a three element list describing the containing object and method. The

Changes to generic/tclInt.h.

  1162   1162   				 * clientData field contains a CallContext
  1163   1163   				 * reference. Part of TIP#257. */
  1164   1164   #define FRAME_IS_OO_DEFINE 0x8	/* The frame is part of the inside workings of
  1165   1165   				 * the [oo::define] command; the clientData
  1166   1166   				 * field contains an Object reference that has
  1167   1167   				 * been confirmed to refer to a class. Part of
  1168   1168   				 * TIP#257. */
         1169  +#define FRAME_IS_PRIVATE_DEFINE 0x10
         1170  +				/* Marks this frame as being used for private
         1171  +				 * declarations with [oo::define]. Usually
         1172  +				 * OR'd with FRAME_IS_OO_DEFINE. TIP#500. */
  1169   1173   
  1170   1174   /*
  1171   1175    * TIP #280
  1172   1176    * The structure below defines a command frame. A command frame provides
  1173   1177    * location information for all commands executing a tcl script (source, eval,
  1174   1178    * uplevel, procedure bodies, ...). The runtime structure essentially contains
  1175   1179    * the stack trace as it would be if the currently executing command were to

Changes to generic/tclOO.c.

    27     27   } defineCmds[] = {
    28     28       {"constructor", TclOODefineConstructorObjCmd, 0},
    29     29       {"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
    30     30       {"destructor", TclOODefineDestructorObjCmd, 0},
    31     31       {"export", TclOODefineExportObjCmd, 0},
    32     32       {"forward", TclOODefineForwardObjCmd, 0},
    33     33       {"method", TclOODefineMethodObjCmd, 0},
           34  +    {"private", TclOODefinePrivateObjCmd, 0},
    34     35       {"renamemethod", TclOODefineRenameMethodObjCmd, 0},
    35     36       {"self", TclOODefineSelfObjCmd, 0},
    36     37       {"unexport", TclOODefineUnexportObjCmd, 0},
    37     38       {NULL, NULL, 0}
    38     39   }, objdefCmds[] = {
    39     40       {"class", TclOODefineClassObjCmd, 1},
    40     41       {"deletemethod", TclOODefineDeleteMethodObjCmd, 1},
    41     42       {"export", TclOODefineExportObjCmd, 1},
    42     43       {"forward", TclOODefineForwardObjCmd, 1},
    43     44       {"method", TclOODefineMethodObjCmd, 1},
           45  +    {"private", TclOODefinePrivateObjCmd, 1},
    44     46       {"renamemethod", TclOODefineRenameMethodObjCmd, 1},
    45     47       {"self", TclOODefineObjSelfObjCmd, 0},
    46     48       {"unexport", TclOODefineUnexportObjCmd, 1},
    47     49       {NULL, NULL, 0}
    48     50   };
    49     51   
    50     52   /*
................................................................................
   989    991   {
   990    992       FOREACH_HASH_DECLS;
   991    993       int i;
   992    994       Class *clsPtr = oPtr->classPtr, *tmpClsPtr;
   993    995       Method *mPtr;
   994    996       Foundation *fPtr = oPtr->fPtr;
   995    997       Tcl_Obj *variableObj;
          998  +    PrivateVariableMapping *privateVariable;
   996    999   
   997   1000       /*
   998   1001        * Sanity check!
   999   1002        */
  1000   1003   
  1001   1004       if (!Deleted(oPtr)) {
  1002   1005   	if (IsRootClass(oPtr)) {
................................................................................
  1094   1097   
  1095   1098       FOREACH(variableObj, clsPtr->variables) {
  1096   1099   	TclDecrRefCount(variableObj);
  1097   1100       }
  1098   1101       if (i) {
  1099   1102   	ckfree(clsPtr->variables.list);
  1100   1103       }
         1104  +
         1105  +    FOREACH_STRUCT(privateVariable, clsPtr->privateVariables) {
         1106  +	TclDecrRefCount(privateVariable->variableObj);
         1107  +	TclDecrRefCount(privateVariable->fullNameObj);
         1108  +    }
         1109  +    if (i) {
         1110  +	ckfree(clsPtr->privateVariables.list);
         1111  +    }
  1101   1112   
  1102   1113       if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) {
  1103   1114   	Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
  1104   1115       }
  1105   1116   }
  1106   1117   
  1107   1118   /*
................................................................................
  1124   1135   {
  1125   1136       Object *oPtr = clientData;
  1126   1137       Foundation *fPtr = oPtr->fPtr;
  1127   1138       FOREACH_HASH_DECLS;
  1128   1139       Class *mixinPtr;
  1129   1140       Method *mPtr;
  1130   1141       Tcl_Obj *filterObj, *variableObj;
         1142  +    PrivateVariableMapping *privateVariable;
  1131   1143       Tcl_Interp *interp = oPtr->fPtr->interp;
  1132   1144       int i;
  1133   1145   
  1134   1146       if (Deleted(oPtr)) {
  1135   1147   	/*
  1136   1148   	 * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, this
  1137   1149   	 * guard could be removed.
................................................................................
  1158   1170        * interpreter is being deleted; their incestuous nature causes problems
  1159   1171        * in that case when the destructor is partially deleted before the uses
  1160   1172        * of it have gone. [Bug 2949397]
  1161   1173        */
  1162   1174   
  1163   1175       if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) {
  1164   1176   	CallContext *contextPtr =
  1165         -		TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
         1177  +		TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL);
  1166   1178   	int result;
  1167   1179   
  1168   1180   	Tcl_InterpState state;
  1169   1181   	oPtr->flags |= DESTRUCTOR_CALLED;
  1170   1182   
  1171   1183   	if (contextPtr != NULL) {
  1172   1184   	    contextPtr->callPtr->flags |= DESTRUCTOR;
................................................................................
  1243   1255   
  1244   1256       FOREACH(variableObj, oPtr->variables) {
  1245   1257   	TclDecrRefCount(variableObj);
  1246   1258       }
  1247   1259       if (i) {
  1248   1260   	ckfree(oPtr->variables.list);
  1249   1261       }
         1262  +
         1263  +    FOREACH_STRUCT(privateVariable, oPtr->privateVariables) {
         1264  +	TclDecrRefCount(privateVariable->variableObj);
         1265  +	TclDecrRefCount(privateVariable->fullNameObj);
         1266  +    }
         1267  +    if (i) {
         1268  +	ckfree(oPtr->privateVariables.list);
         1269  +    }
  1250   1270   
  1251   1271       if (oPtr->chainCache) {
  1252   1272   	TclOODeleteChainCache(oPtr->chainCache);
  1253   1273       }
  1254   1274   
  1255   1275       SquelchCachedName(oPtr);
  1256   1276   
................................................................................
  1627   1647       /*
  1628   1648        * Run constructors, except when objc < 0, which is a special flag case
  1629   1649        * used for object cloning only.
  1630   1650        */
  1631   1651   
  1632   1652       if (objc >= 0) {
  1633   1653   	CallContext *contextPtr =
  1634         -		TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
         1654  +		TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL);
  1635   1655   
  1636   1656   	if (contextPtr != NULL) {
  1637   1657   	    int isRoot, result;
  1638   1658   	    Tcl_InterpState state;
  1639   1659   
  1640   1660   	    state = Tcl_SaveInterpState(interp, TCL_OK);
  1641   1661   	    contextPtr->callPtr->flags |= CONSTRUCTOR;
................................................................................
  1700   1720        * object cloning only). If there aren't any constructors, we do nothing.
  1701   1721        */
  1702   1722   
  1703   1723       if (objc < 0) {
  1704   1724   	*objectPtr = (Tcl_Object) oPtr;
  1705   1725   	return TCL_OK;
  1706   1726       }
  1707         -    contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
         1727  +    contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL);
  1708   1728       if (contextPtr == NULL) {
  1709   1729   	*objectPtr = (Tcl_Object) oPtr;
  1710   1730   	return TCL_OK;
  1711   1731       }
  1712   1732   
  1713   1733       state = Tcl_SaveInterpState(interp, TCL_OK);
  1714   1734       contextPtr->callPtr->flags |= CONSTRUCTOR;
................................................................................
  1880   1900   {
  1881   1901       Object *oPtr = (Object *) sourceObject, *o2Ptr;
  1882   1902       FOREACH_HASH_DECLS;
  1883   1903       Method *mPtr;
  1884   1904       Class *mixinPtr;
  1885   1905       CallContext *contextPtr;
  1886   1906       Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
         1907  +    PrivateVariableMapping *privateVariable;
  1887   1908       int i, result;
  1888   1909   
  1889   1910       /*
  1890   1911        * Sanity check.
  1891   1912        */
  1892   1913   
  1893   1914       if (IsRootClass(oPtr)) {
................................................................................
  1949   1970   
  1950   1971       DUPLICATE(o2Ptr->filters, oPtr->filters, Tcl_Obj *);
  1951   1972       FOREACH(filterObj, o2Ptr->filters) {
  1952   1973   	Tcl_IncrRefCount(filterObj);
  1953   1974       }
  1954   1975   
  1955   1976       /*
  1956         -     * Copy the object's variable resolution list to the new object.
         1977  +     * Copy the object's variable resolution lists to the new object.
  1957   1978        */
  1958   1979   
  1959   1980       DUPLICATE(o2Ptr->variables, oPtr->variables, Tcl_Obj *);
  1960   1981       FOREACH(variableObj, o2Ptr->variables) {
  1961   1982   	Tcl_IncrRefCount(variableObj);
  1962   1983       }
         1984  +
         1985  +    DUPLICATE(o2Ptr->privateVariables, oPtr->privateVariables,
         1986  +	    PrivateVariableMapping);
         1987  +    FOREACH_STRUCT(privateVariable, o2Ptr->privateVariables) {
         1988  +	Tcl_IncrRefCount(privateVariable->variableObj);
         1989  +	Tcl_IncrRefCount(privateVariable->fullNameObj);
         1990  +    }
  1963   1991   
  1964   1992       /*
  1965   1993        * Copy the object's flags to the new object, clearing those that must be
  1966   1994        * kept object-local. The duplicate is never deleted at this point, nor is
  1967   1995        * it the root of the object system or in the midst of processing a filter
  1968   1996        * call.
  1969   1997        */
................................................................................
  2045   2073   
  2046   2074   	DUPLICATE(cls2Ptr->filters, clsPtr->filters, Tcl_Obj *);
  2047   2075   	FOREACH(filterObj, cls2Ptr->filters) {
  2048   2076   	    Tcl_IncrRefCount(filterObj);
  2049   2077   	}
  2050   2078   
  2051   2079   	/*
  2052         -	 * Copy the source class's variable resolution list.
         2080  +	 * Copy the source class's variable resolution lists.
  2053   2081   	 */
  2054   2082   
  2055   2083   	DUPLICATE(cls2Ptr->variables, clsPtr->variables, Tcl_Obj *);
  2056   2084   	FOREACH(variableObj, cls2Ptr->variables) {
  2057   2085   	    Tcl_IncrRefCount(variableObj);
  2058   2086   	}
         2087  +
         2088  +	DUPLICATE(cls2Ptr->privateVariables, clsPtr->privateVariables,
         2089  +		PrivateVariableMapping);
         2090  +	FOREACH_STRUCT(privateVariable, cls2Ptr->privateVariables) {
         2091  +	    Tcl_IncrRefCount(privateVariable->variableObj);
         2092  +	    Tcl_IncrRefCount(privateVariable->fullNameObj);
         2093  +	}
  2059   2094   
  2060   2095   	/*
  2061   2096   	 * Duplicate the source class's mixins (which cannot be circular
  2062   2097   	 * references to the duplicate).
  2063   2098   	 */
  2064   2099   
  2065   2100   	if (cls2Ptr->mixins.num != 0) {
................................................................................
  2125   2160   			    duplicate);
  2126   2161   		}
  2127   2162   	    }
  2128   2163   	}
  2129   2164       }
  2130   2165   
  2131   2166       TclResetRewriteEnsemble(interp, 1);
  2132         -    contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL);
         2167  +    contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL,
         2168  +	    NULL, NULL);
  2133   2169       if (contextPtr) {
  2134   2170   	args[0] = TclOOObjectName(interp, o2Ptr);
  2135   2171   	args[1] = oPtr->fPtr->clonedName;
  2136   2172   	args[2] = TclOOObjectName(interp, oPtr);
  2137   2173   	Tcl_IncrRefCount(args[0]);
  2138   2174   	Tcl_IncrRefCount(args[1]);
  2139   2175   	Tcl_IncrRefCount(args[2]);
................................................................................
  2522   2558       Class *startCls)		/* Where to start in the call chain, or NULL
  2523   2559   				 * if we are to start at the front with
  2524   2560   				 * filters and the object's methods (which is
  2525   2561   				 * the normal case). */
  2526   2562   {
  2527   2563       CallContext *contextPtr;
  2528   2564       Tcl_Obj *methodNamePtr;
         2565  +    CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
         2566  +    Object *callerObjPtr = NULL;
         2567  +    Class *callerClsPtr = NULL;
  2529   2568       int result;
  2530   2569   
  2531   2570       /*
  2532   2571        * If we've no method name, throw this directly into the unknown
  2533   2572        * processing.
  2534   2573        */
  2535   2574   
  2536   2575       if (objc < 2) {
  2537   2576   	flags |= FORCE_UNKNOWN;
  2538   2577   	methodNamePtr = NULL;
  2539   2578   	goto noMapping;
  2540   2579       }
         2580  +
         2581  +    /*
         2582  +     * Determine if we're in a context that can see the extra, private methods
         2583  +     * in this class.
         2584  +     */
         2585  +
         2586  +    if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
         2587  +	CallContext *callerContextPtr = framePtr->clientData;
         2588  +	Method *callerMethodPtr =
         2589  +		callerContextPtr->callPtr->chain[callerContextPtr->index].mPtr;
         2590  +
         2591  +	if (callerMethodPtr->declaringObjectPtr) {
         2592  +	    callerObjPtr = callerMethodPtr->declaringObjectPtr;
         2593  +	}
         2594  +	if (callerMethodPtr->declaringClassPtr) {
         2595  +	    callerClsPtr = callerMethodPtr->declaringClassPtr;
         2596  +	}
         2597  +    }
  2541   2598   
  2542   2599       /*
  2543   2600        * Give plugged in code a chance to remap the method name.
  2544   2601        */
  2545   2602   
  2546   2603       methodNamePtr = objv[1];
  2547   2604       if (oPtr->mapMethodNameProc != NULL) {
................................................................................
  2562   2619   
  2563   2620   	/*
  2564   2621   	 * Get the call chain for the remapped name.
  2565   2622   	 */
  2566   2623   
  2567   2624   	Tcl_IncrRefCount(mappedMethodName);
  2568   2625   	contextPtr = TclOOGetCallContext(oPtr, mappedMethodName,
  2569         -		flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr);
         2626  +		flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr,
         2627  +		callerClsPtr, methodNamePtr);
  2570   2628   	TclDecrRefCount(mappedMethodName);
  2571   2629   	if (contextPtr == NULL) {
  2572   2630   	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
  2573   2631   		    "impossible to invoke method \"%s\": no defined method or"
  2574   2632   		    " unknown method", TclGetString(methodNamePtr)));
  2575   2633   	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED",
  2576   2634   		    TclGetString(methodNamePtr), NULL);
................................................................................
  2579   2637       } else {
  2580   2638   	/*
  2581   2639   	 * Get the call chain.
  2582   2640   	 */
  2583   2641   
  2584   2642       noMapping:
  2585   2643   	contextPtr = TclOOGetCallContext(oPtr, methodNamePtr,
  2586         -		flags | (oPtr->flags & FILTER_HANDLING), NULL);
         2644  +		flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr,
         2645  +		callerClsPtr, NULL);
  2587   2646   	if (contextPtr == NULL) {
  2588   2647   	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
  2589   2648   		    "impossible to invoke method \"%s\": no defined method or"
  2590   2649   		    " unknown method", TclGetString(methodNamePtr)));
  2591   2650   	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
  2592   2651   		    TclGetString(methodNamePtr), NULL);
  2593   2652   	    return TCL_ERROR;

Changes to generic/tclOO.decls.

    54     54   	    ClientData *clientDataPtr)
    55     55   }
    56     56   declare 10 {
    57     57       Tcl_Obj *Tcl_MethodName(Tcl_Method method)
    58     58   }
    59     59   declare 11 {
    60     60       Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object,
    61         -	    Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr,
           61  +	    Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr,
    62     62   	    ClientData clientData)
    63     63   }
    64     64   declare 12 {
    65     65       Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
    66         -	    Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr,
           66  +	    Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr,
    67     67   	    ClientData clientData)
    68     68   }
    69     69   declare 13 {
    70     70       Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls,
    71     71   	    const char *nameStr, const char *nsNameStr, int objc,
    72     72   	    Tcl_Obj *const *objv, int skip)
    73     73   }
................................................................................
   122    122   declare 27 {
   123    123       void Tcl_ClassSetDestructor(Tcl_Interp *interp, Tcl_Class clazz,
   124    124   	    Tcl_Method method)
   125    125   }
   126    126   declare 28 {
   127    127       Tcl_Obj *Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object)
   128    128   }
          129  +declare 29 {
          130  +    int Tcl_MethodIsPrivate(Tcl_Method method)
          131  +}
   129    132   
   130    133   ######################################################################
   131    134   # Private API, exposed to support advanced OO systems that plug in on top of
   132    135   # TclOO; not intended for general use and does not have any commitment to
   133    136   # long-term support.
   134    137   #
   135    138   

Changes to generic/tclOO.h.

    95     95   /*
    96     96    * The correct value for the version field of the Tcl_MethodType structure.
    97     97    * This allows new versions of the structure to be introduced without breaking
    98     98    * binary compatability.
    99     99    */
   100    100   
   101    101   #define TCL_OO_METHOD_VERSION_CURRENT 1
          102  +
          103  +/*
          104  + * Visibility constants for the flags parameter to Tcl_NewMethod and
          105  + * Tcl_NewInstanceMethod.
          106  + */
          107  +
          108  +#define TCL_OO_METHOD_PUBLIC		1
          109  +#define TCL_OO_METHOD_UNEXPORTED	0
          110  +#define TCL_OO_METHOD_PRIVATE		0x20
   102    111   
   103    112   /*
   104    113    * The type of some object (or class) metadata. This describes how to delete
   105    114    * the metadata (when the object or class is deleted) and how to create a
   106    115    * clone of it (when the object or class is copied).
   107    116    */
   108    117   

Changes to generic/tclOOBasic.c.

   343    343       if (objc != Tcl_ObjectContextSkippedArgs(context)) {
   344    344   	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
   345    345   		NULL);
   346    346   	return TCL_ERROR;
   347    347       }
   348    348       if (!(oPtr->flags & DESTRUCTOR_CALLED)) {
   349    349   	oPtr->flags |= DESTRUCTOR_CALLED;
   350         -	contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
          350  +	contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL,
          351  +		NULL);
   351    352   	if (contextPtr != NULL) {
   352    353   	    contextPtr->callPtr->flags |= DESTRUCTOR;
   353    354   	    contextPtr->skip = 0;
   354    355   	    TclNRAddCallback(interp, AfterNRDestructor, contextPtr,
   355    356   		    NULL, NULL, NULL);
   356    357   	    TclPushTailcallPoint(interp);
   357    358   	    return TclOOInvokeContext(contextPtr, interp, 0, NULL);
................................................................................
   495    496       Tcl_Interp *interp,		/* Interpreter in which to create the object;
   496    497   				 * also used for error reporting. */
   497    498       Tcl_ObjectContext context,	/* The object/call context. */
   498    499       int objc,			/* Number of arguments. */
   499    500       Tcl_Obj *const *objv)	/* The actual arguments. */
   500    501   {
   501    502       CallContext *contextPtr = (CallContext *) context;
          503  +    Object *callerObj = NULL;
          504  +    Class *callerCls = NULL;
   502    505       Object *oPtr = contextPtr->oPtr;
   503    506       const char **methodNames;
   504    507       int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);
          508  +    CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
   505    509       Tcl_Obj *errorMsg;
   506    510   
   507    511       /*
   508    512        * If no method name, generate an error asking for a method name. (Only by
   509    513        * overriding *this* method can an object handle the absence of a method
   510    514        * name without an error).
   511    515        */
   512    516   
   513    517       if (objc < skip+1) {
   514    518   	Tcl_WrongNumArgs(interp, skip, objv, "method ?arg ...?");
   515    519   	return TCL_ERROR;
   516    520       }
          521  +
          522  +    /*
          523  +     * Determine if the calling context should know about extra private
          524  +     * methods, and if so, which.
          525  +     */
          526  +
          527  +    if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
          528  +	CallContext *callerContext = framePtr->clientData;
          529  +	Method *mPtr = callerContext->callPtr->chain[
          530  +		    callerContext->index].mPtr;
          531  +
          532  +	if (mPtr->declaringObjectPtr) {
          533  +	    if (oPtr == mPtr->declaringObjectPtr) {
          534  +		callerObj = mPtr->declaringObjectPtr;
          535  +	    }
          536  +	} else {
          537  +	    if (TclOOIsReachable(mPtr->declaringClassPtr, oPtr->selfCls)) {
          538  +		callerCls = mPtr->declaringClassPtr;
          539  +	    }
          540  +	}
          541  +    }
   517    542   
   518    543       /*
   519    544        * Get the list of methods that we want to know about.
   520    545        */
   521    546   
   522         -    numMethodNames = TclOOGetSortedMethodList(oPtr,
          547  +    numMethodNames = TclOOGetSortedMethodList(oPtr, callerObj, callerCls,
   523    548   	    contextPtr->callPtr->flags & PUBLIC_METHOD, &methodNames);
   524    549   
   525    550       /*
   526    551        * Special message when there are no visible methods at all.
   527    552        */
   528    553   
   529    554       if (numMethodNames == 0) {
................................................................................
   680    705   				 * also used for error reporting. */
   681    706       Tcl_ObjectContext context,	/* The object/call context. */
   682    707       int objc,			/* Number of arguments. */
   683    708       Tcl_Obj *const *objv)	/* The actual arguments. */
   684    709   {
   685    710       Var *varPtr, *aryVar;
   686    711       Tcl_Obj *varNamePtr, *argPtr;
          712  +    CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
   687    713       const char *arg;
   688    714   
   689    715       if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
   690    716   	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
   691    717   		"varName");
   692    718   	return TCL_ERROR;
   693    719       }
................................................................................
   704    730        */
   705    731   
   706    732       if (arg[0] == ':' && arg[1] == ':') {
   707    733   	varNamePtr = argPtr;
   708    734       } else {
   709    735   	Tcl_Namespace *namespacePtr =
   710    736   		Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));
          737  +
          738  +	/*
          739  +	 * Private method handling. [TIP 500]
          740  +	 *
          741  +	 * If we're in a context that can see some private methods of an
          742  +	 * object, we may need to precede a variable name with its prefix.
          743  +	 * This is a little tricky as we need to check through the inheritance
          744  +	 * hierarchy when the method was declared by a class to see if the
          745  +	 * current object is an instance of that class.
          746  +	 */
          747  +
          748  +	if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
          749  +	    Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
          750  +	    CallContext *callerContext = framePtr->clientData;
          751  +	    Method *mPtr = callerContext->callPtr->chain[
          752  +		    callerContext->index].mPtr;
          753  +	    PrivateVariableMapping *pvPtr;
          754  +	    int i;
          755  +
          756  +	    if (mPtr->declaringObjectPtr == oPtr) {
          757  +		FOREACH_STRUCT(pvPtr, oPtr->privateVariables) {
          758  +		    if (!strcmp(Tcl_GetString(pvPtr->variableObj),
          759  +			    Tcl_GetString(argPtr))) {
          760  +			argPtr = pvPtr->fullNameObj;
          761  +			break;
          762  +		    }
          763  +		}
          764  +	    } else if (mPtr->declaringClassPtr &&
          765  +		    mPtr->declaringClassPtr->privateVariables.num) {
          766  +		Class *clsPtr = mPtr->declaringClassPtr;
          767  +		int isInstance = TclOOIsReachable(clsPtr, oPtr->selfCls);
          768  +		Class *mixinCls;
          769  +
          770  +		if (!isInstance) {
          771  +		    FOREACH(mixinCls, oPtr->mixins) {
          772  +			if (TclOOIsReachable(clsPtr, mixinCls)) {
          773  +			    isInstance = 1;
          774  +			    break;
          775  +			}
          776  +		    }
          777  +		}
          778  +		if (isInstance) {
          779  +		    FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) {
          780  +			if (!strcmp(Tcl_GetString(pvPtr->variableObj),
          781  +				Tcl_GetString(argPtr))) {
          782  +			    argPtr = pvPtr->fullNameObj;
          783  +			    break;
          784  +			}
          785  +		    }
          786  +		}
          787  +	    }
          788  +	}
   711    789   
   712    790   	varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1);
   713    791   	Tcl_AppendToObj(varNamePtr, "::", 2);
   714    792   	Tcl_AppendObjToObj(varNamePtr, argPtr);
   715    793       }
   716    794       Tcl_IncrRefCount(varNamePtr);
   717    795       varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
................................................................................
   725    803       /*
   726    804        * Now that we've pinned down what variable we're really talking about
   727    805        * (including traversing variable links), convert back to a name.
   728    806        */
   729    807   
   730    808       varNamePtr = Tcl_NewObj();
   731    809       if (aryVar != NULL) {
   732         -	Tcl_HashEntry *hPtr;
   733         -	Tcl_HashSearch search;
   734         -
   735    810   	Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr);
   736    811   
   737    812   	/*
   738    813   	 * WARNING! This code pokes inside the implementation of hash tables!
   739    814   	 */
   740    815   
   741         -	hPtr = Tcl_FirstHashEntry((Tcl_HashTable *) aryVar->value.tablePtr,
   742         -		&search);
   743         -	while (hPtr != NULL) {
   744         -	    if (varPtr == Tcl_GetHashValue(hPtr)) {
   745         -		Tcl_AppendToObj(varNamePtr, "(", -1);
   746         -		Tcl_AppendObjToObj(varNamePtr, hPtr->key.objPtr);
   747         -		Tcl_AppendToObj(varNamePtr, ")", -1);
   748         -		break;
   749         -	    }
   750         -	    hPtr = Tcl_NextHashEntry(&search);
   751         -	}
          816  +	Tcl_AppendToObj(varNamePtr, "(", -1);
          817  +	Tcl_AppendObjToObj(varNamePtr, ((VarInHash *)
          818  +		varPtr)->entry.key.objPtr);
          819  +	Tcl_AppendToObj(varNamePtr, ")", -1);
   752    820       } else {
   753    821   	Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
   754    822       }
   755    823       Tcl_SetObjResult(interp, varNamePtr);
   756    824       return TCL_OK;
   757    825   }
   758    826   

Changes to generic/tclOOCall.c.

    41     41   #define BUILDING_MIXINS	   0x400000
    42     42   #define TRAVERSED_MIXIN	   0x800000
    43     43   #define OBJECT_MIXIN	   0x1000000
    44     44   #define MIXIN_CONSISTENT(flags) \
    45     45       (((flags) & OBJECT_MIXIN) ||					\
    46     46   	!((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN))
    47     47   
           48  +/*
           49  + * Note that the flag bit PRIVATE_METHOD has a confusing name; it's just for
           50  + * Itcl's special type of private.
           51  + */
           52  +
           53  +#define IS_PUBLIC(mPtr)				\
           54  +    (((mPtr)->flags & PUBLIC_METHOD) != 0)
           55  +#define IS_UNEXPORTED(mPtr)			\
           56  +    (((mPtr)->flags & SCOPE_FLAGS) == 0)
           57  +#define IS_ITCLPRIVATE(mPtr)				\
           58  +    (((mPtr)->flags & PRIVATE_METHOD) != 0)
           59  +#define IS_PRIVATE(mPtr)			\
           60  +    (((mPtr)->flags & TRUE_PRIVATE_METHOD) != 0)
           61  +#define WANT_PUBLIC(flags)			\
           62  +    (((flags) & PUBLIC_METHOD) != 0)
           63  +#define WANT_UNEXPORTED(flags)			\
           64  +    (((flags) & (PRIVATE_METHOD | TRUE_PRIVATE_METHOD)) == 0)
           65  +#define WANT_ITCLPRIVATE(flags)			\
           66  +    (((flags) & PRIVATE_METHOD) != 0)
           67  +#define WANT_PRIVATE(flags)			\
           68  +    (((flags) & TRUE_PRIVATE_METHOD) != 0)
           69  +
    48     70   /*
    49     71    * Function declarations for things defined in this file.
    50     72    */
    51     73   
    52     74   static void		AddClassFiltersToCallContext(Object *const oPtr,
    53     75   			    Class *clsPtr, struct ChainBuilder *const cbPtr,
    54     76   			    Tcl_HashTable *const doneFilters, int flags);
................................................................................
    55     77   static void		AddClassMethodNames(Class *clsPtr, const int flags,
    56     78   			    Tcl_HashTable *const namesPtr,
    57     79   			    Tcl_HashTable *const examinedClassesPtr);
    58     80   static inline void	AddMethodToCallChain(Method *const mPtr,
    59     81   			    struct ChainBuilder *const cbPtr,
    60     82   			    Tcl_HashTable *const doneFilters,
    61     83   			    Class *const filterDecl, int flags);
    62         -static inline void	AddSimpleChainToCallContext(Object *const oPtr,
           84  +static inline int	AddInstancePrivateToCallContext(Object *const oPtr,
           85  +			    Tcl_Obj *const methodNameObj,
           86  +			    struct ChainBuilder *const cbPtr, int flags);
           87  +static inline void	AddStandardMethodName(int flags, Tcl_Obj *namePtr,
           88  +			    Method *mPtr, Tcl_HashTable *namesPtr);
           89  +static inline void	AddPrivateMethodNames(Tcl_HashTable *methodsTablePtr,
           90  +			    Tcl_HashTable *namesPtr);
           91  +static inline int	AddSimpleChainToCallContext(Object *const oPtr,
           92  +			    Class *const contextCls,
           93  +			    Tcl_Obj *const methodNameObj,
           94  +			    struct ChainBuilder *const cbPtr,
           95  +			    Tcl_HashTable *const doneFilters, int flags,
           96  +			    Class *const filterDecl);
           97  +static int		AddPrivatesFromClassChainToCallContext(Class *classPtr,
           98  +			    Class *const contextCls,
    63     99   			    Tcl_Obj *const methodNameObj,
    64    100   			    struct ChainBuilder *const cbPtr,
    65    101   			    Tcl_HashTable *const doneFilters, int flags,
    66    102   			    Class *const filterDecl);
    67         -static void		AddSimpleClassChainToCallContext(Class *classPtr,
          103  +static int		AddSimpleClassChainToCallContext(Class *classPtr,
    68    104   			    Tcl_Obj *const methodNameObj,
    69    105   			    struct ChainBuilder *const cbPtr,
    70    106   			    Tcl_HashTable *const doneFilters, int flags,
    71    107   			    Class *const filterDecl);
    72    108   static int		CmpStr(const void *ptr1, const void *ptr2);
    73    109   static void		DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr);
    74    110   static Tcl_NRPostProc	FinalizeMethodRefs;
    75    111   static void		FreeMethodNameRep(Tcl_Obj *objPtr);
    76    112   static inline int	IsStillValid(CallChain *callPtr, Object *oPtr,
    77    113   			    int flags, int reuseMask);
    78    114   static Tcl_NRPostProc	ResetFilterFlags;
    79    115   static Tcl_NRPostProc	SetFilterFlags;
          116  +static int		SortMethodNames(Tcl_HashTable *namesPtr, int flags,
          117  +			    const char ***stringsPtr);
    80    118   static inline void	StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr);
    81    119   
    82    120   /*
    83    121    * Object type used to manage type caches attached to method names.
    84    122    */
    85    123   
    86    124   static const Tcl_ObjType methodNameType = {
................................................................................
   362    400    *
   363    401    * ----------------------------------------------------------------------
   364    402    */
   365    403   
   366    404   int
   367    405   TclOOGetSortedMethodList(
   368    406       Object *oPtr,		/* The object to get the method names for. */
          407  +    Object *contextObj,		/* From what context object we are inquiring.
          408  +				 * NULL when the context shouldn't see
          409  +				 * object-level private methods. Note that
          410  +				 * flags can override this. */
          411  +    Class *contextCls,		/* From what context class we are inquiring.
          412  +				 * NULL when the context shouldn't see
          413  +				 * class-level private methods. Note that
          414  +				 * flags can override this. */
   369    415       int flags,			/* Whether we just want the public method
   370    416   				 * names. */
   371    417       const char ***stringsPtr)	/* Where to write a pointer to the array of
   372    418   				 * strings to. */
   373    419   {
   374    420       Tcl_HashTable names;	/* Tcl_Obj* method name to "wanted in list"
   375    421   				 * mapping. */
   376    422       Tcl_HashTable examinedClasses;
   377    423   				/* Used to track what classes have been looked
   378    424   				 * at. Is set-like in nature and keyed by
   379    425   				 * pointer to class. */
   380    426       FOREACH_HASH_DECLS;
   381         -    int i;
          427  +    int i, numStrings;
   382    428       Class *mixinPtr;
   383    429       Tcl_Obj *namePtr;
   384    430       Method *mPtr;
   385         -    int isWantedIn;
   386         -    void *isWanted;
   387    431   
   388    432       Tcl_InitObjHashTable(&names);
   389    433       Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS);
   390    434   
   391    435       /*
   392    436        * Name the bits used in the names table values.
   393    437        */
................................................................................
   396    440   
   397    441       /*
   398    442        * Process method names due to the object.
   399    443        */
   400    444   
   401    445       if (oPtr->methodsPtr) {
   402    446   	FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
   403         -	    int isNew;
   404         -
   405         -	    if ((mPtr->flags & PRIVATE_METHOD) && !(flags & PRIVATE_METHOD)) {
          447  +	    if (IS_PRIVATE(mPtr)) {
          448  +		continue;
          449  +	    }
          450  +	    if (IS_UNEXPORTED(mPtr) && !WANT_UNEXPORTED(flags)) {
   406    451   		continue;
   407    452   	    }
   408         -	    hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew);
   409         -	    if (isNew) {
   410         -		isWantedIn = ((!(flags & PUBLIC_METHOD)
   411         -			|| mPtr->flags & PUBLIC_METHOD) ? IN_LIST : 0);
   412         -		isWantedIn |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0);
   413         -		Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn));
   414         -	    }
          453  +	    AddStandardMethodName(flags, namePtr, mPtr, &names);
   415    454   	}
   416    455       }
   417    456   
   418    457       /*
   419    458        * Process method names due to private methods on the object's class.
   420    459        */
   421    460   
   422         -    if (flags & PRIVATE_METHOD) {
          461  +    if (WANT_UNEXPORTED(flags)) {
   423    462   	FOREACH_HASH(namePtr, mPtr, &oPtr->selfCls->classMethods) {
   424         -	    if (mPtr->flags & PRIVATE_METHOD) {
   425         -		int isNew;
   426         -
   427         -		hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew);
   428         -		if (isNew) {
   429         -		    isWantedIn = IN_LIST;
   430         -		    if (mPtr->typePtr == NULL) {
   431         -			isWantedIn |= NO_IMPLEMENTATION;
   432         -		    }
   433         -		    Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn));
   434         -		} else if (mPtr->typePtr != NULL) {
   435         -		    isWantedIn = PTR2INT(Tcl_GetHashValue(hPtr));
   436         -		    if (isWantedIn & NO_IMPLEMENTATION) {
   437         -			isWantedIn &= ~NO_IMPLEMENTATION;
   438         -			Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn));
   439         -		    }
   440         -		}
          463  +	    if (IS_UNEXPORTED(mPtr)) {
          464  +		AddStandardMethodName(flags, namePtr, mPtr, &names);
   441    465   	    }
   442    466   	}
   443    467       }
          468  +
          469  +    /*
          470  +     * Process method names due to private methods on the context's object or
          471  +     * class. Which must be correct if either are not NULL.
          472  +     */
          473  +
          474  +    if (contextObj && contextObj->methodsPtr) {
          475  +	AddPrivateMethodNames(contextObj->methodsPtr, &names);
          476  +    }
          477  +    if (contextCls) {
          478  +	AddPrivateMethodNames(&contextCls->classMethods, &names);
          479  +    }
   444    480   
   445    481       /*
   446    482        * Process (normal) method names from the class hierarchy and the mixin
   447    483        * hierarchy.
   448    484        */
   449    485   
   450    486       AddClassMethodNames(oPtr->selfCls, flags, &names, &examinedClasses);
   451    487       FOREACH(mixinPtr, oPtr->mixins) {
   452         -	AddClassMethodNames(mixinPtr, flags|TRAVERSED_MIXIN, &names,
          488  +	AddClassMethodNames(mixinPtr, flags | TRAVERSED_MIXIN, &names,
   453    489   		&examinedClasses);
   454    490       }
   455    491   
          492  +    /*
          493  +     * Tidy up, sort the names and resolve finally whether we really want
          494  +     * them (processing export layering).
          495  +     */
          496  +
   456    497       Tcl_DeleteHashTable(&examinedClasses);
   457         -
   458         -    /*
   459         -     * See how many (visible) method names there are. If none, we do not (and
   460         -     * should not) try to sort the list of them.
   461         -     */
   462         -
   463         -    i = 0;
   464         -    if (names.numEntries != 0) {
   465         -	const char **strings;
   466         -
   467         -	/*
   468         -	 * We need to build the list of methods to sort. We will be using
   469         -	 * qsort() for this, because it is very unlikely that the list will be
   470         -	 * heavily sorted when it is long enough to matter.
   471         -	 */
   472         -
   473         -	strings = ckalloc(sizeof(char *) * names.numEntries);
   474         -	FOREACH_HASH(namePtr, isWanted, &names) {
   475         -	    if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) {
   476         -		if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
   477         -		    continue;
   478         -		}
   479         -		strings[i++] = TclGetString(namePtr);
   480         -	    }
   481         -	}
   482         -
   483         -	/*
   484         -	 * Note that 'i' may well be less than names.numEntries when we are
   485         -	 * dealing with public method names.
   486         -	 */
   487         -
   488         -	if (i > 0) {
   489         -	    if (i > 1) {
   490         -		qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr);
   491         -	    }
   492         -	    *stringsPtr = strings;
   493         -	} else {
   494         -	    ckfree(strings);
   495         -	}
   496         -    }
   497         -
          498  +    numStrings = SortMethodNames(&names, flags, stringsPtr);
   498    499       Tcl_DeleteHashTable(&names);
   499         -    return i;
          500  +    return numStrings;
   500    501   }
   501    502   
   502    503   int
   503    504   TclOOGetSortedClassMethodList(
   504    505       Class *clsPtr,		/* The class to get the method names for. */
   505    506       int flags,			/* Whether we just want the public method
   506    507   				 * names. */
................................................................................
   509    510   {
   510    511       Tcl_HashTable names;	/* Tcl_Obj* method name to "wanted in list"
   511    512   				 * mapping. */
   512    513       Tcl_HashTable examinedClasses;
   513    514   				/* Used to track what classes have been looked
   514    515   				 * at. Is set-like in nature and keyed by
   515    516   				 * pointer to class. */
   516         -    FOREACH_HASH_DECLS;
   517         -    int i;
   518         -    Tcl_Obj *namePtr;
   519         -    void *isWanted;
          517  +    int numStrings;
   520    518   
   521    519       Tcl_InitObjHashTable(&names);
   522    520       Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS);
   523    521   
   524    522       /*
   525    523        * Process method names from the class hierarchy and the mixin hierarchy.
   526    524        */
   527    525   
   528    526       AddClassMethodNames(clsPtr, flags, &names, &examinedClasses);
   529    527       Tcl_DeleteHashTable(&examinedClasses);
   530    528   
          529  +    /*
          530  +     * Process private method names if we should. [TIP 500]
          531  +     */
          532  +
          533  +    if (WANT_PRIVATE(flags)) {
          534  +	AddPrivateMethodNames(&clsPtr->classMethods, &names);
          535  +	flags &= ~TRUE_PRIVATE_METHOD;
          536  +    }
          537  +
          538  +    /*
          539  +     * Tidy up, sort the names and resolve finally whether we really want
          540  +     * them (processing export layering).
          541  +     */
          542  +
          543  +    numStrings = SortMethodNames(&names, flags, stringsPtr);
          544  +    Tcl_DeleteHashTable(&names);
          545  +    return numStrings;
          546  +}
          547  +
          548  +/*
          549  + * ----------------------------------------------------------------------
          550  + *
          551  + * SortMethodNames --
          552  + *
          553  + *	Shared helper for TclOOGetSortedMethodList etc. that knows the method
          554  + *	sorting rules.
          555  + *
          556  + * Returns:
          557  + *	The length of the sorted list.
          558  + *
          559  + * ----------------------------------------------------------------------
          560  + */
          561  +
          562  +static int
          563  +SortMethodNames(
          564  +    Tcl_HashTable *namesPtr,	/* The table of names; unsorted, but contains
          565  +				 * whether the names are wanted and under what
          566  +				 * circumstances. */
          567  +    int flags,			/* Whether we are looking for unexported
          568  +				 * methods. Full private methods are handled
          569  +				 * on insertion to the table. */
          570  +    const char ***stringsPtr)	/* Where to store the sorted list of strings
          571  +				 * that we produce. ckalloced() */
          572  +{
          573  +    const char **strings;
          574  +    FOREACH_HASH_DECLS;
          575  +    Tcl_Obj *namePtr;
          576  +    void *isWanted;
          577  +    int i = 0;
          578  +
   531    579       /*
   532    580        * See how many (visible) method names there are. If none, we do not (and
   533    581        * should not) try to sort the list of them.
   534    582        */
   535    583   
   536         -    i = 0;
   537         -    if (names.numEntries != 0) {
   538         -	const char **strings;
   539         -
   540         -	/*
   541         -	 * We need to build the list of methods to sort. We will be using
   542         -	 * qsort() for this, because it is very unlikely that the list will be
   543         -	 * heavily sorted when it is long enough to matter.
   544         -	 */
   545         -
   546         -	strings = ckalloc(sizeof(char *) * names.numEntries);
   547         -	FOREACH_HASH(namePtr, isWanted, &names) {
   548         -	    if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) {
   549         -		if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
   550         -		    continue;
   551         -		}
   552         -		strings[i++] = TclGetString(namePtr);
   553         -	    }
   554         -	}
   555         -
   556         -	/*
   557         -	 * Note that 'i' may well be less than names.numEntries when we are
   558         -	 * dealing with public method names.
   559         -	 */
   560         -
   561         -	if (i > 0) {
   562         -	    if (i > 1) {
   563         -		qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr);
   564         -	    }
   565         -	    *stringsPtr = strings;
   566         -	} else {
   567         -	    ckfree(strings);
   568         -	}
   569         -    }
   570         -
   571         -    Tcl_DeleteHashTable(&names);
          584  +    if (namesPtr->numEntries == 0) {
          585  +	*stringsPtr = NULL;
          586  +	return 0;
          587  +    }
          588  +
          589  +    /*
          590  +     * We need to build the list of methods to sort. We will be using qsort()
          591  +     * for this, because it is very unlikely that the list will be heavily
          592  +     * sorted when it is long enough to matter.
          593  +     */
          594  +
          595  +    strings = ckalloc(sizeof(char *) * namesPtr->numEntries);
          596  +    FOREACH_HASH(namePtr, isWanted, namesPtr) {
          597  +	if (!WANT_PUBLIC(flags) || (PTR2INT(isWanted) & IN_LIST)) {
          598  +	    if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
          599  +		continue;
          600  +	    }
          601  +	    strings[i++] = TclGetString(namePtr);
          602  +	}
          603  +    }
          604  +
          605  +    /*
          606  +     * Note that 'i' may well be less than names.numEntries when we are
          607  +     * dealing with public method names. We don't sort unless there's at least
          608  +     * two method names.
          609  +     */
          610  +
          611  +    if (i > 0) {
          612  +	if (i > 1) {
          613  +	    qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr);
          614  +	}
          615  +	*stringsPtr = strings;
          616  +    } else {
          617  +	ckfree(strings);
          618  +	*stringsPtr = NULL;
          619  +    }
   572    620       return i;
   573    621   }
   574    622   
   575         -/* Comparator for GetSortedMethodList */
          623  +/* Comparator for SortMethodNames */
   576    624   static int
   577    625   CmpStr(
   578    626       const void *ptr1,
   579    627       const void *ptr2)
   580    628   {
   581    629       const char **strPtr1 = (const char **) ptr1;
   582    630       const char **strPtr2 = (const char **) ptr2;
   583    631   
   584         -    return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1)+1);
          632  +    return TclpUtfNcmp2(*strPtr1, *strPtr2, strlen(*strPtr1) + 1);
   585    633   }
   586    634   
   587    635   /*
   588    636    * ----------------------------------------------------------------------
   589    637    *
   590    638    * AddClassMethodNames --
   591    639    *
................................................................................
   610    658   				 * semantics are handled correctly. */
   611    659       Tcl_HashTable *const examinedClassesPtr)
   612    660   				/* Hash table that tracks what classes have
   613    661   				 * already been looked at. The keys are the
   614    662   				 * pointers to the classes, and the values are
   615    663   				 * immaterial. */
   616    664   {
          665  +    int i;
          666  +
   617    667       /*
   618    668        * If we've already started looking at this class, stop working on it now
   619    669        * to prevent repeated work.
   620    670        */
   621    671   
   622    672       if (Tcl_FindHashEntry(examinedClassesPtr, (char *) clsPtr)) {
   623    673   	return;
................................................................................
   640    690   		&isNew);
   641    691   	if (!isNew) {
   642    692   	    break;
   643    693   	}
   644    694   
   645    695   	if (clsPtr->mixins.num != 0) {
   646    696   	    Class *mixinPtr;
   647         -	    int i;
   648    697   
   649    698   	    FOREACH(mixinPtr, clsPtr->mixins) {
   650    699   		if (mixinPtr != clsPtr) {
   651    700   		    AddClassMethodNames(mixinPtr, flags|TRAVERSED_MIXIN,
   652    701   			    namesPtr, examinedClassesPtr);
   653    702   		}
   654    703   	    }
   655    704   	}
   656    705   
   657    706   	FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
   658         -	    hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew);
   659         -	    if (isNew) {
   660         -		int isWanted = (!(flags & PUBLIC_METHOD)
   661         -			|| (mPtr->flags & PUBLIC_METHOD)) ? IN_LIST : 0;
   662         -
   663         -		isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0);
   664         -		Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
   665         -	    } else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION)
   666         -		    && mPtr->typePtr != NULL) {
   667         -		int isWanted = PTR2INT(Tcl_GetHashValue(hPtr));
   668         -
   669         -		isWanted &= ~NO_IMPLEMENTATION;
   670         -		Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
   671         -	    }
          707  +	    AddStandardMethodName(flags, namePtr, mPtr, namesPtr);
   672    708   	}
   673    709   
   674    710   	if (clsPtr->superclasses.num != 1) {
   675    711   	    break;
   676    712   	}
   677    713   	clsPtr = clsPtr->superclasses.list[0];
   678    714       }
   679    715       if (clsPtr->superclasses.num != 0) {
   680    716   	Class *superPtr;
   681         -	int i;
   682    717   
   683    718   	FOREACH(superPtr, clsPtr->superclasses) {
   684    719   	    AddClassMethodNames(superPtr, flags, namesPtr,
   685    720   		    examinedClassesPtr);
   686    721   	}
   687    722       }
   688    723   }
   689    724   
   690    725   /*
   691    726    * ----------------------------------------------------------------------
   692    727    *
          728  + * AddPrivateMethodNames, AddStandardMethodName --
          729  + *
          730  + *	Factored-out helpers for the sorted name list production functions.
          731  + *
          732  + * ----------------------------------------------------------------------
          733  + */
          734  +
          735  +static inline void
          736  +AddPrivateMethodNames(
          737  +    Tcl_HashTable *methodsTablePtr,
          738  +    Tcl_HashTable *namesPtr)
          739  +{
          740  +    FOREACH_HASH_DECLS;
          741  +    Method *mPtr;
          742  +    Tcl_Obj *namePtr;
          743  +
          744  +    FOREACH_HASH(namePtr, mPtr, methodsTablePtr) {
          745  +	if (IS_PRIVATE(mPtr)) {
          746  +	    int isNew;
          747  +
          748  +	    hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew);
          749  +	    Tcl_SetHashValue(hPtr, INT2PTR(IN_LIST));
          750  +	}
          751  +    }
          752  +}
          753  +
          754  +static inline void
          755  +AddStandardMethodName(
          756  +    int flags,
          757  +    Tcl_Obj *namePtr,
          758  +    Method *mPtr,
          759  +    Tcl_HashTable *namesPtr)
          760  +{
          761  +    if (!IS_PRIVATE(mPtr)) {
          762  +	int isNew;
          763  +	Tcl_HashEntry *hPtr =
          764  +		Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew);
          765  +
          766  +	if (isNew) {
          767  +	    int isWanted = (!WANT_PUBLIC(flags) || IS_PUBLIC(mPtr))
          768  +		    ? IN_LIST : 0;
          769  +
          770  +	    isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0);
          771  +	    Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
          772  +	} else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION)
          773  +		&& mPtr->typePtr != NULL) {
          774  +	    int isWanted = PTR2INT(Tcl_GetHashValue(hPtr));
          775  +
          776  +	    isWanted &= ~NO_IMPLEMENTATION;
          777  +	    Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
          778  +	}
          779  +    }
          780  +}
          781  +
          782  +#undef IN_LIST
          783  +#undef NO_IMPLEMENTATION
          784  +
          785  +/*
          786  + * ----------------------------------------------------------------------
          787  + *
          788  + * AddInstancePrivateToCallContext --
          789  + *
          790  + *	Add private methods from the instance. Called when the calling Tcl
          791  + *	context is a TclOO method declared by an object that is the same as
          792  + *	the current object. Returns true iff a private method was actually
          793  + *	found and added to the call chain (as this suppresses caching).
          794  + *
          795  + * ----------------------------------------------------------------------
          796  + */
          797  +
          798  +static inline int
          799  +AddInstancePrivateToCallContext(
          800  +    Object *const oPtr,		/* Object to add call chain entries for. */
          801  +    Tcl_Obj *const methodName,	/* Name of method to add the call chain
          802  +				 * entries for. */
          803  +    struct ChainBuilder *const cbPtr,
          804  +				/* Where to add the call chain entries. */
          805  +    int flags)			/* What sort of call chain are we building. */
          806  +{
          807  +    Tcl_HashEntry *hPtr;
          808  +    Method *mPtr;
          809  +    int donePrivate = 0;
          810  +
          811  +    if (oPtr->methodsPtr) {
          812  +	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodName);
          813  +	if (hPtr != NULL) {
          814  +	    mPtr = Tcl_GetHashValue(hPtr);
          815  +	    if (IS_PRIVATE(mPtr)) {
          816  +		AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags);
          817  +		donePrivate = 1;
          818  +	    }
          819  +	}
          820  +    }
          821  +    return donePrivate;
          822  +}
          823  +
          824  +/*
          825  + * ----------------------------------------------------------------------
          826  + *
   693    827    * AddSimpleChainToCallContext --
   694    828    *
   695    829    *	The core of the call-chain construction engine, this handles calling a
   696    830    *	particular method on a particular object. Note that filters and
   697    831    *	unknown handling are already handled by the logic that uses this
   698         - *	function.
          832  + *	function. Returns true if a private method was one of those found.
   699    833    *
   700    834    * ----------------------------------------------------------------------
   701    835    */
   702    836   
   703         -static inline void
          837  +static inline int
   704    838   AddSimpleChainToCallContext(
   705    839       Object *const oPtr,		/* Object to add call chain entries for. */
          840  +    Class *const contextCls,	/* Context class; the currently considered
          841  +				 * class is equal to this, private methods may
          842  +				 * also be added. [TIP 500] */
   706    843       Tcl_Obj *const methodNameObj,
   707    844   				/* Name of method to add the call chain
   708    845   				 * entries for. */
   709    846       struct ChainBuilder *const cbPtr,
   710    847   				/* Where to add the call chain entries. */
   711    848       Tcl_HashTable *const doneFilters,
   712    849   				/* Where to record what call chain entries
   713    850   				 * have been processed. */
   714    851       int flags,			/* What sort of call chain are we building. */
   715    852       Class *const filterDecl)	/* The class that declared the filter. If
   716    853   				 * NULL, either the filter was declared by the
   717    854   				 * object or this isn't a filter. */
   718    855   {
   719         -    int i;
          856  +    int i, foundPrivate = 0, blockedUnexported = 0;
          857  +    Tcl_HashEntry *hPtr;
          858  +    Method *mPtr;
   720    859   
   721    860       if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) {
   722         -	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(oPtr->methodsPtr,
   723         -		(char *) methodNameObj);
          861  +	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj);
   724    862   
   725    863   	if (hPtr != NULL) {
   726         -	    Method *mPtr = Tcl_GetHashValue(hPtr);
   727         -
   728         -	    if (flags & PUBLIC_METHOD) {
   729         -		if (!(mPtr->flags & PUBLIC_METHOD)) {
   730         -		    return;
          864  +	    mPtr = Tcl_GetHashValue(hPtr);
          865  +	    if (!IS_PRIVATE(mPtr)) {
          866  +		if (WANT_PUBLIC(flags)) {
          867  +		    if (!IS_PUBLIC(mPtr)) {
          868  +			blockedUnexported = 1;
          869  +		    } else {
          870  +			flags |= DEFINITE_PUBLIC;
          871  +		    }
   731    872   		} else {
   732         -		    flags |= DEFINITE_PUBLIC;
          873  +		    flags |= DEFINITE_PROTECTED;
   733    874   		}
   734         -	    } else {
   735         -		flags |= DEFINITE_PROTECTED;
   736    875   	    }
   737    876   	}
   738    877       }
   739    878       if (!(flags & SPECIAL)) {
   740         -	Tcl_HashEntry *hPtr;
   741    879   	Class *mixinPtr;
   742    880   
   743    881   	FOREACH(mixinPtr, oPtr->mixins) {
   744         -	    AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr,
   745         -		    doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
          882  +	    if (contextCls) {
          883  +		foundPrivate |= AddPrivatesFromClassChainToCallContext(
          884  +			mixinPtr, contextCls, methodNameObj, cbPtr,
          885  +			doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
          886  +	    }
          887  +	    foundPrivate |= AddSimpleClassChainToCallContext(mixinPtr,
          888  +		    methodNameObj, cbPtr, doneFilters,
          889  +		    flags | TRAVERSED_MIXIN, filterDecl);
   746    890   	}
   747         -	if (oPtr->methodsPtr) {
          891  +	if (oPtr->methodsPtr && !blockedUnexported) {
   748    892   	    hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj);
   749    893   	    if (hPtr != NULL) {
   750         -		AddMethodToCallChain(Tcl_GetHashValue(hPtr), cbPtr,
   751         -			doneFilters, filterDecl, flags);
          894  +		mPtr = Tcl_GetHashValue(hPtr);
          895  +		if (!IS_PRIVATE(mPtr)) {
          896  +		    AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
          897  +			    flags);
          898  +		}
   752    899   	    }
   753    900   	}
   754    901       }
   755         -    AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr,
   756         -	    doneFilters, flags, filterDecl);
          902  +    if (contextCls) {
          903  +	foundPrivate |= AddPrivatesFromClassChainToCallContext(oPtr->selfCls,
          904  +		contextCls, methodNameObj, cbPtr, doneFilters, flags,
          905  +		filterDecl);
          906  +    }
          907  +    if (!blockedUnexported) {
          908  +	foundPrivate |= AddSimpleClassChainToCallContext(oPtr->selfCls,
          909  +		methodNameObj, cbPtr, doneFilters, flags, filterDecl);
          910  +    }
          911  +    return foundPrivate;
   757    912   }
   758    913   
   759    914   /*
   760    915    * ----------------------------------------------------------------------
   761    916    *
   762    917    * AddMethodToCallChain --
   763    918    *
................................................................................
   812    967        *  3) this is a class method, AND
   813    968        *  4) this method was not declared by the class of the current object.
   814    969        *
   815    970        * This does mean that only classes really handle private methods. This
   816    971        * should be sufficient for [incr Tcl] support though.
   817    972        */
   818    973   
   819         -    if (!(callPtr->flags & PRIVATE_METHOD)
   820         -	    && (mPtr->flags & PRIVATE_METHOD)
          974  +    if (!WANT_UNEXPORTED(callPtr->flags)
          975  +	    && IS_UNEXPORTED(mPtr)
   821    976   	    && (mPtr->declaringClassPtr != NULL)
   822    977   	    && (mPtr->declaringClassPtr != cbPtr->oPtr->selfCls)) {
   823    978   	return;
   824    979       }
   825    980   
   826    981       /*
   827    982        * First test whether the method is already in the call chain. Skip over
................................................................................
   854   1009        * Need to really add the method. This is made a bit more complex by the
   855   1010        * fact that we are using some "static" space initially, and only start
   856   1011        * realloc-ing if the chain gets long.
   857   1012        */
   858   1013   
   859   1014       if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) {
   860   1015   	callPtr->chain =
   861         -		ckalloc(sizeof(struct MInvoke) * (callPtr->numChain+1));
         1016  +		ckalloc(sizeof(struct MInvoke) * (callPtr->numChain + 1));
   862   1017   	memcpy(callPtr->chain, callPtr->staticChain,
   863   1018   		sizeof(struct MInvoke) * callPtr->numChain);
   864   1019       } else if (callPtr->numChain > CALL_CHAIN_STATIC_SIZE) {
   865   1020   	callPtr->chain = ckrealloc(callPtr->chain,
   866   1021   		sizeof(struct MInvoke) * (callPtr->numChain + 1));
   867   1022       }
   868   1023       callPtr->chain[i].mPtr = mPtr;
................................................................................
   953   1108       Tcl_Obj *methodNameObj,	/* The name of the method to get the context
   954   1109   				 * for. NULL when getting a constructor or
   955   1110   				 * destructor chain. */
   956   1111       int flags,			/* What sort of context are we looking for.
   957   1112   				 * Only the bits PUBLIC_METHOD, CONSTRUCTOR,
   958   1113   				 * PRIVATE_METHOD, DESTRUCTOR and
   959   1114   				 * FILTER_HANDLING are useful. */
         1115  +    Object *contextObj,		/* Context object; when equal to oPtr, it
         1116  +				 * means that private methods may also be
         1117  +				 * added. [TIP 500] */
         1118  +    Class *contextCls,		/* Context class; the currently considered
         1119  +				 * class is equal to this, private methods may
         1120  +				 * also be added. [TIP 500] */
   960   1121       Tcl_Obj *cacheInThisObj)	/* What object to cache in, or NULL if it is
   961   1122   				 * to be in the same object as the
   962   1123   				 * methodNameObj. */
   963   1124   {
   964   1125       CallContext *contextPtr;
   965   1126       CallChain *callPtr;
   966   1127       struct ChainBuilder cb;
   967         -    int i, count, doFilters;
         1128  +    int i, count, doFilters, donePrivate = 0;
   968   1129       Tcl_HashEntry *hPtr;
   969   1130       Tcl_HashTable doneFilters;
   970   1131   
   971   1132       if (cacheInThisObj == NULL) {
   972   1133   	cacheInThisObj = methodNameObj;
   973   1134       }
   974   1135       if (flags&(SPECIAL|FILTER_HANDLING) || (oPtr->flags&FILTER_HANDLING)) {
................................................................................
  1000   1161   	/*
  1001   1162   	 * Check if we can get the chain out of the Tcl_Obj method name or out
  1002   1163   	 * of the cache. This is made a bit more complex by the fact that
  1003   1164   	 * there are multiple different layers of cache (in the Tcl_Obj, in
  1004   1165   	 * the object, and in the class).
  1005   1166   	 */
  1006   1167   
  1007         -	const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);
         1168  +	const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
  1008   1169   
  1009   1170   	if (cacheInThisObj->typePtr == &methodNameType) {
  1010   1171   	    callPtr = cacheInThisObj->internalRep.twoPtrValue.ptr1;
  1011   1172   	    if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
  1012   1173   		callPtr->refCount++;
  1013   1174   		goto returnContext;
  1014   1175   	    }
................................................................................
  1052   1213       cb.oPtr = oPtr;
  1053   1214   
  1054   1215       /*
  1055   1216        * If we're working with a forced use of unknown, do that now.
  1056   1217        */
  1057   1218   
  1058   1219       if (flags & FORCE_UNKNOWN) {
  1059         -	AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
  1060         -		&cb, NULL, BUILDING_MIXINS, NULL);
  1061         -	AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
  1062         -		&cb, NULL, 0, NULL);
         1220  +	AddSimpleChainToCallContext(oPtr, NULL,
         1221  +		oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS,
         1222  +		NULL);
         1223  +	AddSimpleChainToCallContext(oPtr, NULL,
         1224  +		oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL);
  1063   1225   	callPtr->flags |= OO_UNKNOWN_METHOD;
  1064   1226   	callPtr->epoch = -1;
  1065   1227   	if (callPtr->numChain == 0) {
  1066   1228   	    TclOODeleteChain(callPtr);
  1067   1229   	    return NULL;
  1068   1230   	}
  1069   1231   	goto returnContext;
................................................................................
  1084   1246   	FOREACH(mixinPtr, oPtr->mixins) {
  1085   1247   	    AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters,
  1086   1248   		    TRAVERSED_MIXIN|BUILDING_MIXINS|OBJECT_MIXIN);
  1087   1249   	    AddClassFiltersToCallContext(oPtr, mixinPtr, &cb, &doneFilters,
  1088   1250   		    OBJECT_MIXIN);
  1089   1251   	}
  1090   1252   	FOREACH(filterObj, oPtr->filters) {
  1091         -	    AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters,
  1092         -		    BUILDING_MIXINS, NULL);
  1093         -	    AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0,
  1094         -		    NULL);
         1253  +	    donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls,
         1254  +		    filterObj, &cb, &doneFilters, BUILDING_MIXINS, NULL);
         1255  +	    donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls,
         1256  +		    filterObj, &cb, &doneFilters, 0, NULL);
  1095   1257   	}
  1096   1258   	AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters,
  1097   1259   		BUILDING_MIXINS);
  1098   1260   	AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters,
  1099   1261   		0);
  1100   1262   	Tcl_DeleteHashTable(&doneFilters);
  1101   1263       }
................................................................................
  1102   1264       count = cb.filterLength = callPtr->numChain;
  1103   1265   
  1104   1266       /*
  1105   1267        * Add the actual method implementations. We have to do this twice to
  1106   1268        * handle class mixins right.
  1107   1269        */
  1108   1270   
  1109         -    AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL,
  1110         -	    flags|BUILDING_MIXINS, NULL);
  1111         -    AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL);
         1271  +    if (oPtr == contextObj) {
         1272  +	donePrivate |= AddInstancePrivateToCallContext(oPtr, methodNameObj,
         1273  +		&cb, flags);
         1274  +	donePrivate |= (contextObj->flags & HAS_PRIVATE_METHODS);
         1275  +    }
         1276  +    donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls,
         1277  +	    methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL);
         1278  +    donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls,
         1279  +	    methodNameObj, &cb, NULL, flags, NULL);
  1112   1280   
  1113   1281       /*
  1114   1282        * Check to see if the method has no implementation. If so, we probably
  1115   1283        * need to add in a call to the unknown method. Otherwise, set up the
  1116   1284        * cacheing of the method implementation (if relevant).
  1117   1285        */
  1118   1286   
................................................................................
  1122   1290   	 * or destructors, this isn't a problem.
  1123   1291   	 */
  1124   1292   
  1125   1293   	if (flags & SPECIAL) {
  1126   1294   	    TclOODeleteChain(callPtr);
  1127   1295   	    return NULL;
  1128   1296   	}
  1129         -	AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
  1130         -		&cb, NULL, BUILDING_MIXINS, NULL);
  1131         -	AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
  1132         -		&cb, NULL, 0, NULL);
         1297  +	AddSimpleChainToCallContext(oPtr, NULL,
         1298  +		oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS,
         1299  +		NULL);
         1300  +	AddSimpleChainToCallContext(oPtr, NULL,
         1301  +		oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL);
  1133   1302   	callPtr->flags |= OO_UNKNOWN_METHOD;
  1134   1303   	callPtr->epoch = -1;
  1135   1304   	if (count == callPtr->numChain) {
  1136   1305   	    TclOODeleteChain(callPtr);
  1137   1306   	    return NULL;
  1138   1307   	}
  1139         -    } else if (doFilters) {
         1308  +    } else if (doFilters && !donePrivate) {
  1140   1309   	if (hPtr == NULL) {
  1141   1310   	    if (oPtr->flags & USE_CLASS_CACHE) {
  1142   1311   		if (oPtr->selfCls->classChainCache == NULL) {
  1143   1312   		    oPtr->selfCls->classChainCache =
  1144   1313   			    ckalloc(sizeof(Tcl_HashTable));
  1145   1314   
  1146   1315   		    Tcl_InitObjHashTable(oPtr->selfCls->classChainCache);
................................................................................
  1238   1407        * in the class).
  1239   1408        */
  1240   1409   
  1241   1410       if (clsPtr->classChainCache != NULL) {
  1242   1411   	hPtr = Tcl_FindHashEntry(clsPtr->classChainCache,
  1243   1412   		(char *) methodNameObj);
  1244   1413   	if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
  1245         -	    const int reuseMask =
  1246         -		    ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);
         1414  +	    const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
  1247   1415   
  1248   1416   	    callPtr = Tcl_GetHashValue(hPtr);
  1249   1417   	    if (IsStillValid(callPtr, &obj, flags, reuseMask)) {
  1250   1418   		callPtr->refCount++;
  1251   1419   		return callPtr;
  1252   1420   	    }
  1253   1421   	    Tcl_SetHashValue(hPtr, NULL);
................................................................................
  1283   1451       Tcl_DeleteHashTable(&doneFilters);
  1284   1452       count = cb.filterLength = callPtr->numChain;
  1285   1453   
  1286   1454       /*
  1287   1455        * Add the actual method implementations.
  1288   1456        */
  1289   1457   
  1290         -    AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL,
         1458  +    AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL,
  1291   1459   	    flags|BUILDING_MIXINS, NULL);
  1292         -    AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL);
         1460  +    AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL, flags,
         1461  +	    NULL);
  1293   1462   
  1294   1463       /*
  1295   1464        * Check to see if the method has no implementation. If so, we probably
  1296   1465        * need to add in a call to the unknown method. Otherwise, set up the
  1297   1466        * cacheing of the method implementation (if relevant).
  1298   1467        */
  1299   1468   
  1300   1469       if (count == callPtr->numChain) {
  1301         -	AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb,
  1302         -		NULL, BUILDING_MIXINS, NULL);
  1303         -	AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb,
  1304         -		NULL, 0, NULL);
         1470  +	AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj,
         1471  +		&cb, NULL, BUILDING_MIXINS, NULL);
         1472  +	AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj,
         1473  +		&cb, NULL, 0, NULL);
  1305   1474   	callPtr->flags |= OO_UNKNOWN_METHOD;
  1306   1475   	callPtr->epoch = -1;
  1307   1476   	if (count == callPtr->numChain) {
  1308   1477   	    TclOODeleteChain(callPtr);
  1309   1478   	    return NULL;
  1310   1479   	}
  1311   1480       } else {
................................................................................
  1377   1546       if (MIXIN_CONSISTENT(flags)) {
  1378   1547   	FOREACH(filterObj, clsPtr->filters) {
  1379   1548   	    int isNew;
  1380   1549   
  1381   1550   	    (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj,
  1382   1551   		    &isNew);
  1383   1552   	    if (isNew) {
  1384         -		AddSimpleChainToCallContext(oPtr, filterObj, cbPtr,
         1553  +		AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr,
  1385   1554   			doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr);
  1386         -		AddSimpleChainToCallContext(oPtr, filterObj, cbPtr,
         1555  +		AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr,
  1387   1556   			doneFilters, clearedFlags, clsPtr);
  1388   1557   	    }
  1389   1558   	}
  1390   1559       }
  1391   1560   
  1392   1561       /*
  1393   1562        * Now process the recursive case. Notice the tail-call optimization.
................................................................................
  1406   1575   	return;
  1407   1576       }
  1408   1577   }
  1409   1578   
  1410   1579   /*
  1411   1580    * ----------------------------------------------------------------------
  1412   1581    *
  1413         - * AddSimpleClassChainToCallContext --
         1582  + * AddPrivatesFromClassChainToCallContext --
  1414   1583    *
  1415         - *	Construct a call-chain from a class hierarchy.
         1584  + *	Helper for AddSimpleChainToCallContext that is used to find private
         1585  + *	methds and add them to the call chain. Returns true when a private
         1586  + *	method is found and added. [TIP 500]
  1416   1587    *
  1417   1588    * ----------------------------------------------------------------------
  1418   1589    */
  1419   1590   
  1420         -static void
  1421         -AddSimpleClassChainToCallContext(
         1591  +static int
         1592  +AddPrivatesFromClassChainToCallContext(
  1422   1593       Class *classPtr,		/* Class to add the call chain entries for. */
  1423         -    Tcl_Obj *const methodNameObj,
  1424         -				/* Name of method to add the call chain
         1594  +    Class *const contextCls,	/* Context class; the currently considered
         1595  +				 * class is equal to this, private methods may
         1596  +				 * also be added. */
         1597  +    Tcl_Obj *const methodName,	/* Name of method to add the call chain
  1425   1598   				 * entries for. */
  1426   1599       struct ChainBuilder *const cbPtr,
  1427   1600   				/* Where to add the call chain entries. */
  1428   1601       Tcl_HashTable *const doneFilters,
  1429   1602   				/* Where to record what call chain entries
  1430   1603   				 * have been processed. */
  1431   1604       int flags,			/* What sort of call chain are we building. */
................................................................................
  1442   1615        *
  1443   1616        * Note that mixins must be processed before the main class hierarchy.
  1444   1617        * [Bug 1998221]
  1445   1618        */
  1446   1619   
  1447   1620     tailRecurse:
  1448   1621       FOREACH(superPtr, classPtr->mixins) {
  1449         -	AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr,
  1450         -		doneFilters, flags|TRAVERSED_MIXIN, filterDecl);
         1622  +	if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls,
         1623  +		methodName, cbPtr, doneFilters, flags|TRAVERSED_MIXIN,
         1624  +		filterDecl)) {
         1625  +	    return 1;
         1626  +	}
         1627  +    }
         1628  +
         1629  +    if (classPtr == contextCls) {
         1630  +	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
         1631  +		(char *) methodName);
         1632  +
         1633  +	if (hPtr != NULL) {
         1634  +	    register Method *mPtr = Tcl_GetHashValue(hPtr);
         1635  +
         1636  +	    if (IS_PRIVATE(mPtr)) {
         1637  +		AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
         1638  +			flags);
         1639  +		return 1;
         1640  +	    }
         1641  +	}
         1642  +    }
         1643  +
         1644  +    switch (classPtr->superclasses.num) {
         1645  +    case 1:
         1646  +	classPtr = classPtr->superclasses.list[0];
         1647  +	goto tailRecurse;
         1648  +    default:
         1649  +	FOREACH(superPtr, classPtr->superclasses) {
         1650  +	    if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls,
         1651  +		    methodName, cbPtr, doneFilters, flags, filterDecl)) {
         1652  +		return 1;
         1653  +	    }
         1654  +	}
         1655  +    case 0:
         1656  +	return 0;
         1657  +    }
         1658  +}
         1659  +
         1660  +/*
         1661  + * ----------------------------------------------------------------------
         1662  + *
         1663  + * AddSimpleClassChainToCallContext --
         1664  + *
         1665  + *	Construct a call-chain from a class hierarchy.
         1666  + *
         1667  + * ----------------------------------------------------------------------
         1668  + */
         1669  +
         1670  +static int
         1671  +AddSimpleClassChainToCallContext(
         1672  +    Class *classPtr,		/* Class to add the call chain entries for. */
         1673  +    Tcl_Obj *const methodNameObj,
         1674  +				/* Name of method to add the call chain
         1675  +				 * entries for. */
         1676  +    struct ChainBuilder *const cbPtr,
         1677  +				/* Where to add the call chain entries. */
         1678  +    Tcl_HashTable *const doneFilters,
         1679  +				/* Where to record what call chain entries
         1680  +				 * have been processed. */
         1681  +    int flags,			/* What sort of call chain are we building. */
         1682  +    Class *const filterDecl)	/* The class that declared the filter. If
         1683  +				 * NULL, either the filter was declared by the
         1684  +				 * object or this isn't a filter. */
         1685  +{
         1686  +    int i, privateDanger = 0;
         1687  +    Class *superPtr;
         1688  +
         1689  +    /*
         1690  +     * We hard-code the tail-recursive form. It's by far the most common case
         1691  +     * *and* it is much more gentle on the stack.
         1692  +     *
         1693  +     * Note that mixins must be processed before the main class hierarchy.
         1694  +     * [Bug 1998221]
         1695  +     */
         1696  +
         1697  +  tailRecurse:
         1698  +    FOREACH(superPtr, classPtr->mixins) {
         1699  +	privateDanger |= AddSimpleClassChainToCallContext(superPtr,
         1700  +		methodNameObj, cbPtr, doneFilters, flags | TRAVERSED_MIXIN,
         1701  +		filterDecl);
  1451   1702       }
  1452   1703   
  1453   1704       if (flags & CONSTRUCTOR) {
  1454   1705   	AddMethodToCallChain(classPtr->constructorPtr, cbPtr, doneFilters,
  1455   1706   		filterDecl, flags);
  1456   1707   
  1457   1708       } else if (flags & DESTRUCTOR) {
  1458   1709   	AddMethodToCallChain(classPtr->destructorPtr, cbPtr, doneFilters,
  1459   1710   		filterDecl, flags);
  1460   1711       } else {
  1461   1712   	Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
  1462   1713   		(char *) methodNameObj);
  1463   1714   
         1715  +	if (classPtr->flags & HAS_PRIVATE_METHODS) {
         1716  +	    privateDanger |= 1;
         1717  +	}
  1464   1718   	if (hPtr != NULL) {
  1465   1719   	    register Method *mPtr = Tcl_GetHashValue(hPtr);
  1466   1720   
  1467         -	    if (!(flags & KNOWN_STATE)) {
  1468         -		if (flags & PUBLIC_METHOD) {
  1469         -		    if (mPtr->flags & PUBLIC_METHOD) {
         1721  +	    if (!IS_PRIVATE(mPtr)) {
         1722  +		if (!(flags & KNOWN_STATE)) {
         1723  +		    if (flags & PUBLIC_METHOD) {
         1724  +			if (!IS_PUBLIC(mPtr)) {
         1725  +			    return privateDanger;
         1726  +			}
  1470   1727   			flags |= DEFINITE_PUBLIC;
  1471   1728   		    } else {
  1472         -			return;
         1729  +			flags |= DEFINITE_PROTECTED;
  1473   1730   		    }
  1474         -		} else {
  1475         -		    flags |= DEFINITE_PROTECTED;
  1476   1731   		}
         1732  +		AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
         1733  +			flags);
  1477   1734   	    }
  1478         -	    AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, flags);
  1479   1735   	}
  1480   1736       }
  1481   1737   
  1482   1738       switch (classPtr->superclasses.num) {
  1483   1739       case 1:
  1484   1740   	classPtr = classPtr->superclasses.list[0];
  1485   1741   	goto tailRecurse;
  1486   1742       default:
  1487   1743   	FOREACH(superPtr, classPtr->superclasses) {
  1488         -	    AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr,
  1489         -		    doneFilters, flags, filterDecl);
         1744  +	    privateDanger |= AddSimpleClassChainToCallContext(superPtr,
         1745  +		    methodNameObj, cbPtr, doneFilters, flags, filterDecl);
  1490   1746   	}
  1491   1747       case 0:
  1492         -	return;
         1748  +	return privateDanger;
  1493   1749       }
  1494   1750   }
  1495   1751   
  1496   1752   /*
  1497   1753    * ----------------------------------------------------------------------
  1498   1754    *
  1499   1755    * TclOORenderCallChain --
................................................................................
  1505   1761    */
  1506   1762   
  1507   1763   Tcl_Obj *
  1508   1764   TclOORenderCallChain(
  1509   1765       Tcl_Interp *interp,
  1510   1766       CallChain *callPtr)
  1511   1767   {
  1512         -    Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral;
         1768  +    Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral, *privateLiteral;
  1513   1769       Tcl_Obj *resultObj, *descObjs[4], **objv;
  1514   1770       Foundation *fPtr = TclOOGetFoundation(interp);
  1515   1771       int i;
  1516   1772   
  1517   1773       /*
  1518   1774        * Allocate the literals (potentially) used in our description.
  1519   1775        */
  1520   1776   
  1521         -    filterLiteral = Tcl_NewStringObj("filter", -1);
         1777  +    TclNewLiteralStringObj(filterLiteral, "filter");
  1522   1778       Tcl_IncrRefCount(filterLiteral);
  1523         -    methodLiteral = Tcl_NewStringObj("method", -1);
         1779  +    TclNewLiteralStringObj(methodLiteral, "method");
  1524   1780       Tcl_IncrRefCount(methodLiteral);
  1525         -    objectLiteral = Tcl_NewStringObj("object", -1);
         1781  +    TclNewLiteralStringObj(objectLiteral, "object");
  1526   1782       Tcl_IncrRefCount(objectLiteral);
         1783  +    TclNewLiteralStringObj(privateLiteral, "private");
         1784  +    Tcl_IncrRefCount(privateLiteral);
  1527   1785   
  1528   1786       /*
  1529   1787        * Do the actual construction of the descriptions. They consist of a list
  1530   1788        * of triples that describe the details of how a method is understood. For
  1531   1789        * each triple, the first word is the type of invocation ("method" is
  1532   1790        * normal, "unknown" is special because it adds the method name as an
  1533   1791        * extra argument when handled by some method types, and "filter" is
................................................................................
  1537   1795        * method (or "object" if it is declared on the instance).
  1538   1796        */
  1539   1797   
  1540   1798       objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
  1541   1799       for (i=0 ; i<callPtr->numChain ; i++) {
  1542   1800   	struct MInvoke *miPtr = &callPtr->chain[i];
  1543   1801   
  1544         -	descObjs[0] = miPtr->isFilter
  1545         -		? filterLiteral
  1546         -		: callPtr->flags & OO_UNKNOWN_METHOD
  1547         -			? fPtr->unknownMethodNameObj
  1548         -			: methodLiteral;
  1549         -	descObjs[1] = callPtr->flags & CONSTRUCTOR
  1550         -		? fPtr->constructorName
  1551         -		: callPtr->flags & DESTRUCTOR
  1552         -			? fPtr->destructorName
  1553         -			: miPtr->mPtr->namePtr;
         1802  +	descObjs[0] =
         1803  +	    miPtr->isFilter ? filterLiteral :
         1804  +	    callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj :
         1805  +	    IS_PRIVATE(miPtr->mPtr) ? privateLiteral :
         1806  +		    methodLiteral;
         1807  +	descObjs[1] =
         1808  +	    callPtr->flags & CONSTRUCTOR ? fPtr->constructorName :
         1809  +	    callPtr->flags & DESTRUCTOR ? fPtr->destructorName :
         1810  +		    miPtr->mPtr->namePtr;
  1554   1811   	descObjs[2] = miPtr->mPtr->declaringClassPtr
  1555   1812   		? Tcl_GetObjectName(interp,
  1556   1813   			(Tcl_Object) miPtr->mPtr->declaringClassPtr->thisPtr)
  1557   1814   		: objectLiteral;
  1558   1815   	descObjs[3] = Tcl_NewStringObj(miPtr->mPtr->typePtr->name, -1);
  1559   1816   
  1560   1817   	objv[i] = Tcl_NewListObj(4, descObjs);
................................................................................
  1564   1821        * Drop the local references to the literals; if they're actually used,
  1565   1822        * they'll live on the description itself.
  1566   1823        */
  1567   1824   
  1568   1825       Tcl_DecrRefCount(filterLiteral);
  1569   1826       Tcl_DecrRefCount(methodLiteral);
  1570   1827       Tcl_DecrRefCount(objectLiteral);
         1828  +    Tcl_DecrRefCount(privateLiteral);
  1571   1829   
  1572   1830       /*
  1573   1831        * Finish building the description and return it.
  1574   1832        */
  1575   1833   
  1576   1834       resultObj = Tcl_NewListObj(callPtr->numChain, objv);
  1577   1835       TclStackFree(interp, objv);

Changes to generic/tclOODecls.h.

    55     55   				const Tcl_MethodType *typePtr,
    56     56   				ClientData *clientDataPtr);
    57     57   /* 10 */
    58     58   TCLAPI Tcl_Obj *	Tcl_MethodName(Tcl_Method method);
    59     59   /* 11 */
    60     60   TCLAPI Tcl_Method	Tcl_NewInstanceMethod(Tcl_Interp *interp,
    61     61   				Tcl_Object object, Tcl_Obj *nameObj,
    62         -				int isPublic, const Tcl_MethodType *typePtr,
           62  +				int flags, const Tcl_MethodType *typePtr,
    63     63   				ClientData clientData);
    64     64   /* 12 */
    65     65   TCLAPI Tcl_Method	Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
    66         -				Tcl_Obj *nameObj, int isPublic,
           66  +				Tcl_Obj *nameObj, int flags,
    67     67   				const Tcl_MethodType *typePtr,
    68     68   				ClientData clientData);
    69     69   /* 13 */
    70     70   TCLAPI Tcl_Object	Tcl_NewObjectInstance(Tcl_Interp *interp,
    71     71   				Tcl_Class cls, const char *nameStr,
    72     72   				const char *nsNameStr, int objc,
    73     73   				Tcl_Obj *const *objv, int skip);
................................................................................
   112    112   				Tcl_Class clazz, Tcl_Method method);
   113    113   /* 27 */
   114    114   TCLAPI void		Tcl_ClassSetDestructor(Tcl_Interp *interp,
   115    115   				Tcl_Class clazz, Tcl_Method method);
   116    116   /* 28 */
   117    117   TCLAPI Tcl_Obj *	Tcl_GetObjectName(Tcl_Interp *interp,
   118    118   				Tcl_Object object);
          119  +/* 29 */
          120  +TCLAPI int		Tcl_MethodIsPrivate(Tcl_Method method);
   119    121   
   120    122   typedef struct {
   121    123       const struct TclOOIntStubs *tclOOIntStubs;
   122    124   } TclOOStubHooks;
   123    125   
   124    126   typedef struct TclOOStubs {
   125    127       int magic;
................................................................................
   132    134       Tcl_Object (*tcl_GetObjectFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 4 */
   133    135       Tcl_Namespace * (*tcl_GetObjectNamespace) (Tcl_Object object); /* 5 */
   134    136       Tcl_Class (*tcl_MethodDeclarerClass) (Tcl_Method method); /* 6 */
   135    137       Tcl_Object (*tcl_MethodDeclarerObject) (Tcl_Method method); /* 7 */
   136    138       int (*tcl_MethodIsPublic) (Tcl_Method method); /* 8 */
   137    139       int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 9 */
   138    140       Tcl_Obj * (*tcl_MethodName) (Tcl_Method method); /* 10 */
   139         -    Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */
   140         -    Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */
          141  +    Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */
          142  +    Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */
   141    143       Tcl_Object (*tcl_NewObjectInstance) (Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 13 */
   142    144       int (*tcl_ObjectDeleted) (Tcl_Object object); /* 14 */
   143    145       int (*tcl_ObjectContextIsFiltering) (Tcl_ObjectContext context); /* 15 */
   144    146       Tcl_Method (*tcl_ObjectContextMethod) (Tcl_ObjectContext context); /* 16 */
   145    147       Tcl_Object (*tcl_ObjectContextObject) (Tcl_ObjectContext context); /* 17 */
   146    148       int (*tcl_ObjectContextSkippedArgs) (Tcl_ObjectContext context); /* 18 */
   147    149       ClientData (*tcl_ClassGetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 19 */
................................................................................
   150    152       void (*tcl_ObjectSetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 22 */
   151    153       int (*tcl_ObjectContextInvokeNext) (Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 23 */
   152    154       Tcl_ObjectMapMethodNameProc * (*tcl_ObjectGetMethodNameMapper) (Tcl_Object object); /* 24 */
   153    155       void (*tcl_ObjectSetMethodNameMapper) (Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 25 */
   154    156       void (*tcl_ClassSetConstructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 26 */
   155    157       void (*tcl_ClassSetDestructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */
   156    158       Tcl_Obj * (*tcl_GetObjectName) (Tcl_Interp *interp, Tcl_Object object); /* 28 */
          159  +    int (*tcl_MethodIsPrivate) (Tcl_Method method); /* 29 */
   157    160   } TclOOStubs;
   158    161   
   159    162   extern const TclOOStubs *tclOOStubsPtr;
   160    163   
   161    164   #ifdef __cplusplus
   162    165   }
   163    166   #endif
................................................................................
   222    225   	(tclOOStubsPtr->tcl_ObjectSetMethodNameMapper) /* 25 */
   223    226   #define Tcl_ClassSetConstructor \
   224    227   	(tclOOStubsPtr->tcl_ClassSetConstructor) /* 26 */
   225    228   #define Tcl_ClassSetDestructor \
   226    229   	(tclOOStubsPtr->tcl_ClassSetDestructor) /* 27 */
   227    230   #define Tcl_GetObjectName \
   228    231   	(tclOOStubsPtr->tcl_GetObjectName) /* 28 */
          232  +#define Tcl_MethodIsPrivate \
          233  +	(tclOOStubsPtr->tcl_MethodIsPrivate) /* 29 */
   229    234   
   230    235   #endif /* defined(USE_TCLOO_STUBS) */
   231    236   
   232    237   /* !END!: Do not edit above this line. */
   233    238   
   234    239   #endif /* _TCLOODECLS */

Changes to generic/tclOODefineCmds.c.

    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  +/*
           20  + * The actual value used to mark private declaration frames.
           21  + */
           22  +
           23  +#define PRIVATE_FRAME (FRAME_IS_OO_DEFINE | FRAME_IS_PRIVATE_DEFINE)
           24  +
    19     25   /*
    20     26    * The maximum length of fully-qualified object name to use in an errorinfo
    21     27    * message. Longer than this will be curtailed.
    22     28    */
    23     29   
    24     30   #define OBJNAME_LENGTH_IN_ERRORINFO_LIMIT 30
    25     31   
................................................................................
   114    120       SLOT("define::superclass",  ClassSuperGet,  ClassSuperSet),
   115    121       SLOT("define::variable",    ClassVarsGet,   ClassVarsSet),
   116    122       SLOT("objdefine::filter",   ObjFilterGet,   ObjFilterSet),
   117    123       SLOT("objdefine::mixin",    ObjMixinGet,    ObjMixinSet),
   118    124       SLOT("objdefine::variable", ObjVarsGet,     ObjVarsSet),
   119    125       {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
   120    126   };
          127  +
          128  +/*
          129  + * How to build the in-namespace name of a private variable. This is a pattern
          130  + * used with Tcl_ObjPrintf().
          131  + */
          132  +
          133  +#define PRIVATE_VARIABLE_PATTERN "%d : %s"
          134  +
          135  +/*
          136  + * ----------------------------------------------------------------------
          137  + *
          138  + * IsPrivateDefine --
          139  + *
          140  + *	Extracts whether the current context is handling private definitions.
          141  + *
          142  + * ----------------------------------------------------------------------
          143  + */
          144  +
          145  +static inline int
          146  +IsPrivateDefine(
          147  +    Tcl_Interp *interp)
          148  +{
          149  +    Interp *iPtr = (Interp *) interp;
          150  +
          151  +    if (!iPtr->varFramePtr) {
          152  +	return 0;
          153  +    }
          154  +    return iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME;
          155  +}
   121    156   
   122    157   /*
   123    158    * ----------------------------------------------------------------------
   124    159    *
   125    160    * BumpGlobalEpoch --
   126    161    *
   127    162    *	Utility that ensures that call chains that are invalid will get thrown
................................................................................
   415    450       }
   416    451       BumpGlobalEpoch(interp, classPtr);
   417    452   }
   418    453   
   419    454   /*
   420    455    * ----------------------------------------------------------------------
   421    456    *
          457  + * InstallStandardVariableMapping, InstallPrivateVariableMapping --
          458  + *
          459  + *	Helpers for installing standard and private variable maps.
          460  + *
          461  + * ----------------------------------------------------------------------
          462  + */
          463  +static inline void
          464  +InstallStandardVariableMapping(
          465  +    VariableNameList *vnlPtr,
          466  +    int varc,
          467  +    Tcl_Obj *const *varv)
          468  +{
          469  +    Tcl_Obj *variableObj;
          470  +    int i, n, created;
          471  +    Tcl_HashTable uniqueTable;
          472  +
          473  +    for (i=0 ; i<varc ; i++) {
          474  +	Tcl_IncrRefCount(varv[i]);
          475  +    }
          476  +    FOREACH(variableObj, *vnlPtr) {
          477  +	Tcl_DecrRefCount(variableObj);
          478  +    }
          479  +    if (i != varc) {
          480  +	if (varc == 0) {
          481  +	    ckfree(vnlPtr->list);
          482  +	} else if (i) {
          483  +	    vnlPtr->list = ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc);
          484  +	} else {
          485  +	    vnlPtr->list = ckalloc(sizeof(Tcl_Obj *) * varc);
          486  +	}
          487  +    }
          488  +    vnlPtr->num = 0;
          489  +    if (varc > 0) {
          490  +	Tcl_InitObjHashTable(&uniqueTable);
          491  +	for (i=n=0 ; i<varc ; i++) {
          492  +	    Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
          493  +	    if (created) {
          494  +		vnlPtr->list[n++] = varv[i];
          495  +	    } else {
          496  +		Tcl_DecrRefCount(varv[i]);
          497  +	    }
          498  +	}
          499  +	vnlPtr->num = n;
          500  +
          501  +	/*
          502  +	 * Shouldn't be necessary, but maintain num/list invariant.
          503  +	 */
          504  +
          505  +	if (n != varc) {
          506  +	    vnlPtr->list = ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * n);
          507  +	}
          508  +	Tcl_DeleteHashTable(&uniqueTable);
          509  +    }
          510  +}
          511  +
          512  +static inline void
          513  +InstallPrivateVariableMapping(
          514  +    PrivateVariableList *pvlPtr,
          515  +    int varc,
          516  +    Tcl_Obj *const *varv,
          517  +    int creationEpoch)
          518  +{
          519  +    PrivateVariableMapping *privatePtr;
          520  +    int i, n, created;
          521  +    Tcl_HashTable uniqueTable;
          522  +
          523  +    for (i=0 ; i<varc ; i++) {
          524  +	Tcl_IncrRefCount(varv[i]);
          525  +    }
          526  +    FOREACH_STRUCT(privatePtr, *pvlPtr) {
          527  +	Tcl_DecrRefCount(privatePtr->variableObj);
          528  +	Tcl_DecrRefCount(privatePtr->fullNameObj);
          529  +    }
          530  +    if (i != varc) {
          531  +	if (varc == 0) {
          532  +	    ckfree(pvlPtr->list);
          533  +	} else if (i) {
          534  +	    pvlPtr->list = ckrealloc(pvlPtr->list,
          535  +		    sizeof(PrivateVariableMapping) * varc);
          536  +	} else {
          537  +	    pvlPtr->list = ckalloc(sizeof(PrivateVariableMapping) * varc);
          538  +	}
          539  +    }
          540  +
          541  +    pvlPtr->num = 0;
          542  +    if (varc > 0) {
          543  +	Tcl_InitObjHashTable(&uniqueTable);
          544  +	for (i=n=0 ; i<varc ; i++) {
          545  +	    Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
          546  +	    if (created) {
          547  +		privatePtr = &(pvlPtr->list[n++]);
          548  +		privatePtr->variableObj = varv[i];
          549  +		privatePtr->fullNameObj = Tcl_ObjPrintf(
          550  +			PRIVATE_VARIABLE_PATTERN,
          551  +			creationEpoch, Tcl_GetString(varv[i]));
          552  +		Tcl_IncrRefCount(privatePtr->fullNameObj);
          553  +	    } else {
          554  +		Tcl_DecrRefCount(varv[i]);
          555  +	    }
          556  +	}
          557  +	pvlPtr->num = n;
          558  +
          559  +	/*
          560  +	 * Shouldn't be necessary, but maintain num/list invariant.
          561  +	 */
          562  +
          563  +	if (n != varc) {
          564  +	    pvlPtr->list = ckrealloc(pvlPtr->list,
          565  +		    sizeof(PrivateVariableMapping) * n);
          566  +	}
          567  +	Tcl_DeleteHashTable(&uniqueTable);
          568  +    }
          569  +}
          570  +
          571  +/*
          572  + * ----------------------------------------------------------------------
          573  + *
   422    574    * RenameDeleteMethod --
   423    575    *
   424    576    *	Core of the code to rename and delete methods.
   425    577    *
   426    578    * ----------------------------------------------------------------------
   427    579    */
   428    580   
................................................................................
   704    856   TclOOGetDefineCmdContext(
   705    857       Tcl_Interp *interp)
   706    858   {
   707    859       Interp *iPtr = (Interp *) interp;
   708    860       Tcl_Object object;
   709    861   
   710    862       if ((iPtr->varFramePtr == NULL)
   711         -	    || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) {
          863  +	    || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE
          864  +	    && iPtr->varFramePtr->isProcCallFrame != PRIVATE_FRAME)) {
   712    865   	Tcl_SetObjResult(interp, Tcl_NewStringObj(
   713    866   		"this command may only be called from within the context of"
   714    867   		" an ::oo::define or ::oo::objdefine command", -1));
   715    868   	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
   716    869   	return NULL;
   717    870       }
   718    871       object = iPtr->varFramePtr->clientData;
................................................................................
   745    898       Tcl_Obj *className,
   746    899       const char *errMsg)
   747    900   {
   748    901       Interp *iPtr = (Interp *) interp;
   749    902       Object *oPtr;
   750    903       CallFrame *savedFramePtr = iPtr->varFramePtr;
   751    904   
   752         -    while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE) {
          905  +    while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE
          906  +	    || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) {
   753    907   	if (iPtr->varFramePtr->callerVarPtr == NULL) {
   754    908   	    Tcl_Panic("getting outer context when already in global context");
   755    909   	}
   756    910   	iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr;
   757    911       }
   758    912       oPtr = (Object *) Tcl_GetObjectFromObj(interp, className);
   759    913       iPtr->varFramePtr = savedFramePtr;
................................................................................
  1034   1188       ClientData clientData,
  1035   1189       Tcl_Interp *interp,
  1036   1190       int objc,
  1037   1191       Tcl_Obj *const *objv)
  1038   1192   {
  1039   1193       Foundation *fPtr = TclOOGetFoundation(interp);
  1040   1194       Object *oPtr;
  1041         -    int result;
         1195  +    int result, private;
  1042   1196   
  1043   1197       oPtr = (Object *) TclOOGetDefineCmdContext(interp);
  1044   1198       if (oPtr == NULL) {
  1045   1199   	return TCL_ERROR;
  1046   1200       }
  1047   1201   
  1048   1202       if (objc < 2) {
  1049   1203   	Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
  1050   1204   	return TCL_OK;
  1051   1205       }
  1052   1206   
         1207  +    private = IsPrivateDefine(interp);
         1208  +
  1053   1209       /*
  1054   1210        * Make the oo::objdefine namespace the current namespace and evaluate the
  1055   1211        * command(s).
  1056   1212        */
  1057   1213   
  1058   1214       if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){
  1059   1215   	return TCL_ERROR;
  1060   1216       }
         1217  +    if (private) {
         1218  +	((Interp *) interp)->varFramePtr->isProcCallFrame = PRIVATE_FRAME;
         1219  +    }
  1061   1220   
  1062   1221       AddRef(oPtr);
  1063   1222       if (objc == 2) {
  1064   1223   	Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
  1065   1224   
  1066   1225   	Tcl_IncrRefCount(objNameObj);
  1067   1226   	result = TclEvalObjEx(interp, objv[1], 0,
  1068         -		((Interp *)interp)->cmdFramePtr, 2);
         1227  +		((Interp *)interp)->cmdFramePtr, 1);
  1069   1228   	if (result == TCL_ERROR) {
  1070   1229   	    GenerateErrorInfo(interp, oPtr, objNameObj, "class object");
  1071   1230   	}
  1072   1231   	TclDecrRefCount(objNameObj);
  1073   1232       } else {
  1074   1233   	result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 1, objc, objv);
  1075   1234       }
................................................................................
  1112   1271       if (oPtr == NULL) {
  1113   1272   	return TCL_ERROR;
  1114   1273       }
  1115   1274   
  1116   1275       Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
  1117   1276       return TCL_OK;
  1118   1277   }
         1278  +
         1279  +/*
         1280  + * ----------------------------------------------------------------------
         1281  + *
         1282  + * TclOODefinePrivateObjCmd --
         1283  + *
         1284  + *	Implementation of the "private" subcommand of the "oo::define"
         1285  + *	and "oo::objdefine" commands.
         1286  + *
         1287  + * ----------------------------------------------------------------------
         1288  + */
         1289  +
         1290  +int
         1291  +TclOODefinePrivateObjCmd(
         1292  +    ClientData clientData,
         1293  +    Tcl_Interp *interp,
         1294  +    int objc,
         1295  +    Tcl_Obj *const *objv)
         1296  +{
         1297  +    int isInstancePrivate = (clientData != NULL);
         1298  +				/* Just so that we can generate the correct
         1299  +				 * error message depending on the context of
         1300  +				 * usage of this function. */
         1301  +    Interp *iPtr = (Interp *) interp;
         1302  +    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
         1303  +    int saved;			/* The saved flag. We restore it on exit so
         1304  +				 * that [private private ...] doesn't make
         1305  +				 * things go weird. */
         1306  +    int result;
         1307  +
         1308  +    if (oPtr == NULL) {
         1309  +	return TCL_ERROR;
         1310  +    }
         1311  +    if (objc == 1) {
         1312  +	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(IsPrivateDefine(interp)));
         1313  +	return TCL_OK;
         1314  +    }
         1315  +
         1316  +    /*
         1317  +     * Change the frame type flag while evaluating the body.
         1318  +     */
         1319  +
         1320  +    saved = iPtr->varFramePtr->isProcCallFrame;
         1321  +    iPtr->varFramePtr->isProcCallFrame = PRIVATE_FRAME;
         1322  +
         1323  +    /*
         1324  +     * Evaluate the body; standard pattern.
         1325  +     */
         1326  +
         1327  +    AddRef(oPtr);
         1328  +    if (objc == 2) {
         1329  +	Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
         1330  +
         1331  +	Tcl_IncrRefCount(objNameObj);
         1332  +	result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1);
         1333  +	if (result == TCL_ERROR) {
         1334  +	    GenerateErrorInfo(interp, oPtr, objNameObj,
         1335  +		    isInstancePrivate ? "object" : "class");
         1336  +	}
         1337  +	TclDecrRefCount(objNameObj);
         1338  +    } else {
         1339  +	result = MagicDefinitionInvoke(interp, TclGetCurrentNamespace(interp),
         1340  +		1, objc, objv);
         1341  +    }
         1342  +    TclOODecrRefCount(oPtr);
         1343  +
         1344  +    /*
         1345  +     * Restore the frame type flag to what it was previously.
         1346  +     */
         1347  +
         1348  +    iPtr->varFramePtr->isProcCallFrame = saved;
         1349  +    return result;
         1350  +}
  1119   1351   
  1120   1352   /*
  1121   1353    * ----------------------------------------------------------------------
  1122   1354    *
  1123   1355    * TclOODefineClassObjCmd --
  1124   1356    *
  1125   1357    *	Implementation of the "class" subcommand of the "oo::objdefine"
................................................................................
  1456   1688   	    mPtr->refCount = 1;
  1457   1689   	    mPtr->namePtr = objv[i];
  1458   1690   	    Tcl_IncrRefCount(objv[i]);
  1459   1691   	    Tcl_SetHashValue(hPtr, mPtr);
  1460   1692   	} else {
  1461   1693   	    mPtr = Tcl_GetHashValue(hPtr);
  1462   1694   	}
  1463         -	if (isNew || !(mPtr->flags & PUBLIC_METHOD)) {
         1695  +	if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) {
  1464   1696   	    mPtr->flags |= PUBLIC_METHOD;
         1697  +	    mPtr->flags &= ~TRUE_PRIVATE_METHOD;
  1465   1698   	    changed = 1;
  1466   1699   	}
  1467   1700       }
  1468   1701   
  1469   1702       /*
  1470   1703        * Bump the right epoch if we actually changed anything.
  1471   1704        */
................................................................................
  1517   1750   	Tcl_SetObjResult(interp, Tcl_NewStringObj(
  1518   1751   		"attempt to misuse API", -1));
  1519   1752   	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
  1520   1753   	return TCL_ERROR;
  1521   1754       }
  1522   1755       isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
  1523   1756   	    ? PUBLIC_METHOD : 0;
         1757  +    if (IsPrivateDefine(interp)) {
         1758  +	isPublic = TRUE_PRIVATE_METHOD;
         1759  +    }
  1524   1760   
  1525   1761       /*
  1526   1762        * Create the method structure.
  1527   1763        */
  1528   1764   
  1529   1765       prefixObj = Tcl_NewListObj(objc-2, objv+2);
  1530   1766       if (isInstanceForward) {
................................................................................
  1576   1812   	Tcl_SetObjResult(interp, Tcl_NewStringObj(
  1577   1813   		"attempt to misuse API", -1));
  1578   1814   	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
  1579   1815   	return TCL_ERROR;
  1580   1816       }
  1581   1817       isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
  1582   1818   	    ? PUBLIC_METHOD : 0;
         1819  +    if (IsPrivateDefine(interp)) {
         1820  +	isPublic = TRUE_PRIVATE_METHOD;
         1821  +    }
  1583   1822   
  1584   1823       /*
  1585   1824        * Create the method by using the right back-end API.
  1586   1825        */
  1587   1826   
  1588   1827       if (isInstanceMethod) {
  1589   1828   	if (TclOONewProcInstanceMethod(interp, oPtr, isPublic, objv[1],
................................................................................
  1791   2030   	    mPtr->refCount = 1;
  1792   2031   	    mPtr->namePtr = objv[i];
  1793   2032   	    Tcl_IncrRefCount(objv[i]);
  1794   2033   	    Tcl_SetHashValue(hPtr, mPtr);
  1795   2034   	} else {
  1796   2035   	    mPtr = Tcl_GetHashValue(hPtr);
  1797   2036   	}
  1798         -	if (isNew || mPtr->flags & PUBLIC_METHOD) {
  1799         -	    mPtr->flags &= ~PUBLIC_METHOD;
         2037  +	if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
         2038  +	    mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
  1800   2039   	    changed = 1;
  1801   2040   	}
  1802   2041       }
  1803   2042   
  1804   2043       /*
  1805   2044        * Bump the right epoch if we actually changed anything.
  1806   2045        */
................................................................................
  2284   2523       ClientData clientData,
  2285   2524       Tcl_Interp *interp,
  2286   2525       Tcl_ObjectContext context,
  2287   2526       int objc,
  2288   2527       Tcl_Obj *const *objv)
  2289   2528   {
  2290   2529       Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
  2291         -    Tcl_Obj *resultObj, *variableObj;
         2530  +    Tcl_Obj *resultObj;
  2292   2531       int i;
  2293   2532   
  2294   2533       if (Tcl_ObjectContextSkippedArgs(context) != objc) {
  2295   2534   	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
  2296   2535   		NULL);
  2297   2536   	return TCL_ERROR;
  2298   2537       }
................................................................................
  2302   2541   	Tcl_SetObjResult(interp, Tcl_NewStringObj(
  2303   2542   		"attempt to misuse API", -1));
  2304   2543   	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
  2305   2544   	return TCL_ERROR;
  2306   2545       }
  2307   2546   
  2308   2547       resultObj = Tcl_NewObj();
  2309         -    FOREACH(variableObj, oPtr->classPtr->variables) {
  2310         -	Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
         2548  +    if (IsPrivateDefine(interp)) {
         2549  +	PrivateVariableMapping *privatePtr;
         2550  +
         2551  +	FOREACH_STRUCT(privatePtr, oPtr->classPtr->privateVariables) {
         2552  +	    Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
         2553  +	}
         2554  +    } else {
         2555  +	Tcl_Obj *variableObj;
         2556  +
         2557  +	FOREACH(variableObj, oPtr->classPtr->variables) {
         2558  +	    Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
         2559  +	}
  2311   2560       }
  2312   2561       Tcl_SetObjResult(interp, resultObj);
  2313   2562       return TCL_OK;
  2314   2563   }
  2315   2564   
  2316   2565   static int
  2317   2566   ClassVarsSet(
................................................................................
  2319   2568       Tcl_Interp *interp,
  2320   2569       Tcl_ObjectContext context,
  2321   2570       int objc,
  2322   2571       Tcl_Obj *const *objv)
  2323   2572   {
  2324   2573       Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
  2325   2574       int varc;
  2326         -    Tcl_Obj **varv, *variableObj;
         2575  +    Tcl_Obj **varv;
  2327   2576       int i;
  2328   2577   
  2329   2578       if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
  2330   2579   	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
  2331   2580   		"filterList");
  2332   2581   	return TCL_ERROR;
  2333   2582       }
................................................................................
  2360   2609   		    "invalid declared variable name \"%s\": must not %s",
  2361   2610   		    varName, "refer to an array element"));
  2362   2611   	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
  2363   2612   	    return TCL_ERROR;
  2364   2613   	}
  2365   2614       }
  2366   2615   
  2367         -    for (i=0 ; i<varc ; i++) {
  2368         -	Tcl_IncrRefCount(varv[i]);
  2369         -    }
  2370         -    FOREACH(variableObj, oPtr->classPtr->variables) {
  2371         -	Tcl_DecrRefCount(variableObj);
  2372         -    }
  2373         -    if (i != varc) {
  2374         -	if (varc == 0) {
  2375         -	    ckfree(oPtr->classPtr->variables.list);
  2376         -	} else if (i) {
  2377         -	    oPtr->classPtr->variables.list = (Tcl_Obj **)
  2378         -		    ckrealloc((char *) oPtr->classPtr->variables.list,
  2379         -		    sizeof(Tcl_Obj *) * varc);
  2380         -	} else {
  2381         -	    oPtr->classPtr->variables.list = (Tcl_Obj **)
  2382         -		    ckalloc(sizeof(Tcl_Obj *) * varc);
  2383         -	}
  2384         -    }
  2385         -
  2386         -    oPtr->classPtr->variables.num = 0;
  2387         -    if (varc > 0) {
  2388         -	int created, n;
  2389         -	Tcl_HashTable uniqueTable;
  2390         -
  2391         -	Tcl_InitObjHashTable(&uniqueTable);
  2392         -	for (i=n=0 ; i<varc ; i++) {
  2393         -	    Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
  2394         -	    if (created) {
  2395         -		oPtr->classPtr->variables.list[n++] = varv[i];
  2396         -	    } else {
  2397         -		Tcl_DecrRefCount(varv[i]);
  2398         -	    }
  2399         -	}
  2400         -	oPtr->classPtr->variables.num = n;
  2401         -
  2402         -	/*
  2403         -	 * Shouldn't be necessary, but maintain num/list invariant.
  2404         -	 */
  2405         -
  2406         -	oPtr->classPtr->variables.list = (Tcl_Obj **)
  2407         -		ckrealloc((char *) oPtr->classPtr->variables.list,
  2408         -		sizeof(Tcl_Obj *) * n);
  2409         -	Tcl_DeleteHashTable(&uniqueTable);
         2616  +    if (IsPrivateDefine(interp)) {
         2617  +	InstallPrivateVariableMapping(&oPtr->classPtr->privateVariables,
         2618  +		varc, varv, oPtr->classPtr->thisPtr->creationEpoch);
         2619  +    } else {
         2620  +	InstallStandardVariableMapping(&oPtr->classPtr->variables, varc, varv);
  2410   2621       }
  2411   2622       return TCL_OK;
  2412   2623   }
  2413   2624   
  2414   2625   /*
  2415   2626    * ----------------------------------------------------------------------
  2416   2627    *
................................................................................
  2581   2792       ClientData clientData,
  2582   2793       Tcl_Interp *interp,
  2583   2794       Tcl_ObjectContext context,
  2584   2795       int objc,
  2585   2796       Tcl_Obj *const *objv)
  2586   2797   {
  2587   2798       Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
  2588         -    Tcl_Obj *resultObj, *variableObj;
         2799  +    Tcl_Obj *resultObj;
  2589   2800       int i;
  2590   2801   
  2591   2802       if (Tcl_ObjectContextSkippedArgs(context) != objc) {
  2592   2803   	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
  2593   2804   		NULL);
  2594   2805   	return TCL_ERROR;
  2595   2806       } else if (oPtr == NULL) {
  2596   2807   	return TCL_ERROR;
  2597   2808       }
  2598   2809   
  2599   2810       resultObj = Tcl_NewObj();
  2600         -    FOREACH(variableObj, oPtr->variables) {
  2601         -	Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
         2811  +    if (IsPrivateDefine(interp)) {
         2812  +	PrivateVariableMapping *privatePtr;
         2813  +
         2814  +	FOREACH_STRUCT(privatePtr, oPtr->privateVariables) {
         2815  +	    Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
         2816  +	}
         2817  +    } else {
         2818  +	Tcl_Obj *variableObj;
         2819  +
         2820  +	FOREACH(variableObj, oPtr->variables) {
         2821  +	    Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
         2822  +	}
  2602   2823       }
  2603   2824       Tcl_SetObjResult(interp, resultObj);
  2604   2825       return TCL_OK;
  2605   2826   }
  2606   2827   
  2607   2828   static int
  2608   2829   ObjVarsSet(
................................................................................
  2610   2831       Tcl_Interp *interp,
  2611   2832       Tcl_ObjectContext context,
  2612   2833       int objc,
  2613   2834       Tcl_Obj *const *objv)
  2614   2835   {
  2615   2836       Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
  2616   2837       int varc, i;
  2617         -    Tcl_Obj **varv, *variableObj;
         2838  +    Tcl_Obj **varv;
  2618   2839   
  2619   2840       if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
  2620   2841   	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
  2621   2842   		"variableList");
  2622   2843   	return TCL_ERROR;
  2623   2844       } else if (oPtr == NULL) {
  2624   2845   	return TCL_ERROR;
................................................................................
  2643   2864   	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
  2644   2865   		    "invalid declared variable name \"%s\": must not %s",
  2645   2866   		    varName, "refer to an array element"));
  2646   2867   	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
  2647   2868   	    return TCL_ERROR;
  2648   2869   	}
  2649   2870       }
  2650         -    for (i=0 ; i<varc ; i++) {
  2651         -	Tcl_IncrRefCount(varv[i]);
  2652         -    }
  2653   2871   
  2654         -    FOREACH(variableObj, oPtr->variables) {
  2655         -	Tcl_DecrRefCount(variableObj);
  2656         -    }
  2657         -    if (i != varc) {
  2658         -	if (varc == 0) {
  2659         -	    ckfree(oPtr->variables.list);
  2660         -	} else if (i) {
  2661         -	    oPtr->variables.list = (Tcl_Obj **)
  2662         -		    ckrealloc((char *) oPtr->variables.list,
  2663         -		    sizeof(Tcl_Obj *) * varc);
  2664         -	} else {
  2665         -	    oPtr->variables.list = (Tcl_Obj **)
  2666         -		    ckalloc(sizeof(Tcl_Obj *) * varc);
  2667         -	}
  2668         -    }
  2669         -    oPtr->variables.num = 0;
  2670         -    if (varc > 0) {
  2671         -	int created, n;
  2672         -	Tcl_HashTable uniqueTable;
  2673         -
  2674         -	Tcl_InitObjHashTable(&uniqueTable);
  2675         -	for (i=n=0 ; i<varc ; i++) {
  2676         -	    Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
  2677         -	    if (created) {
  2678         -		oPtr->variables.list[n++] = varv[i];
  2679         -	    } else {
  2680         -		Tcl_DecrRefCount(varv[i]);
  2681         -	    }
  2682         -	}
  2683         -	oPtr->variables.num = n;
  2684         -
  2685         -	/*
  2686         -	 * Shouldn't be necessary, but maintain num/list invariant.
  2687         -	 */
  2688         -
  2689         -	oPtr->variables.list = (Tcl_Obj **)
  2690         -		ckrealloc((char *) oPtr->variables.list,
  2691         -		sizeof(Tcl_Obj *) * n);
  2692         -	Tcl_DeleteHashTable(&uniqueTable);
         2872  +    if (IsPrivateDefine(interp)) {
         2873  +	InstallPrivateVariableMapping(&oPtr->privateVariables, varc, varv,
         2874  +		oPtr->creationEpoch);
         2875  +    } else {
         2876  +	InstallStandardVariableMapping(&oPtr->variables, varc, varv);
  2693   2877       }
  2694   2878       return TCL_OK;
  2695   2879   }
  2696   2880   
  2697   2881   /*
  2698   2882    * Local Variables:
  2699   2883    * mode: c
  2700   2884    * c-basic-offset: 4
  2701   2885    * fill-column: 78
  2702   2886    * End:
  2703   2887    */

Changes to generic/tclOOInfo.c.

    18     18   
    19     19   static inline Class *	GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
    20     20   static Tcl_ObjCmdProc InfoObjectCallCmd;
    21     21   static Tcl_ObjCmdProc InfoObjectClassCmd;
    22     22   static Tcl_ObjCmdProc InfoObjectDefnCmd;
    23     23   static Tcl_ObjCmdProc InfoObjectFiltersCmd;
    24     24   static Tcl_ObjCmdProc InfoObjectForwardCmd;
           25  +static Tcl_ObjCmdProc InfoObjectIdCmd;
    25     26   static Tcl_ObjCmdProc InfoObjectIsACmd;
    26     27   static Tcl_ObjCmdProc InfoObjectMethodsCmd;
    27     28   static Tcl_ObjCmdProc InfoObjectMethodTypeCmd;
    28     29   static Tcl_ObjCmdProc InfoObjectMixinsCmd;
    29     30   static Tcl_ObjCmdProc InfoObjectNsCmd;
    30     31   static Tcl_ObjCmdProc InfoObjectVarsCmd;
    31     32   static Tcl_ObjCmdProc InfoObjectVariablesCmd;
................................................................................
    46     47   /*
    47     48    * List of commands that are used to implement the [info object] subcommands.
    48     49    */
    49     50   
    50     51   static const EnsembleImplMap infoObjectCmds[] = {
    51     52       {"call",	   InfoObjectCallCmd,	    TclCompileBasic2ArgCmd, NULL, NULL, 0},
    52     53       {"class",	   InfoObjectClassCmd,	    TclCompileInfoObjectClassCmd, NULL, NULL, 0},
           54  +    {"creationid", InfoObjectIdCmd,	    TclCompileBasic1ArgCmd, NULL, NULL, 0},
    53     55       {"definition", InfoObjectDefnCmd,	    TclCompileBasic2ArgCmd, NULL, NULL, 0},
    54     56       {"filters",	   InfoObjectFiltersCmd,    TclCompileBasic1ArgCmd, NULL, NULL, 0},
    55     57       {"forward",	   InfoObjectForwardCmd,    TclCompileBasic2ArgCmd, NULL, NULL, 0},
    56     58       {"isa",	   InfoObjectIsACmd,	    TclCompileInfoObjectIsACmd, NULL, NULL, 0},
    57     59       {"methods",	   InfoObjectMethodsCmd,    TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
    58     60       {"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
    59     61       {"mixins",	   InfoObjectMixinsCmd,	    TclCompileBasic1ArgCmd, NULL, NULL, 0},
    60     62       {"namespace",  InfoObjectNsCmd,	    TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0},
    61         -    {"variables",  InfoObjectVariablesCmd,  TclCompileBasic1ArgCmd, NULL, NULL, 0},
           63  +    {"variables",  InfoObjectVariablesCmd,  TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    62     64       {"vars",	   InfoObjectVarsCmd,	    TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    63     65       {NULL, NULL, NULL, NULL, NULL, 0}
    64     66   };
    65     67   
    66     68   /*
    67     69    * List of commands that are used to implement the [info class] subcommands.
    68     70    */
................................................................................
    76     78       {"forward",	     InfoClassForwardCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
    77     79       {"instances",    InfoClassInstancesCmd,	TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    78     80       {"methods",	     InfoClassMethodsCmd,	TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
    79     81       {"methodtype",   InfoClassMethodTypeCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
    80     82       {"mixins",	     InfoClassMixinsCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
    81     83       {"subclasses",   InfoClassSubsCmd,		TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    82     84       {"superclasses", InfoClassSupersCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
    83         -    {"variables",    InfoClassVariablesCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
           85  +    {"variables",    InfoClassVariablesCmd,	TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    84     86       {NULL, NULL, NULL, NULL, NULL, 0}
    85     87   };
    86     88   
    87     89   /*
    88     90    * ----------------------------------------------------------------------
    89     91    *
    90     92    * TclOOInitInfo --
................................................................................
   513    515   InfoObjectMethodsCmd(
   514    516       ClientData clientData,
   515    517       Tcl_Interp *interp,
   516    518       int objc,
   517    519       Tcl_Obj *const objv[])
   518    520   {
   519    521       Object *oPtr;
   520         -    int flag = PUBLIC_METHOD, recurse = 0;
          522  +    int flag = PUBLIC_METHOD, recurse = 0, scope = -1;
   521    523       FOREACH_HASH_DECLS;
   522    524       Tcl_Obj *namePtr, *resultObj;
   523    525       Method *mPtr;
   524    526       static const char *const options[] = {
   525         -	"-all", "-localprivate", "-private", NULL
          527  +	"-all", "-localprivate", "-private", "-scope", NULL
   526    528       };
   527    529       enum Options {
   528         -	OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE
          530  +	OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE
          531  +    };
          532  +    static const char *const scopes[] = {
          533  +	"private", "public", "unexported"
          534  +    };
          535  +    enum Scopes {
          536  +	SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED,
          537  +	SCOPE_LOCALPRIVATE
   529    538       };
   530    539   
   531    540       if (objc < 2) {
   532    541   	Tcl_WrongNumArgs(interp, 1, objv, "objName ?-option value ...?");
   533    542   	return TCL_ERROR;
   534    543       }
   535    544       oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
................................................................................
   549    558   		recurse = 1;
   550    559   		break;
   551    560   	    case OPT_LOCALPRIVATE:
   552    561   		flag = PRIVATE_METHOD;
   553    562   		break;
   554    563   	    case OPT_PRIVATE:
   555    564   		flag = 0;
          565  +		break;
          566  +	    case OPT_SCOPE:
          567  +		if (++i >= objc) {
          568  +		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
          569  +			    "missing option for -scope"));
          570  +		    Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING",
          571  +			    NULL);
          572  +		    return TCL_ERROR;
          573  +		}
          574  +		if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0,
          575  +			&scope) != TCL_OK) {
          576  +		    return TCL_ERROR;
          577  +		}
   556    578   		break;
   557    579   	    }
   558    580   	}
          581  +    }
          582  +    if (scope != -1) {
          583  +	recurse = 0;
          584  +	switch (scope) {
          585  +	case SCOPE_PRIVATE:
          586  +	    flag = TRUE_PRIVATE_METHOD;
          587  +	    break;
          588  +	case SCOPE_PUBLIC:
          589  +	    flag = PUBLIC_METHOD;
          590  +	    break;
          591  +	case SCOPE_LOCALPRIVATE:
          592  +	    flag = PRIVATE_METHOD;
          593  +	    break;
          594  +	case SCOPE_UNEXPORTED:
          595  +	    flag = 0;
          596  +	    break;
          597  +	}
   559    598       }
   560    599   
   561    600       resultObj = Tcl_NewObj();
   562    601       if (recurse) {
   563    602   	const char **names;
   564         -	int i, numNames = TclOOGetSortedMethodList(oPtr, flag, &names);
          603  +	int i, numNames = TclOOGetSortedMethodList(oPtr, NULL, NULL, flag,
          604  +		&names);
   565    605   
   566    606   	for (i=0 ; i<numNames ; i++) {
   567    607   	    Tcl_ListObjAppendElement(NULL, resultObj,
   568    608   		    Tcl_NewStringObj(names[i], -1));
   569    609   	}
   570    610   	if (numNames > 0) {
   571    611   	    ckfree(names);
   572    612   	}
   573    613       } else if (oPtr->methodsPtr) {
   574    614   	FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
   575         -	    if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
          615  +	    if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) {
   576    616   		Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
   577    617   	    }
   578    618   	}
   579    619       }
   580    620       Tcl_SetObjResult(interp, resultObj);
   581    621       return TCL_OK;
   582    622   }
................................................................................
   680    720       Tcl_SetObjResult(interp, resultObj);
   681    721       return TCL_OK;
   682    722   }
   683    723   
   684    724   /*
   685    725    * ----------------------------------------------------------------------
   686    726    *
          727  + * InfoObjectIdCmd --
          728  + *
          729  + *	Implements [info object creationid $objName]
          730  + *
          731  + * ----------------------------------------------------------------------
          732  + */
          733  +
          734  +static int
          735  +InfoObjectIdCmd(
          736  +    ClientData clientData,
          737  +    Tcl_Interp *interp,
          738  +    int objc,
          739  +    Tcl_Obj *const objv[])
          740  +{
          741  +    Object *oPtr;
          742  +
          743  +    if (objc != 2) {
          744  +	Tcl_WrongNumArgs(interp, 1, objv, "objName");
          745  +	return TCL_ERROR;
          746  +    }
          747  +    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
          748  +    if (oPtr == NULL) {
          749  +	return TCL_ERROR;
          750  +    }
          751  +
          752  +    Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->creationEpoch));
          753  +    return TCL_OK;
          754  +}
          755  +
          756  +/*
          757  + * ----------------------------------------------------------------------
          758  + *
   687    759    * InfoObjectNsCmd --
   688    760    *
   689    761    *	Implements [info object namespace $objName]
   690    762    *
   691    763    * ----------------------------------------------------------------------
   692    764    */
   693    765   
................................................................................
   715    787   }
   716    788   
   717    789   /*
   718    790    * ----------------------------------------------------------------------
   719    791    *
   720    792    * InfoObjectVariablesCmd --
   721    793    *
   722         - *	Implements [info object variables $objName]
          794  + *	Implements [info object variables $objName ?-private?]
   723    795    *
   724    796    * ----------------------------------------------------------------------
   725    797    */
   726    798   
   727    799   static int
   728    800   InfoObjectVariablesCmd(
   729    801       ClientData clientData,
   730    802       Tcl_Interp *interp,
   731    803       int objc,
   732    804       Tcl_Obj *const objv[])
   733    805   {
   734    806       Object *oPtr;
   735         -    Tcl_Obj *variableObj, *resultObj;
   736         -    int i;
          807  +    Tcl_Obj *resultObj;
          808  +    int i, private = 0;
   737    809   
   738         -    if (objc != 2) {
   739         -	Tcl_WrongNumArgs(interp, 1, objv, "objName");
          810  +    if (objc != 2 && objc != 3) {
          811  +	Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?");
   740    812   	return TCL_ERROR;
          813  +    }
          814  +    if (objc == 3) {
          815  +	if (strcmp("-private", Tcl_GetString(objv[2])) != 0) {
          816  +	    return TCL_ERROR;
          817  +	}
          818  +	private = 1;
   741    819       }
   742    820       oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
   743    821       if (oPtr == NULL) {
   744    822   	return TCL_ERROR;
   745    823       }
   746    824   
   747    825       resultObj = Tcl_NewObj();
   748         -    FOREACH(variableObj, oPtr->variables) {
   749         -	Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
          826  +    if (private) {
          827  +	PrivateVariableMapping *privatePtr;
          828  +
          829  +	FOREACH_STRUCT(privatePtr, oPtr->privateVariables) {
          830  +	    Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
          831  +	}
          832  +    } else {
          833  +	Tcl_Obj *variableObj;
          834  +
          835  +	FOREACH(variableObj, oPtr->variables) {
          836  +	    Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
          837  +	}
   750    838       }
   751    839       Tcl_SetObjResult(interp, resultObj);
   752    840       return TCL_OK;
   753    841   }
   754    842   
   755    843   /*
   756    844    * ----------------------------------------------------------------------
................................................................................
  1124   1212   }
  1125   1213   
  1126   1214   /*
  1127   1215    * ----------------------------------------------------------------------
  1128   1216    *
  1129   1217    * InfoClassMethodsCmd --
  1130   1218    *
  1131         - *	Implements [info class methods $clsName ?-private?]
         1219  + *	Implements [info class methods $clsName ?options...?]
  1132   1220    *
  1133   1221    * ----------------------------------------------------------------------
  1134   1222    */
  1135   1223   
  1136   1224   static int
  1137   1225   InfoClassMethodsCmd(
  1138   1226       ClientData clientData,
  1139   1227       Tcl_Interp *interp,
  1140   1228       int objc,
  1141   1229       Tcl_Obj *const objv[])
  1142   1230   {
  1143         -    int flag = PUBLIC_METHOD, recurse = 0;
         1231  +    int flag = PUBLIC_METHOD, recurse = 0, scope = -1;
  1144   1232       Tcl_Obj *namePtr, *resultObj;
  1145   1233       Method *mPtr;
  1146   1234       Class *clsPtr;
  1147   1235       static const char *const options[] = {
  1148         -	"-all", "-localprivate", "-private", NULL
         1236  +	"-all", "-localprivate", "-private", "-scope", NULL
  1149   1237       };
  1150   1238       enum Options {
  1151         -	OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE
         1239  +	OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE
         1240  +    };
         1241  +    static const char *const scopes[] = {
         1242  +	"private", "public", "unexported"
         1243  +    };
         1244  +    enum Scopes {
         1245  +	SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED
  1152   1246       };
  1153   1247   
  1154   1248       if (objc < 2) {
  1155   1249   	Tcl_WrongNumArgs(interp, 1, objv, "className ?-option value ...?");
  1156   1250   	return TCL_ERROR;
  1157   1251       }
  1158   1252       clsPtr = GetClassFromObj(interp, objv[1]);
................................................................................
  1172   1266   		recurse = 1;
  1173   1267   		break;
  1174   1268   	    case OPT_LOCALPRIVATE:
  1175   1269   		flag = PRIVATE_METHOD;
  1176   1270   		break;
  1177   1271   	    case OPT_PRIVATE:
  1178   1272   		flag = 0;
         1273  +		break;
         1274  +	    case OPT_SCOPE:
         1275  +		if (++i >= objc) {
         1276  +		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
         1277  +			    "missing option for -scope"));
         1278  +		    Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING",
         1279  +			    NULL);
         1280  +		    return TCL_ERROR;
         1281  +		}
         1282  +		if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0,
         1283  +			&scope) != TCL_OK) {
         1284  +		    return TCL_ERROR;
         1285  +		}
  1179   1286   		break;
  1180   1287   	    }
  1181   1288   	}
         1289  +    }
         1290  +    if (scope != -1) {
         1291  +	recurse = 0;
         1292  +	switch (scope) {
         1293  +	case SCOPE_PRIVATE:
         1294  +	    flag = TRUE_PRIVATE_METHOD;
         1295  +	    break;
         1296  +	case SCOPE_PUBLIC:
         1297  +	    flag = PUBLIC_METHOD;
         1298  +	    break;
         1299  +	case SCOPE_UNEXPORTED:
         1300  +	    flag = 0;
         1301  +	    break;
         1302  +	}
  1182   1303       }
  1183   1304   
  1184   1305       resultObj = Tcl_NewObj();
  1185   1306       if (recurse) {
  1186   1307   	const char **names;
  1187   1308   	int i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names);
  1188   1309   
................................................................................
  1193   1314   	if (numNames > 0) {
  1194   1315   	    ckfree(names);
  1195   1316   	}
  1196   1317       } else {
  1197   1318   	FOREACH_HASH_DECLS;
  1198   1319   
  1199   1320   	FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
  1200         -	    if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) {
         1321  +	    if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) {
  1201   1322   		Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
  1202   1323   	    }
  1203   1324   	}
  1204   1325       }
  1205   1326       Tcl_SetObjResult(interp, resultObj);
  1206   1327       return TCL_OK;
  1207   1328   }
................................................................................
  1395   1516   }
  1396   1517   
  1397   1518   /*
  1398   1519    * ----------------------------------------------------------------------
  1399   1520    *
  1400   1521    * InfoClassVariablesCmd --
  1401   1522    *
  1402         - *	Implements [info class variables $clsName]
         1523  + *	Implements [info class variables $clsName ?-private?]
  1403   1524    *
  1404   1525    * ----------------------------------------------------------------------
  1405   1526    */
  1406   1527   
  1407   1528   static int
  1408   1529   InfoClassVariablesCmd(
  1409   1530       ClientData clientData,
  1410   1531       Tcl_Interp *interp,
  1411   1532       int objc,
  1412   1533       Tcl_Obj *const objv[])
  1413   1534   {
  1414   1535       Class *clsPtr;
  1415         -    Tcl_Obj *variableObj, *resultObj;
  1416         -    int i;
         1536  +    Tcl_Obj *resultObj;
         1537  +    int i, private = 0;
  1417   1538   
  1418         -    if (objc != 2) {
  1419         -	Tcl_WrongNumArgs(interp, 1, objv, "className");
         1539  +    if (objc != 2 && objc != 3) {
         1540  +	Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?");
  1420   1541   	return TCL_ERROR;
         1542  +    }
         1543  +    if (objc == 3) {
         1544  +	if (strcmp("-private", Tcl_GetString(objv[2])) != 0) {
         1545  +	    return TCL_ERROR;
         1546  +	}
         1547  +	private = 1;
  1421   1548       }
  1422   1549       clsPtr = GetClassFromObj(interp, objv[1]);
  1423   1550       if (clsPtr == NULL) {
  1424   1551   	return TCL_ERROR;
  1425   1552       }
  1426   1553   
  1427   1554       resultObj = Tcl_NewObj();
  1428         -    FOREACH(variableObj, clsPtr->variables) {
  1429         -	Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
         1555  +    if (private) {
         1556  +	PrivateVariableMapping *privatePtr;
         1557  +
         1558  +	FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) {
         1559  +	    Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
         1560  +	}
         1561  +    } else {
         1562  +	Tcl_Obj *variableObj;
         1563  +
         1564  +	FOREACH(variableObj, clsPtr->variables) {
         1565  +	    Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
         1566  +	}
  1430   1567       }
  1431   1568       Tcl_SetObjResult(interp, resultObj);
  1432   1569       return TCL_OK;
  1433   1570   }
  1434   1571   
  1435   1572   /*
  1436   1573    * ----------------------------------------------------------------------
................................................................................
  1461   1598   	return TCL_ERROR;
  1462   1599       }
  1463   1600   
  1464   1601       /*
  1465   1602        * Get the call context and render its call chain.
  1466   1603        */
  1467   1604   
  1468         -    contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL);
         1605  +    contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL,
         1606  +	    NULL);
  1469   1607       if (contextPtr == NULL) {
  1470   1608   	Tcl_SetObjResult(interp, Tcl_NewStringObj(
  1471   1609   		"cannot construct any call chain", -1));
  1472   1610   	return TCL_ERROR;
  1473   1611       }
  1474   1612       Tcl_SetObjResult(interp,
  1475   1613   	    TclOORenderCallChain(interp, contextPtr->callPtr));

Changes to generic/tclOOInt.h.

   120    120   
   121    121   typedef struct ForwardMethod {
   122    122       Tcl_Obj *prefixObj;		/* The list of values to use to replace the
   123    123   				 * object and method name with. Will be a
   124    124   				 * non-empty list. */
   125    125   } ForwardMethod;
   126    126   
          127  +/*
          128  + * Structure used in private variable mappings. Describes the mapping of a
          129  + * single variable from the user's local name to the system's storage name.
          130  + * [TIP #500]
          131  + */
          132  +
          133  +typedef struct {
          134  +    Tcl_Obj *variableObj;	/* Name used within methods. This is the part
          135  +				 * that is properly under user control. */
          136  +    Tcl_Obj *fullNameObj;	/* Name used at the instance namespace level. */
          137  +} PrivateVariableMapping;
          138  +
   127    139   /*
   128    140    * Helper definitions that declare a "list" array. The two varieties are
   129    141    * either optimized for simplicity (in the case that the whole array is
   130    142    * typically assigned at once) or efficiency (in the case that the array is
   131    143    * expected to be expanded over time). These lists are designed to be iterated
   132    144    * over with the help of the FOREACH macro (see later in this file).
   133    145    *
................................................................................
   137    149    */
   138    150   
   139    151   #define LIST_STATIC(listType_t) \
   140    152       struct { int num; listType_t *list; }
   141    153   #define LIST_DYNAMIC(listType_t) \
   142    154       struct { int num, size; listType_t *list; }
   143    155   
          156  +/*
          157  + * These types are needed in function arguments.
          158  + */
          159  +
          160  +typedef LIST_STATIC(Tcl_Obj *) VariableNameList;
          161  +typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList;
          162  +
   144    163   /*
   145    164    * Now, the definition of what an object actually is.
   146    165    */
   147    166   
   148    167   typedef struct Object {
   149    168       struct Foundation *fPtr;	/* The basis for the object system. Putting
   150    169   				 * this here allows the avoidance of quite a
................................................................................
   182    201   				 * allocated if metadata is attached. */
   183    202       Tcl_Obj *cachedNameObj;	/* Cache of the name of the object. */
   184    203       Tcl_HashTable *chainCache;	/* Place to keep unused contexts. This table
   185    204   				 * is indexed by method name as Tcl_Obj. */
   186    205       Tcl_ObjectMapMethodNameProc *mapMethodNameProc;
   187    206   				/* Function to allow remapping of method
   188    207   				 * names. For itcl-ng. */
   189         -    LIST_STATIC(Tcl_Obj *) variables;
          208  +    VariableNameList variables;
          209  +    PrivateVariableList privateVariables;
          210  +				/* Configurations for the variable resolver
          211  +				 * used inside methods. */
   190    212   } Object;
   191    213   
   192    214   #define OBJECT_DELETED	1	/* Flag to say that an object has been
   193    215   				 * destroyed. */
   194    216   #define DESTRUCTOR_CALLED 2	/* Flag to say that the destructor has been
   195    217   				 * called. */
   196    218   #define CLASS_GONE	4	/* Obsolete. Indicates that the class of this
................................................................................
   210    232   				 * no methods, mixins, or filters. */
   211    233   #define ROOT_CLASS 0x8000	/* Flag to say that this object is the root
   212    234   				 * class of classes, and should be treated
   213    235   				 * specially during teardown (and in a few
   214    236   				 * other spots). */
   215    237   #define FORCE_UNKNOWN 0x10000	/* States that we are *really* looking up the
   216    238   				 * unknown method handler at that point. */
          239  +#define HAS_PRIVATE_METHODS 0x20000
          240  +				/* Object/class has (or had) private methods,
          241  +				 * and so shouldn't be cached so
          242  +				 * aggressively. */
   217    243   
   218    244   /*
   219    245    * And the definition of a class. Note that every class also has an associated
   220    246    * object, through which it is manipulated.
   221    247    */
   222    248   
   223    249   typedef struct Class {
................................................................................
   264    290   				/* Places where call chains are stored. For
   265    291   				 * constructors, the class chain is always
   266    292   				 * used. For destructors and ordinary methods,
   267    293   				 * the class chain is only used when the
   268    294   				 * object doesn't override with its own mixins
   269    295   				 * (and filters and method implementations for
   270    296   				 * when getting method chains). */
   271         -    LIST_STATIC(Tcl_Obj *) variables;
          297  +    VariableNameList variables;
          298  +    PrivateVariableList privateVariables;
          299  +				/* Configurations for the variable resolver
          300  +				 * used inside methods. */
   272    301   } Class;
   273    302   
   274    303   /*
   275    304    * The foundation of the object system within an interpreter contains
   276    305    * references to the key classes and namespaces, together with a few other
   277    306    * useful bits and pieces. Probably ought to eventually go in the Interp
   278    307    * structure itself.
................................................................................
   366    395   
   367    396   /*
   368    397    * Bits for the 'flags' field of the call chain.
   369    398    */
   370    399   
   371    400   #define PUBLIC_METHOD     0x01	/* This is a public (exported) method. */
   372    401   #define PRIVATE_METHOD    0x02	/* This is a private (class's direct instances
   373         -				 * only) method. */
          402  +				 * only) method. Supports itcl. */
   374    403   #define OO_UNKNOWN_METHOD 0x04	/* This is an unknown method. */
   375    404   #define CONSTRUCTOR	  0x08	/* This is a constructor. */
   376    405   #define DESTRUCTOR	  0x10	/* This is a destructor. */
          406  +#define TRUE_PRIVATE_METHOD 0x20
          407  +				/* This is a private method only accessible
          408  +				 * from other methods defined on this class
          409  +				 * or instance. [TIP #500] */
          410  +#define SCOPE_FLAGS (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD)
   377    411   
   378    412   /*
   379    413    * Structure containing definition information about basic class methods.
   380    414    */
   381    415   
   382    416   typedef struct {
   383    417       const char *name;		/* Name of the method in question. */
................................................................................
   426    460   			    Tcl_Interp *interp, int objc,
   427    461   			    Tcl_Obj *const *objv);
   428    462   MODULE_SCOPE int	TclOODefineSelfObjCmd(ClientData clientData,
   429    463   			    Tcl_Interp *interp, int objc,
   430    464   			    Tcl_Obj *const *objv);
   431    465   MODULE_SCOPE int	TclOODefineObjSelfObjCmd(ClientData clientData,
   432    466   			    Tcl_Interp *interp, int objc,
          467  +			    Tcl_Obj *const *objv);
          468  +MODULE_SCOPE int	TclOODefinePrivateObjCmd(ClientData clientData,
          469  +			    Tcl_Interp *interp, int objc,
   433    470   			    Tcl_Obj *const *objv);
   434    471   MODULE_SCOPE int	TclOOUnknownDefinition(ClientData clientData,
   435    472   			    Tcl_Interp *interp, int objc,
   436    473   			    Tcl_Obj *const *objv);
   437    474   MODULE_SCOPE int	TclOOCopyObjectCmd(ClientData clientData,
   438    475   			    Tcl_Interp *interp, int objc,
   439    476   			    Tcl_Obj *const *objv);
................................................................................
   500    537   MODULE_SCOPE int	TclOODefineSlots(Foundation *fPtr);
   501    538   MODULE_SCOPE void	TclOODeleteChain(CallChain *callPtr);
   502    539   MODULE_SCOPE void	TclOODeleteChainCache(Tcl_HashTable *tablePtr);
   503    540   MODULE_SCOPE void	TclOODeleteContext(CallContext *contextPtr);
   504    541   MODULE_SCOPE void	TclOODelMethodRef(Method *method);
   505    542   MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
   506    543   			    Tcl_Obj *methodNameObj, int flags,
          544  +			    Object *contextObjPtr, Class *contextClsPtr,
   507    545   			    Tcl_Obj *cacheInThisObj);
   508    546   MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr,
   509    547   			    Tcl_Obj *methodNameObj, int flags);
   510    548   MODULE_SCOPE Foundation	*TclOOGetFoundation(Tcl_Interp *interp);
   511    549   MODULE_SCOPE Tcl_Obj *	TclOOGetFwdFromMethod(Method *mPtr);
   512    550   MODULE_SCOPE Proc *	TclOOGetProcFromMethod(Method *mPtr);
   513    551   MODULE_SCOPE Tcl_Obj *	TclOOGetMethodBody(Method *mPtr);
   514    552   MODULE_SCOPE int	TclOOGetSortedClassMethodList(Class *clsPtr,
   515    553   			    int flags, const char ***stringsPtr);
   516         -MODULE_SCOPE int	TclOOGetSortedMethodList(Object *oPtr, int flags,
          554  +MODULE_SCOPE int	TclOOGetSortedMethodList(Object *oPtr,
          555  +			    Object *contextObj, Class *contextCls, int flags,
   517    556   			    const char ***stringsPtr);
   518    557   MODULE_SCOPE int	TclOOInit(Tcl_Interp *interp);
   519    558   MODULE_SCOPE void	TclOOInitInfo(Tcl_Interp *interp);
   520    559   MODULE_SCOPE int	TclOOInvokeContext(ClientData clientData,
   521    560   			    Tcl_Interp *interp, int objc,
   522    561   			    Tcl_Obj *const objv[]);
   523    562   MODULE_SCOPE int	TclNRObjectContextInvokeNext(Tcl_Interp *interp,
................................................................................
   556    595    */
   557    596   
   558    597   #define FOREACH(var,ary) \
   559    598       for(i=0 ; i<(ary).num; i++) if ((ary).list[i] == NULL) { \
   560    599   	continue; \
   561    600       } else if (var = (ary).list[i], 1) 
   562    601   
          602  +/*
          603  + * A variation where the array is an array of structs. There's no issue with
          604  + * possible NULLs; every element of the array will be iterated over and the
          605  + * varable set to a pointer to each of those elements in turn.
          606  + * REQUIRES DECLARATION: int i;
          607  + */
          608  +
          609  +#define FOREACH_STRUCT(var,ary) \
          610  +    for(i=0 ; var=&((ary).list[i]), i<(ary).num; i++)
          611  +
   563    612   /*
   564    613    * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS
   565    614    * sets up the declarations needed for the main macro, FOREACH_HASH, which
   566    615    * does the actual iteration. FOREACH_HASH_VALUE is a restricted version that
   567    616    * only iterates over values.
          617  + * REQUIRES DECLARATION: FOREACH_HASH_DECLS;
   568    618    */
   569    619   
   570    620   #define FOREACH_HASH_DECLS \
   571    621       Tcl_HashEntry *hPtr;Tcl_HashSearch search
   572    622   #define FOREACH_HASH(key,val,tablePtr) \
   573    623       for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
   574    624   	    ((key)=(void *)Tcl_GetHashKey((tablePtr),hPtr),\

Changes to generic/tclOOMethod.c.

   182    182     populate:
   183    183       mPtr->typePtr = typePtr;
   184    184       mPtr->clientData = clientData;
   185    185       mPtr->flags = 0;
   186    186       mPtr->declaringObjectPtr = oPtr;
   187    187       mPtr->declaringClassPtr = NULL;
   188    188       if (flags) {
   189         -	mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD);
          189  +	mPtr->flags |= flags &
          190  +		(PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD);
          191  +	if (flags & TRUE_PRIVATE_METHOD) {
          192  +	    oPtr->flags |= HAS_PRIVATE_METHODS;
          193  +	}
   190    194       }
   191    195       oPtr->epoch++;
   192    196       return (Tcl_Method) mPtr;
   193    197   }
   194    198   
   195    199   /*
   196    200    * ----------------------------------------------------------------------
................................................................................
   246    250       clsPtr->thisPtr->fPtr->epoch++;
   247    251       mPtr->typePtr = typePtr;
   248    252       mPtr->clientData = clientData;
   249    253       mPtr->flags = 0;
   250    254       mPtr->declaringObjectPtr = NULL;
   251    255       mPtr->declaringClassPtr = clsPtr;
   252    256       if (flags) {
   253         -	mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD);
          257  +	mPtr->flags |= flags &
          258  +		(PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD);
          259  +	if (flags & TRUE_PRIVATE_METHOD) {
          260  +	    clsPtr->flags |= HAS_PRIVATE_METHODS;
          261  +	}
   254    262       }
   255    263   
   256    264       return (Tcl_Method) mPtr;
   257    265   }
   258    266   
   259    267   /*
   260    268    * ----------------------------------------------------------------------
................................................................................
   924    932    *
   925    933    * TclOOSetupVariableResolver, etc. --
   926    934    *
   927    935    *	Variable resolution engine used to connect declared variables to local
   928    936    *	variables used in methods. The compiled variable resolver is more
   929    937    *	important, but both are needed as it is possible to have a variable
   930    938    *	that is only referred to in ways that aren't compilable and we can't
   931         - *	force LVT presence. [TIP #320]
          939  + *	force LVT presence. [TIP #320, #500]
   932    940    *
   933    941    * ----------------------------------------------------------------------
   934    942    */
   935    943   
   936    944   void
   937    945   TclOOSetupVariableResolver(
   938    946       Tcl_Namespace *nsPtr)
................................................................................
   982    990       Tcl_ResolvedVarInfo *rPtr)
   983    991   {
   984    992       OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr;
   985    993       Interp *iPtr = (Interp *) interp;
   986    994       CallFrame *framePtr = iPtr->varFramePtr;
   987    995       CallContext *contextPtr;
   988    996       Tcl_Obj *variableObj;
          997  +    PrivateVariableMapping *privateVar;
   989    998       Tcl_HashEntry *hPtr;
   990    999       int i, isNew, cacheIt, varLen, len;
   991   1000       const char *match, *varName;
   992   1001   
   993   1002       /*
   994   1003        * Check that the variable is being requested in a context that is also a
   995   1004        * method call; if not (i.e. we're evaluating in the object's namespace or
................................................................................
  1015   1024        * is in the list provided by the user). If not, we mustn't do anything
  1016   1025        * either.
  1017   1026        */
  1018   1027   
  1019   1028       varName = TclGetStringFromObj(infoPtr->variableObj, &varLen);
  1020   1029       if (contextPtr->callPtr->chain[contextPtr->index]
  1021   1030   	    .mPtr->declaringClassPtr != NULL) {
         1031  +	FOREACH_STRUCT(privateVar, contextPtr->callPtr->chain[contextPtr->index]
         1032  +		.mPtr->declaringClassPtr->privateVariables) {
         1033  +	    match = TclGetStringFromObj(privateVar->variableObj, &len);
         1034  +	    if ((len == varLen) && !memcmp(match, varName, len)) {
         1035  +		variableObj = privateVar->fullNameObj;
         1036  +		cacheIt = 0;
         1037  +		goto gotMatch;
         1038  +	    }
         1039  +	}
  1022   1040   	FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index]
  1023   1041   		.mPtr->declaringClassPtr->variables) {
  1024   1042   	    match = TclGetStringFromObj(variableObj, &len);
  1025   1043   	    if ((len == varLen) && !memcmp(match, varName, len)) {
  1026   1044   		cacheIt = 0;
  1027   1045   		goto gotMatch;
  1028   1046   	    }
  1029   1047   	}
  1030   1048       } else {
         1049  +	FOREACH_STRUCT(privateVar, contextPtr->oPtr->privateVariables) {
         1050  +	    match = TclGetStringFromObj(privateVar->variableObj, &len);
         1051  +	    if ((len == varLen) && !memcmp(match, varName, len)) {
         1052  +		variableObj = privateVar->fullNameObj;
         1053  +		cacheIt = 1;
         1054  +		goto gotMatch;
         1055  +	    }
         1056  +	}
  1031   1057   	FOREACH(variableObj, contextPtr->oPtr->variables) {
  1032   1058   	    match = TclGetStringFromObj(variableObj, &len);
  1033   1059   	    if ((len == varLen) && !memcmp(match, varName, len)) {
  1034   1060   		cacheIt = 1;
  1035   1061   		goto gotMatch;
  1036   1062   	    }
  1037   1063   	}
................................................................................
  1669   1695   
  1670   1696   int
  1671   1697   Tcl_MethodIsPublic(
  1672   1698       Tcl_Method method)
  1673   1699   {
  1674   1700       return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0;
  1675   1701   }
         1702  +
         1703  +int
         1704  +Tcl_MethodIsPrivate(
         1705  +    Tcl_Method method)
         1706  +{
         1707  +    return (((Method *)method)->flags & TRUE_PRIVATE_METHOD) ? 1 : 0;
         1708  +}
  1676   1709   
  1677   1710   /*
  1678   1711    * Extended method construction for itcl-ng.
  1679   1712    */
  1680   1713   
  1681   1714   Tcl_Method
  1682   1715   TclOONewProcInstanceMethodEx(

Changes to generic/tclOOStubInit.c.

    69     69       Tcl_ObjectSetMetadata, /* 22 */
    70     70       Tcl_ObjectContextInvokeNext, /* 23 */
    71     71       Tcl_ObjectGetMethodNameMapper, /* 24 */
    72     72       Tcl_ObjectSetMethodNameMapper, /* 25 */
    73     73       Tcl_ClassSetConstructor, /* 26 */
    74     74       Tcl_ClassSetDestructor, /* 27 */
    75     75       Tcl_GetObjectName, /* 28 */
           76  +    Tcl_MethodIsPrivate, /* 29 */
    76     77   };
    77     78   
    78     79   /* !END!: Do not edit above this line. */

Changes to generic/tclVar.c.

  6319   6319   
  6320   6320     objectVars:
  6321   6321       if (!includeLinks) {
  6322   6322   	return;
  6323   6323       }
  6324   6324   
  6325   6325       if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) {
  6326         -	CallContext *contextPtr = iPtr->varFramePtr->clientData;
  6327         -	Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
         6326  +	Method *mPtr = (Method *)
         6327  +		Tcl_ObjectContextMethod(iPtr->varFramePtr->clientData);
         6328  +	PrivateVariableMapping *privatePtr;
  6328   6329   
  6329   6330   	if (mPtr->declaringObjectPtr) {
  6330         -	    FOREACH(objNamePtr, mPtr->declaringObjectPtr->variables) {
         6331  +	    Object *oPtr = mPtr->declaringObjectPtr;
         6332  +
         6333  +	    FOREACH(objNamePtr, oPtr->variables) {
         6334  +		Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
         6335  +		if (added && (!pattern ||
         6336  +			Tcl_StringMatch(TclGetString(objNamePtr), pattern))) {
         6337  +		    Tcl_ListObjAppendElement(interp, listPtr, objNamePtr);
         6338  +		}
         6339  +	    }
         6340  +	    FOREACH_STRUCT(privatePtr, oPtr->privateVariables) {
         6341  +		Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj,
         6342  +			&added);
         6343  +		if (added && (!pattern ||
         6344  +			Tcl_StringMatch(TclGetString(privatePtr->variableObj),
         6345  +				pattern))) {
         6346  +		    Tcl_ListObjAppendElement(interp, listPtr,
         6347  +			    privatePtr->variableObj);
         6348  +		}
         6349  +	    }
         6350  +	} else {
         6351  +	    Class *clsPtr = mPtr->declaringClassPtr;
         6352  +
         6353  +	    FOREACH(objNamePtr, clsPtr->variables) {
  6331   6354   		Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
  6332   6355   		if (added && (!pattern ||
  6333   6356   			Tcl_StringMatch(TclGetString(objNamePtr), pattern))) {
  6334   6357   		    Tcl_ListObjAppendElement(interp, listPtr, objNamePtr);
  6335   6358   		}
  6336   6359   	    }
  6337         -	} else {
  6338         -	    FOREACH(objNamePtr, mPtr->declaringClassPtr->variables) {
  6339         -		Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
         6360  +	    FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) {
         6361  +		Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj,
         6362  +			&added);
  6340   6363   		if (added && (!pattern ||
  6341         -			Tcl_StringMatch(TclGetString(objNamePtr), pattern))) {
  6342         -		    Tcl_ListObjAppendElement(interp, listPtr, objNamePtr);
         6364  +			Tcl_StringMatch(TclGetString(privatePtr->variableObj),
         6365  +				pattern))) {
         6366  +		    Tcl_ListObjAppendElement(interp, listPtr,
         6367  +			    privatePtr->variableObj);
  6343   6368   		}
  6344   6369   	    }
  6345   6370   	}
  6346   6371       }
  6347   6372       Tcl_DeleteHashTable(&addedTable);
  6348   6373   }
  6349   6374   

Changes to tests/oo.test.

  2198   2198       while executing
  2199   2199   \"info object\""
  2200   2200   test oo-16.2 {OO: object introspection} -body {
  2201   2201       info object class NOTANOBJECT
  2202   2202   } -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
  2203   2203   test oo-16.3 {OO: object introspection} -body {
  2204   2204       info object gorp oo::object
  2205         -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars}
         2205  +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, creationid, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars}
  2206   2206   test oo-16.4 {OO: object introspection} -setup {
  2207   2207       oo::class create meta { superclass oo::class }
  2208   2208       [meta create instance1] create instance2
  2209   2209   } -body {
  2210   2210       list [list [info object class oo::object] \
  2211   2211   	      [info object class oo::class] \
  2212   2212   	      [info object class meta] \
................................................................................
  2328   2328   		 [info object isa mixin list NOTANOBJECT] \
  2329   2329   		 [info object isa mixin NOTANOBJECT list] \
  2330   2330   		 [info object isa mixin oo::object list] \
  2331   2331   		 [info object isa mixin list oo::object]]
  2332   2332   } -cleanup {
  2333   2333       meta destroy
  2334   2334   } -result {class {0 0} meta {0 0 0} type {0 0 0 0 0 0} mix {0 0 0 0 0 0}}
         2335  +test oo-16.15 {OO: object introspection: creationid #500} -setup {
         2336  +    oo::class create cls
         2337  +} -body {
         2338  +    info object creationid [cls new]
         2339  +} -cleanup {
         2340  +    cls destroy
         2341  +} -result {^\d+$} -match regexp
         2342  +test oo-16.16 {OO: object introspection: creationid #500} -setup {
         2343  +    oo::class create cls
         2344  +} -body {
         2345  +    set obj [cls new]
         2346  +    set id [info object creationid $obj]
         2347  +    rename $obj gorp
         2348  +    set id2 [info object creationid gorp]
         2349  +    list $id $id2
         2350  +} -cleanup {
         2351  +    cls destroy
         2352  +} -result {^(\d+) \1$} -match regexp
         2353  +test oo-16.17 {OO: object introspection: creationid #500} -body {
         2354  +    info object creationid nosuchobject
         2355  +} -returnCodes error -result {nosuchobject does not refer to an object}
         2356  +test oo-16.18 {OO: object introspection: creationid #500} -body {
         2357  +    info object creationid
         2358  +} -returnCodes error -result {wrong # args: should be "info object creationid objName"}
         2359  +test oo-16.18 {OO: object introspection: creationid #500} -body {
         2360  +    info object creationid oo::object gorp
         2361  +} -returnCodes error -result {wrong # args: should be "info object creationid objName"}
         2362  +test oo-16.19 {OO: object introspection: creationid #500} -setup {
         2363  +    oo::class create cls
         2364  +} -body {
         2365  +    set id1 [info object creationid [set o1 [cls new]]]
         2366  +    set id2 [info object creationid [set o2 [cls new]]]
         2367  +    if {$id1 == $id2} {
         2368  +	format "objects %s and %s have same creation id: %d" $o1 $o2 $id1
         2369  +    } else {
         2370  +	string cat not-equal
         2371  +    }
         2372  +} -cleanup {
         2373  +    cls destroy
         2374  +} -result not-equal
         2375  +test oo-16.20 {OO: object introspection: creationid #500} -setup {
         2376  +    oo::class create cls
         2377  +} -body {
         2378  +    set id1 [info object creationid [set o1 [cls new]]]
         2379  +    $o1 destroy
         2380  +    set id2 [info object creationid [set o2 [cls new]]]
         2381  +    if {$id1 == $id2} {
         2382  +	format "objects %s and %s have same creation id: %d" $o1 $o2 $id1
         2383  +    } else {
         2384  +	string cat not-equal
         2385  +    }
         2386  +} -cleanup {
         2387  +    cls destroy
         2388  +} -result not-equal
         2389  +test oo-16.21 {OO: object introspection: creationid #500} -setup {
         2390  +    oo::class create cls
         2391  +} -body {
         2392  +    set id1 [info object creationid [set o1 [cls new]]]
         2393  +    set id2 [info object creationid [set o2 [oo::copy $o1]]]
         2394  +    if {$id1 == $id2} {
         2395  +	format "objects %s and %s have same creation id: %d" $o1 $o2 $id1
         2396  +    } else {
         2397  +	string cat not-equal
         2398  +    }
         2399  +} -cleanup {
         2400  +    cls destroy
         2401  +} -result not-equal
  2335   2402   
  2336   2403   test oo-17.1 {OO: class introspection} -body {
  2337   2404       info class
  2338   2405   } -returnCodes 1 -result "wrong \# args: should be \"info class subcommand ?arg ...?\""
  2339   2406   test oo-17.1.1 {OO: class introspection} -body {
  2340   2407       catch {info class} m o
  2341   2408       dict get $o -errorinfo
................................................................................
  4098   4165       }
  4099   4166       Cls create obj
  4100   4167       list [oo::objdefine obj testself] $result
  4101   4168   } -cleanup {
  4102   4169       Cls destroy
  4103   4170       catch {rename oo::objdefine::testself {}}
  4104   4171   } -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::obj}}
         4172  +
         4173  +test oo-37.1 {TIP 500: private command propagates errors} -setup {
         4174  +    oo::class create cls
         4175  +} -body {
         4176  +    oo::define cls {
         4177  +	private ::error "this is an error"
         4178  +    }
         4179  +} -cleanup {
         4180  +    cls destroy
         4181  +} -returnCodes error -result {this is an error}
         4182  +test oo-37.2 {TIP 500: private command propagates errors} -setup {
         4183  +    oo::class create cls
         4184  +} -body {
         4185  +    oo::define cls {
         4186  +	private {
         4187  +	    ::error "this is an error"
         4188  +	}
         4189  +    }
         4190  +} -cleanup {
         4191  +    cls destroy
         4192  +} -returnCodes error -result {this is an error}
         4193  +test oo-37.3 {TIP 500: private command propagates errors} -setup {
         4194  +    oo::object create obj
         4195  +} -body {
         4196  +    oo::objdefine obj {
         4197  +	private ::error "this is an error"
         4198  +    }
         4199  +} -cleanup {
         4200  +    obj destroy
         4201  +} -returnCodes error -result {this is an error}
         4202  +test oo-37.4 {TIP 500: private command propagates errors} -setup {
         4203  +    oo::object create obj
         4204  +} -body {
         4205  +    oo::objdefine obj {
         4206  +	private {
         4207  +	    ::error "this is an error"
         4208  +	}
         4209  +    }
         4210  +} -cleanup {
         4211  +    obj destroy
         4212  +} -returnCodes error -result {this is an error}
         4213  +test oo-37.5 {TIP 500: private command can't be used outside definitions} -body {
         4214  +    oo::define::private error "xyz"
         4215  +} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command}
         4216  +test oo-37.6 {TIP 500: private command can't be used outside definitions} -body {
         4217  +    oo::objdefine::private error "xyz"
         4218  +} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command}
         4219  +
         4220  +test oo-38.1 {TIP 500: private variables don't cross-interfere with each other or normal ones} -setup {
         4221  +    oo::class create parent
         4222  +} -body {
         4223  +    oo::class create clsA {
         4224  +	superclass parent
         4225  +	private variable x
         4226  +	constructor {} {
         4227  +	    set x 1
         4228  +	}
         4229  +	method getA {} {
         4230  +	    return $x
         4231  +	}
         4232  +    }
         4233  +    oo::class create clsB {
         4234  +	superclass clsA
         4235  +	private {
         4236  +	    variable x
         4237  +	}
         4238  +	constructor {} {
         4239  +	    set x 2
         4240  +	    next
         4241  +	}
         4242  +	method getB {} {
         4243  +	    return $x
         4244  +	}
         4245  +    }
         4246  +    oo::class create clsC {
         4247  +	superclass clsB
         4248  +	variable x
         4249  +	constructor {} {
         4250  +	    set x 3
         4251  +	    next
         4252  +	}
         4253  +	method getC {} {
         4254  +	    return $x
         4255  +	}
         4256  +    }
         4257  +    clsC create obj
         4258  +    oo::objdefine obj {
         4259  +	private {
         4260  +	    variable x
         4261  +	}
         4262  +	method setup {} {
         4263  +	    set x 4
         4264  +	}
         4265  +	method getO {} {
         4266  +	    return $x
         4267  +	}
         4268  +    }
         4269  +    obj setup
         4270  +    list [obj getA] [obj getB] [obj getC] [obj getO] \
         4271  +	[lsort [string map [list [info object creationid clsA] CLASS-A \
         4272  +				[info object creationid clsB] CLASS-B \
         4273  +				[info object creationid obj] OBJ] \
         4274  +		    [info object vars obj]]]
         4275  +} -cleanup {
         4276  +    parent destroy
         4277  +} -result {1 2 3 4 {{CLASS-A : x} {CLASS-B : x} {OBJ : x} x}}
         4278  +test oo-38.2 {TIP 500: private variables introspection} -setup {
         4279  +    oo::class create parent
         4280  +} -body {
         4281  +    oo::class create cls {
         4282  +	superclass parent
         4283  +	private {
         4284  +	    variable x1
         4285  +	    variable x2
         4286  +	}
         4287  +	variable y1 y2
         4288  +    }
         4289  +    cls create obj
         4290  +    oo::objdefine obj {
         4291  +	private variable a1 a2
         4292  +	variable b1 b2
         4293  +    }
         4294  +    list [lsort [info class variables cls]] \
         4295  +	[lsort [info class variables cls -private]] \
         4296  +	[lsort [info object variables obj]] \
         4297  +	[lsort [info object variables obj -private]]
         4298  +} -cleanup {
         4299  +    parent destroy
         4300  +} -result {{y1 y2} {x1 x2} {b1 b2} {a1 a2}}
         4301  +test oo-38.3 {TIP 500: private variables and oo::object·varname} -setup {
         4302  +    oo::class create parent
         4303  +} -body {
         4304  +    oo::class create clsA {
         4305  +	superclass parent
         4306  +	private {
         4307  +	    variable x
         4308  +	}
         4309  +	method getx {} {
         4310  +	    set x 1
         4311  +	    my varname x
         4312  +	}
         4313  +	method readx {} {
         4314  +	    return $x
         4315  +	}
         4316  +    }
         4317  +    oo::class create clsB {
         4318  +	superclass clsA
         4319  +	variable x
         4320  +	method gety {} {
         4321  +	    set x 1
         4322  +	    my varname x
         4323  +	}
         4324  +	method ready {} {
         4325  +	    return $x
         4326  +	}
         4327  +    }
         4328  +    clsB create obj
         4329  +    set [obj getx] 2
         4330  +    set [obj gety] 3
         4331  +    list [obj readx] [obj ready]
         4332  +} -cleanup {
         4333  +    parent destroy
         4334  +} -result {2 3}
         4335  +test oo-38.4 {TIP 500: private variables introspection} -setup {
         4336  +    oo::class create parent
         4337  +} -body {
         4338  +    oo::class create cls {
         4339  +	superclass parent
         4340  +	private {
         4341  +	    variable x1 x2
         4342  +	}
         4343  +	variable y1 y2
         4344  +	constructor {} {
         4345  +	    variable z boo
         4346  +	    set x1 a
         4347  +	    set y1 c
         4348  +	}
         4349  +	method list {} {
         4350  +	    variable z
         4351  +	    set ok 1
         4352  +	    list [info locals] [lsort [info vars]] [info exist x2]
         4353  +	}
         4354  +    }
         4355  +    cls create obj
         4356  +    oo::objdefine obj {
         4357  +	private variable a1 a2
         4358  +	variable b1 b2
         4359  +	method init {} {
         4360  +	    # Because we don't have a constructor to do this setup for us
         4361  +	    set a1 p
         4362  +	    set b1 r
         4363  +	}
         4364  +	method list {} {
         4365  +	    variable z
         4366  +	    set yes 1
         4367  +	    list {*}[next] [info locals] [lsort [info vars]] [info exist a2]
         4368  +	}
         4369  +    }
         4370  +    obj init
         4371  +    obj list
         4372  +} -cleanup {
         4373  +    parent destroy
         4374  +} -result {ok {ok x1 x2 y1 y2 z} 0 yes {a1 a2 b1 b2 yes z} 0}
         4375  +test oo-38.5 {TIP 500: private variables and oo::object·variable} -setup {
         4376  +    oo::class create parent
         4377  +} -body {
         4378  +    oo::class create cls1 {
         4379  +	superclass parent
         4380  +	private variable x
         4381  +	method abc val {
         4382  +	    my variable x
         4383  +	    set x $val
         4384  +	}
         4385  +	method def val {
         4386  +	    my variable y
         4387  +	    set y $val
         4388  +	}
         4389  +	method get1 {} {
         4390  +	    my variable x y
         4391  +	    return [list $x $y]
         4392  +	}
         4393  +    }
         4394  +    oo::class create cls2 {
         4395  +	superclass cls1
         4396  +	private variable x
         4397  +	method x-exists {} {
         4398  +	    return [info exists x],[uplevel 1 {info exists x}]
         4399  +	}
         4400  +	method ghi x {
         4401  +	    # Additional instrumentation to show that we're not using the
         4402  +	    # resolved variable until we ask for it; the argument nixed that
         4403  +	    # happening by default.
         4404  +	    set val $x
         4405  +	    set before [my x-exists]
         4406  +	    unset x
         4407  +	    set x $val
         4408  +	    set mid [my x-exists]
         4409  +	    unset x
         4410  +	    set mid2 [my x-exists]
         4411  +	    my variable x
         4412  +	    set x $val
         4413  +	    set after [my x-exists]
         4414  +	    return "$before;$mid;$mid2;$after"
         4415  +	}
         4416  +	method jkl val {
         4417  +	    my variable y
         4418  +	    set y $val
         4419  +	}
         4420  +	method get2 {} {
         4421  +	    my variable x y
         4422  +	    return [list $x $y]
         4423  +	}
         4424  +    }
         4425  +    cls2 create a
         4426  +    a abc 123
         4427  +    a def 234
         4428  +    set tmp [a ghi 345]
         4429  +    a jkl 456
         4430  +    list $tmp [a get1] [a get2]
         4431  +} -cleanup {
         4432  +    parent destroy
         4433  +} -result {{0,1;0,1;0,0;1,1} {123 456} {345 456}}
         4434  +
         4435  +test oo-39.1 {TIP 500: private methods internal call; class private} -setup {
         4436  +    oo::class create parent
         4437  +} -body {
         4438  +    oo::class create clsA {
         4439  +	superclass parent
         4440  +	variable x
         4441  +	constructor {} {
         4442  +	    set x 1
         4443  +	}
         4444  +	method act {} {
         4445  +	    my step
         4446  +	    my step
         4447  +	    my step
         4448  +	    return
         4449  +	}
         4450  +	private {
         4451  +	    method step {} {
         4452  +		incr x 2
         4453  +	    }
         4454  +	}
         4455  +	method x {} {
         4456  +	    return $x
         4457  +	}
         4458  +    }
         4459  +    clsA create obj
         4460  +    obj act
         4461  +    list [obj x] [catch {obj step} msg] $msg
         4462  +} -cleanup {
         4463  +    parent destroy
         4464  +} -result {7 1 {unknown method "step": must be act, destroy or x}}
         4465  +test oo-39.2 {TIP 500: private methods internal call; class private} -setup {
         4466  +    oo::class create parent
         4467  +} -body {
         4468  +    oo::class create clsA {
         4469  +	superclass parent
         4470  +	variable x
         4471  +	constructor {} {
         4472  +	    set x 1
         4473  +	}
         4474  +	method act {} {
         4475  +	    my step
         4476  +	    my step
         4477  +	    my step
         4478  +	    return
         4479  +	}
         4480  +	private {
         4481  +	    method step {} {
         4482  +		incr x 2
         4483  +	    }
         4484  +	}
         4485  +	method x {} {
         4486  +	    return $x
         4487  +	}
         4488  +    }
         4489  +    oo::class create clsB {
         4490  +	superclass clsA
         4491  +	variable x
         4492  +	method step {} {
         4493  +	    incr x 5
         4494  +	}
         4495  +    }
         4496  +    clsB create obj
         4497  +    obj act
         4498  +    list [obj x] [obj step]
         4499  +} -cleanup {
         4500  +    parent destroy
         4501  +} -result {7 12}
         4502  +test oo-39.3 {TIP 500: private methods internal call; class private} -setup {
         4503  +    oo::class create parent
         4504  +} -body {
         4505  +    oo::class create clsA {
         4506  +	superclass parent
         4507  +	variable x
         4508  +	constructor {} {
         4509  +	    set x 1
         4510  +	}
         4511  +	method act {} {
         4512  +	    my Step
         4513  +	    my Step
         4514  +	    my Step
         4515  +	    return
         4516  +	}
         4517  +	method x {} {
         4518  +	    return $x
         4519  +	}
         4520  +    }
         4521  +    oo::class create clsB {
         4522  +	superclass clsA
         4523  +	variable x
         4524  +	method Step {} {
         4525  +	    incr x 5
         4526  +	}
         4527  +    }
         4528  +    clsB create obj
         4529  +    obj act
         4530  +    set result [obj x]
         4531  +    oo::define clsA {
         4532  +	private {
         4533  +	    method Step {} {
         4534  +		incr x 2
         4535  +	    }
         4536  +	}
         4537  +    }
         4538  +    obj act
         4539  +    lappend result [obj x]
         4540  +} -cleanup {
         4541  +    parent destroy
         4542  +} -result {16 22}
         4543  +test oo-39.4 {TIP 500: private methods internal call; instance private} -setup {
         4544  +    oo::class create parent
         4545  +} -body {
         4546  +    oo::class create clsA {
         4547  +	superclass parent
         4548  +	variable x
         4549  +	constructor {} {
         4550  +	    set x 1
         4551  +	}
         4552  +	method act {} {
         4553  +	    my step
         4554  +	    return
         4555  +	}
         4556  +	method step {} {
         4557  +	    incr x
         4558  +	}
         4559  +	method x {} {
         4560  +	    return $x
         4561  +	}
         4562  +    }
         4563  +    clsA create obj
         4564  +    obj act
         4565  +    set result [obj x]
         4566  +    oo::objdefine obj {
         4567  +	variable x
         4568  +	private {
         4569  +	    method step {} {
         4570  +		incr x 2
         4571  +	    }
         4572  +	}
         4573  +    }
         4574  +    obj act
         4575  +    lappend result [obj x]
         4576  +    oo::objdefine obj {
         4577  +	method act {} {
         4578  +	    my step
         4579  +	    next
         4580  +	}
         4581  +    }
         4582  +    obj act
         4583  +    lappend result [obj x]
         4584  +} -cleanup {
         4585  +    parent destroy
         4586  +} -result {2 3 6}
         4587  +test oo-39.5 {TIP 500: private methods internal call; cross object} -setup {
         4588  +    oo::class create parent
         4589  +} -body {
         4590  +    oo::class create cls {
         4591  +	superclass parent
         4592  +	variable x
         4593  +	constructor {val} {
         4594  +	    set x $val
         4595  +	}
         4596  +	private method x {} {
         4597  +	    return $x
         4598  +	}
         4599  +	method equal {other} {
         4600  +	    expr {$x == [$other x]}
         4601  +	}
         4602  +    }
         4603  +    cls create a 1
         4604  +    cls create b 2
         4605  +    cls create c 1
         4606  +    list [a equal b] [b equal c] [c equal a] [catch {a x} msg] $msg
         4607  +} -cleanup {
         4608  +    parent destroy
         4609  +} -result {0 0 1 1 {unknown method "x": must be destroy or equal}}
         4610  +test oo-39.6 {TIP 500: private methods internal call; error reporting} -setup {
         4611  +    oo::class create parent
         4612  +} -body {
         4613  +    oo::class create cls {
         4614  +	superclass parent
         4615  +	variable x
         4616  +	constructor {val} {
         4617  +	    set x $val
         4618  +	}
         4619  +	private method x {} {
         4620  +	    return $x
         4621  +	}
         4622  +	method equal {other} {
         4623  +	    expr {$x == [$other y]}
         4624  +	}
         4625  +    }
         4626  +    cls create a 1
         4627  +    cls create b 2
         4628  +    a equal b
         4629  +} -returnCodes error -cleanup {
         4630  +    parent destroy
         4631  +} -result {unknown method "y": must be destroy, equal or x}
         4632  +test oo-39.7 {TIP 500: private methods internal call; error reporting} -setup {
         4633  +    oo::class create parent
         4634  +} -body {
         4635  +    oo::class create cls {
         4636  +	superclass parent
         4637  +	variable x
         4638  +	constructor {val} {
         4639  +	    set x $val
         4640  +	}
         4641  +	private method x {} {
         4642  +	    return $x
         4643  +	}
         4644  +	method equal {other} {
         4645  +	    expr {[[self] y] == [$other x]}
         4646  +	}
         4647  +    }
         4648  +    cls create a 1
         4649  +    cls create b 2
         4650  +    a equal b
         4651  +} -returnCodes error -cleanup {
         4652  +    parent destroy
         4653  +} -result {unknown method "y": must be destroy, equal or x}
         4654  +test oo-39.8 {TIP 500: private methods internal call; error reporting} -setup {
         4655  +    oo::class create parent
         4656  +} -body {
         4657  +    oo::class create cls {
         4658  +	superclass parent
         4659  +	variable x
         4660  +	constructor {val} {
         4661  +	    set x $val
         4662  +	}
         4663  +	private method x {} {
         4664  +	    return $x
         4665  +	}
         4666  +	method equal {other} {
         4667  +	    expr {[my y] == [$other x]}
         4668  +	}
         4669  +    }
         4670  +    cls create a 1
         4671  +    cls create b 2
         4672  +    a equal b
         4673  +} -returnCodes error -cleanup {
         4674  +    parent destroy
         4675  +} -result {unknown method "y": must be <cloned>, destroy, equal, eval, unknown, variable, varname or x}
         4676  +test oo-39.9 {TIP 500: private methods internal call; error reporting} -setup {
         4677  +    oo::class create parent
         4678  +} -body {
         4679  +    oo::class create cls {
         4680  +	superclass parent
         4681  +	variable x
         4682  +	constructor {val} {
         4683  +	    set x $val
         4684  +	}
         4685  +	private method x {} {
         4686  +	    return $x
         4687  +	}
         4688  +    }
         4689  +    oo::class create cls2 {
         4690  +	superclass cls
         4691  +	method equal {other} {
         4692  +	    expr {[my y] == [$other x]}
         4693  +	}
         4694  +    }
         4695  +    cls2 create a 1
         4696  +    cls2 create b 2
         4697  +    a equal b
         4698  +} -returnCodes error -cleanup {
         4699  +    parent destroy
         4700  +} -result {unknown method "y": must be <cloned>, destroy, equal, eval, unknown, variable or varname}
         4701  +test oo-39.10 {TIP 500: private methods internal call; error reporting} -setup {
         4702  +    oo::class create parent
         4703  +} -body {
         4704  +    oo::class create cls {
         4705  +	superclass parent
         4706  +	variable x
         4707  +	constructor {val} {
         4708  +	    set x $val
         4709  +	}
         4710  +	private method x {} {
         4711  +	    return $x
         4712  +	}
         4713  +    }
         4714  +    oo::class create cls2 {
         4715  +	superclass cls
         4716  +	method equal {other} {
         4717  +	    expr {[my x] == [$other x]}
         4718  +	}
         4719  +    }
         4720  +    cls2 create a 1
         4721  +    cls2 create b 2
         4722  +    a equal b
         4723  +} -returnCodes error -cleanup {
         4724  +    parent destroy
         4725  +} -result {unknown method "x": must be <cloned>, destroy, equal, eval, unknown, variable or varname}
         4726  +test oo-39.11 {TIP 500: private methods; call chain caching and reporting} -setup {
         4727  +    oo::class create parent
         4728  +} -body {
         4729  +    oo::class create cls {
         4730  +	superclass parent
         4731  +	method chain {} {
         4732  +	    return [self call]
         4733  +	}
         4734  +    }
         4735  +    oo::class create cls2 {
         4736  +	superclass cls
         4737  +	private method chain {} {
         4738  +	    next
         4739  +	}
         4740  +	method chain2 {} {
         4741  +	    my chain
         4742  +	}
         4743  +	method chain3 {} {
         4744  +	    [self] chain
         4745  +	}
         4746  +    }
         4747  +    cls create a
         4748  +    cls2 create b
         4749  +    list [a chain] [b chain] [b chain2] [b chain3]
         4750  +} -cleanup {
         4751  +    parent destroy
         4752  +} -result {{{{method chain ::cls method}} 0} {{{method chain ::cls method}} 0} {{{private chain ::cls2 method} {method chain ::cls method}} 1} {{{private chain ::cls2 method} {method chain ::cls method}} 1}}
         4753  +test oo-39.12 {TIP 500: private methods; introspection} -setup {
         4754  +    oo::class create parent
         4755  +} -body {
         4756  +    oo::class create cls {
         4757  +	superclass parent
         4758  +	method chain {} {
         4759  +	    return [self call]
         4760  +	}
         4761  +	private method abc {} {}
         4762  +    }
         4763  +    oo::class create cls2 {
         4764  +	superclass cls
         4765  +	method chain2 {} {
         4766  +	    my chain
         4767  +	}
         4768  +	method chain3 {} {
         4769  +	    [self] chain
         4770  +	}
         4771  +	private method def {} {}
         4772  +	unexport chain3
         4773  +    }
         4774  +    cls create a
         4775  +    cls2 create b
         4776  +    oo::objdefine b {
         4777  +	private method ghi {} {}
         4778  +	method ABC {} {}
         4779  +	method foo {} {}
         4780  +    }
         4781  +    set scopes {public unexported private}
         4782  +    list a: [lmap s $scopes {info object methods a -scope $s}] \
         4783  +	b: [lmap s $scopes {info object methods b -scope $s}] \
         4784  +	cls: [lmap s $scopes {info class methods cls -scope $s}] \
         4785  +	cls2: [lmap s $scopes {info class methods cls2 -scope $s}] \
         4786  +} -cleanup {
         4787  +    parent destroy
         4788  +} -result {a: {{} {} {}} b: {foo ABC ghi} cls: {chain {} abc} cls2: {chain2 chain3 def}}
         4789  +
         4790  +test oo-40.1 {TIP 500: private and self} -setup {
         4791  +    oo::class create cls
         4792  +} -body {
         4793  +    oo::define cls {
         4794  +	self {
         4795  +	    private {
         4796  +		variable a
         4797  +	    }
         4798  +	    variable b
         4799  +	}
         4800  +	private {
         4801  +	    self {
         4802  +		variable c
         4803  +	    }
         4804  +	    variable d
         4805  +	}
         4806  +	variable e
         4807  +    }
         4808  +    list \
         4809  +	[lsort [info class variables cls]] \
         4810  +	[lsort [info class variables cls -private]] \
         4811  +	[lsort [info object variables cls]] \
         4812  +	[lsort [info object variables cls -private]]
         4813  +} -cleanup {
         4814  +    cls destroy
         4815  +} -result {e d b {a c}}
         4816  +test oo-40.2 {TIP 500: private and export} -setup {
         4817  +    oo::class create cls
         4818  +} -body {
         4819  +    oo::define cls {
         4820  +	private method foo {} {}
         4821  +    }
         4822  +    set result [lmap s {public unexported private} {
         4823  +	info class methods cls -scope $s}]
         4824  +    oo::define cls {
         4825  +	export foo
         4826  +    }
         4827  +    lappend result {*}[lmap s {public unexported private} {
         4828  +	info class methods cls -scope $s}]
         4829  +} -cleanup {
         4830  +    cls destroy
         4831  +} -result {{} {} foo foo {} {}}
         4832  +test oo-40.3 {TIP 500: private and unexport} -setup {
         4833  +    oo::class create cls
         4834  +} -body {
         4835  +    oo::define cls {
         4836  +	private method foo {} {}
         4837  +    }
         4838  +    set result [lmap s {public unexported private} {
         4839  +	info class methods cls -scope $s}]
         4840  +    oo::define cls {
         4841  +	unexport foo
         4842  +    }
         4843  +    lappend result {*}[lmap s {public unexported private} {
         4844  +	info class methods cls -scope $s}]
         4845  +} -cleanup {
         4846  +    cls destroy
         4847  +} -result {{} {} foo {} foo {}}
  4105   4848   
  4106   4849   cleanupTests
  4107   4850   return
  4108   4851   
  4109   4852   # Local Variables:
  4110   4853   # mode: tcl
  4111   4854   # End: