diff options
| -rw-r--r-- | README.oo | 253 | ||||
| -rwxr-xr-x | configure | 7 | ||||
| -rwxr-xr-x | configure.ac | 7 | ||||
| -rw-r--r-- | examples/ootest.tcl | 137 | ||||
| -rw-r--r-- | jim-load-static-exts.c | 6 | ||||
| -rw-r--r-- | oo.tcl | 89 |
6 files changed, 493 insertions, 6 deletions
diff --git a/README.oo b/README.oo new file mode 100644 index 0000000..ab8015c --- /dev/null +++ b/README.oo @@ -0,0 +1,253 @@ +OO Package for Jim Tcl +====================== + +Author: Steve Bennett <steveb@workware.net.au> +Date: 1 Nov 2010 09:18:40 + +OVERVIEW +-------- +The pure-Tcl oo package leverages Jim's unique strengths +to provide support for Object Oriented programming. + +The oo package can be statically linked with Jim or installed +as a separate Tcl package and loaded with: + + package require oo + +DECLARING CLASSES +----------------- +A class is declared with the 'class' proc as follows. + + class myclass ?baseclasses? classvars + +This declares a class named 'myclass' with the given dictionary, +'classvars', providing the initial state of all new objects. +It is important to list all class variables in 'classvars', even +if initialised only to the empty string, since the class makes +these variables available in methods and via [myclass vars]. + +A list of zero or more base classes may also be specified from +which methods and class variables are imported. See INHERITANCE +below for more details. + +Declaring a class creates a procedure with the class name along +with some related procedures. For example: + + . class Account {balance 0} + Account + . info procs Account* + {Account get} {Account methods} {Account eval} Account {Account new} {Account destroy} + {Account vars} {Account classname} {Account classvars} {Account method} + +Notice that apart from the main 'Account' procedure, all the remaining procedures (methods) +are prefixed with 'Account' and a space. + +PREDEFINED CLASS METHODS +------------------------ +Decaring a class pre-defines a number of "class" methods. i.e. those which don't +require an object and simply return or manipulate properties of the class. These are: + + new ?instancevars?:: + Creates and returns new object, optionally overriding the default class variable values. + Note that the class name is an alias for 'classname new {}' and can be used as a shorthand + for creating new objects with default values. + + method name arglist body:: + Creates or redefines a method for the class with the given name, argument list and body. + + methods:: + Returns a list of the methods supported by this class, including both class methods + and instance methods. Also includes base class methods. + + vars:: + Returns a list of the class variables for this class (names + only). Also includes base class variables. + + classvars:: + Returns a dictionary the class variables, including initial values, for this class. + Also includes base class variables. + + classname:: + Returns the classname. This can be useful as [$self classname]. + +Class methods may be invoked either via the class name or via an object of the class. +For example: + + . class Account {balance 0} + Account + . Account methods + classname classvars destroy eval get method methods new vars + . set a [Account] + <reference.<Account>.00000000000000000001> + . $a methods + classname classvars destroy eval get method methods new vars + +PREDEFINED OBJECT METHODS +------------------------- +Decaring a class pre-defines a number of "object" methods. i.e. those which operate +on a specific object. + + destroy:: + Destroys the object. This method may be overridden, but note that it should + delete the object with {rename $self ""}. This method will also be called + if the object is reaped during garbage collection. + + get varname:: + Returns the value of the given instance variable. + + eval ?locals? body:: + Makes any given local variables available to the body, along with + the instance variables, and evaluate the body in that context. + This can be used for one-off evaluation to avoid declaring a method. + +CREATING OBJECTS +---------------- +An object is created with the 'new' method, or simply by using the classname shortcut. +If the 'new' method is used, the variables for the newly created object (instance variables) +may be initialised. Otherwise they are set to the default values specified when the +class was declared. + +For example: + + . class Account {balance 0} + Account + . set a [Account] + <reference.<Account>.00000000000000000001> + . set b [Account new {balance 1000}] + <reference.<Account>.00000000000000000002> + . $a get balance + 0 + . $b get balance + 1000 + +DECLARING METHODS +----------------- +In addition to the predefined methods, new methods may be decared, or existing +methods redefined with the class method, method. + +Declaring a method is very similar to defining a proc, and the arglist +has identical syntax. For example: + + . Account method show {{channel stdout}} { $channel puts "Balance of account is $balance" } + . $b show + Balance of account is 1000 + +All instance variables are available within the method and any +changes to these variables are maintained by the object. + +In addition, the $self variables is defined and refers to the current object. +This may be used to invoke further methods on the object. For example: + + . Account method show {} { puts "Balance of account is [$self get balance]" } + . $b show + Balance of account is 1000 + +Notes: +* It is a bad idea to unset an instance variable. +* In general, you should avoid redefining any of the pre-defined methods, except for 'destroy'. +* When accessing the caller's scope with upvar or uplevel, note that there + are two frame levels between the caller and the method. Thus it is necessary + to use 'upvar 2' or 'uplevel 2' + +INHERITANCE +----------- +For each base class given in a new class declaration, the methods +and variables of those classes are imported into the new class being +defined. Base classes are imported in left to right order, so that if a +method is defined in more than one base class, the later definition +is selected. This applies similarly to class variables. + +Within a method, 'super' may be used to explicitly invoke a +base class method on the object. This applies only to the *last* +base class given. For example: + + # Assumes the existence of classes Account and Client + . Account method debit {amount} { incr balance -$amount } + . class CreditAccount {Client Account} {type visa} + CreditAccount + . CreditAccount method debit {amount} { + puts "Debit $type card" + super debit $amount + } + . set a [CreditAccount] + <reference.<Account>.00000000000000000001> + . $a debit 20 + Debit visa card + . $a balance + -20 + +In the CreditAccount debit method, the call to 'super debit' invokes +the method 'Account debit' since Account is the last base class listed. + +OBJECT LIFETIME/GARBAGE COLLECTION +---------------------------------- +Objects are implemented as lambdas. That is, they are procedures with state +and are named as references. This means that when an object is no longer +reachable by any name and garbage collection runs, the object will be +discarded and the destructor will be invoked. Note that the garbage collector +can be invoked manually with 'collect' if required. + + . class Account {} + Account + . Account method destroy {} { puts dying...; rename $self "" } + Account destroy + . proc a {} { set b [Account]; return "" } + a + . a + . collect + dying... + 1 + +CLASS METHODS/CLASS STATIC VARIABLES +------------------------------------ +All methods defined with 'method' operate on objects (instances). +If a class method is required, it is possible to simply declare one with 'proc'. +The method dispatcher will automatically be able to dispatch to this method. +Using this approach, it is also possible to add class static variables by +defining static variables to the proc. Although strictly these variables +are accessible only to that proc, not the class as a whole. + +For example: + + . class Account {} + Account + . proc {Account nextid} {} {{id 0}} { incr id } + Account nextid + . Account nextid + 1 + . Account nextid + 2 + . set a [Account] + <reference.<Account>.00000000000000000001> + . $a nextid + 3 + . $a eval { $self nextid } + 4 + +HOW METHOD DISPATCH WORKS +------------------------- +All class and object methods are name "classname methodname". + +The class method dispatcher is named "classname". When invoked with a methodname, +it simply invokes the method "classname methodname". + +The method dispatch is via a two step process. Firstly the object procedure is invoked +with the method name. This procedure then invokes "classname method" which sets up +the appropriate access to the object variables, and then invokes the method body. + +EXAMPLES +-------- +tree.tcl +~~~~~~~~ +The 'tree' package is implemented using the 'oo' package. +See the source code in tree.tcl and a usage example in tests/tree.test + +Of particular note is how callbacks and recursive invocation is used in the 'walk' method. + +examples/ootest.tcl +~~~~~~~~~~~~~~~~~~~ +A comprehensive OO example is provided in examples/ootest.tcl. + +It can be run simply as: + + ./jimsh examples/ootest.tcl @@ -1354,7 +1354,8 @@ Optional Packages: These are disabled by default: nvp - Name-value pairs C-only API - tree - Similar to tcllib ::struct::tree using references + oo - Jim OO extension + tree - OO tree structure, similar to tcllib ::struct::tree readline - Interface to libreadline rlprompt - Tcl wrapper around the readline extension sqlite - Interface to sqlite @@ -3843,12 +3844,12 @@ in_list() } # Tcl extensions -ext_tcl="stdlib glob tclcompat tree rlprompt" +ext_tcl="stdlib glob tclcompat tree rlprompt oo" # C extensions ext_c="load package readdir array clock exec file posix regexp signal aio eventloop syslog nvp readline sqlite sqlite3 win32" # Tcl extensions which can be modules -ext_tcl_mod="glob tree rlprompt" +ext_tcl_mod="glob tree rlprompt oo" # C extensions which can be modules ext_c_mod="readdir array clock file posix regexp syslog readline sqlite sqlite3 win32" diff --git a/configure.ac b/configure.ac index 23e3070..824373f 100755 --- a/configure.ac +++ b/configure.ac @@ -92,12 +92,12 @@ in_list() } # Tcl extensions -ext_tcl="stdlib glob tclcompat tree rlprompt" +ext_tcl="stdlib glob tclcompat tree rlprompt oo" # C extensions ext_c="load package readdir array clock exec file posix regexp signal aio eventloop syslog nvp readline sqlite sqlite3 win32" # Tcl extensions which can be modules -ext_tcl_mod="glob tree rlprompt" +ext_tcl_mod="glob tree rlprompt oo" # C extensions which can be modules ext_c_mod="readdir array clock file posix regexp syslog readline sqlite sqlite3 win32" @@ -133,7 +133,8 @@ AC_ARG_WITH(jim-ext, These are disabled by default: nvp - Name-value pairs C-only API - tree - Similar to tcllib ::struct::tree using references + oo - Jim OO extension + tree - OO tree structure, similar to tcllib ::struct::tree readline - Interface to libreadline rlprompt - Tcl wrapper around the readline extension sqlite - Interface to sqlite diff --git a/examples/ootest.tcl b/examples/ootest.tcl new file mode 100644 index 0000000..d04951e --- /dev/null +++ b/examples/ootest.tcl @@ -0,0 +1,137 @@ +package require oo + +# Create a class, the usual bank account, with two instance variables: +class Account { + balance 0 + name "Unknown" +} + +# We have some class methods predefined +# Note we can call (e.g.) either Account.methods or 'Account methods' +puts "---- class Account ----" +puts "Account vars=[Account vars]" +puts "Account methods=[Account methods]" +puts "" + +# Now flesh out the class with some methods +# Could use 'Account method' here instead +Account method deposit {amount} { + set balance [+ $balance $amount] +} +Account method see {} { + set balance +} +Account method withdraw {amount} { + if {$amount > $balance} {error "Sorry $name, can only withdraw $balance"} + set balance [- $balance $amount] +} +Account method describe {} { + puts "I am object $self of class [$self classname]" + puts "My 'see' method returns [$self see]" + puts "My variables are:" + foreach i [$self vars] { + puts " $i=[set $i]" + } +} + +# Now an instance, initialisition some fields +set a [Account new {name "Bob Smith"}] + +puts "---- object Account ----" +# We can use class methods on the instance too +puts a.vars=[$a vars] +puts a.classname=[$a classname] + +# Now object methods +$a deposit 100 +puts "deposit 100 -> [$a see]" + +$a withdraw 40 +puts "withdraw 40 -> [$a see]" + +catch {$a withdraw 1000} res +puts "withdraw 1000 -> $res\n" + +# Tell me something about the object +$a describe +puts "" + +# Now create a new subclass +class CreditAccount Account { + limit -1000 +} +# Override the 'withdraw' method to allow overdrawing +CreditAccount method withdraw {amount} { + if {$balance - $amount < $limit} {error "Sorry $name, that would exceed your credit limit of [expr -$limit]"} + set balance [- $balance $amount] +} +# Override the 'describe' method, but invoke the baseclass method first +CreditAccount method describe {} { + # First invoke the base class 'describe' + super describe + if {$balance < 0} { + puts "*** Account is in debit" + } +} + +puts "---- class CreditAccount ----" +puts "CreditAccount vars=[CreditAccount vars]" +puts "CreditAccount methods=[CreditAccount methods]" +puts "" + +puts "---- object CreditAccount ----" +set b [CreditAccount new {name "John White"}] + +puts b.vars=[$b vars] +puts b.classname=[$b classname] + +$b deposit 100 +puts "deposit 100 -> [$b see]" + +$b withdraw 40 +puts "withdraw 40 -> [$b see]" + +$b withdraw 1000 +puts "withdraw 1000 -> [$b see]" +puts "" + +# Tell me something about the object +$b describe +puts "" + +# 'eval' is similar to 'dict with' for an object, except it operates +# in it's own scope. A list of variables can be imported into the object scope. +# It is useful for ad-hoc operations for which it is not worth defining a method. +set total 0 +$a eval total { incr total $balance } +incr total [$b get balance] +puts "Total of accounts [$a get name] and [$b eval {return "$name (Credit Limit: $limit)"}] is: $total" + +# Can we find all objects in the system? +# Almost. We can't really distinguish those which aren't real classes. +# This will get all references which aren't simple lambdas. +puts "---- All objects ----" +Account new {name "Terry Green" balance 20} +set x [Account] +lambda {} {dummy} +ref blah blah + +foreach r [info references] { + if {[getref $r] ne {}} { + try { + $r eval { + puts [format "Found %14s: Owner: %14s, Balance: %+5d, in object %s" [$self classname] $name $balance $self] + } + } on error msg { + puts "Not an object: $r" + } + } +} +unset r + +# And goodbye +$a destroy + +# Let the garbage collection take care of this one +unset b +collect diff --git a/jim-load-static-exts.c b/jim-load-static-exts.c index 003b74b..e025521 100644 --- a/jim-load-static-exts.c +++ b/jim-load-static-exts.c @@ -54,5 +54,11 @@ int Jim_InitStaticExtensions(Jim_Interp *interp) #ifdef jim_ext_syslog LOAD_EXT(syslog); #endif +#ifdef jim_ext_oo + LOAD_EXT(oo); +#endif +#ifdef jim_ext_tree + LOAD_EXT(tree); +#endif return JIM_OK; } @@ -0,0 +1,89 @@ +# OO support for Jim Tcl, with multiple inheritance + +# Create a new class $classname, with the given +# dictionary as class variables. These are the initial +# variables which all newly created objects of this class are +# initialised with. +# +# If a list of baseclasses is given, +# methods and instance variables are inherited. +# The *last* baseclass can be accessed directly with [super] +# Later baseclasses take precedence if the same method exists in more than one +proc class {classname {baseclasses {}} classvars} { + foreach baseclass $baseclasses { + # Start by mapping all methods to the parent class + foreach method [$baseclass methods] { alias "$classname $method" "$baseclass $method" } + # Now import the base class classvars + set classvars [dict merge $classvars [$baseclass classvars]] + # The last baseclass will win here + proc "$classname baseclass" {} baseclass { return $baseclass } + } + + # Make sure that classvars is a dictionary + set vars [lsort [dict keys $classvars]] + + # This is the class dispatcher for $classname + # It simply dispatches 'classname cmd' to a procedure named {classname cmd} + # with a nice message if the class procedure doesn't exist + proc $classname {{cmd new} args} classname { + if {![exists -proc "$classname $cmd"]} { + return -code error "$classname, unknown command \"$cmd\": should be [join [$classname methods] ", "]" + } + tailcall "$classname $cmd" {*}$args + } + + # Constructor + proc "$classname new" {{instvars {}}} {classname classvars} { + set instvars [dict merge $classvars $instvars] + + # This is the object dispatcher for $classname. + # Store the classname in both the ref value and tag, for debugging + # ref tag (for debugging) + proc [ref $classname $classname "$classname finalize"] {method args} {classname instvars} { + if {![exists -proc "$classname $method"]} { + return -code error "$classname, unknown method \"$method\": should be [join [$classname methods] ", "]" + } + "$classname $method" {*}$args + } + } + # Finalizer to invoke destructor during garbage collection + proc "$classname finalize" {ref classname} { $ref destroy } + # Method creator + proc "$classname method" {method arglist body} classname { + proc "$classname $method" $arglist {body} { + # Make sure this isn't incorrectly called without an object + if {![uplevel exists instvars]} { + return -code error -level 2 "\"[lindex [info level 0] 0]\" method called with no object" + } + lassign [info level -1] self + # Note that we can't use 'dict with' here because + # the dict isn't updated until the body completes. + foreach _ [$self vars] {upvar 1 instvars($_) $_} + eval $body + } + } + # Other simple class procs + proc "$classname vars" {} vars { return $vars } + proc "$classname classvars" {} classvars { return $classvars } + proc "$classname classname" {} classname { return $classname } + proc "$classname methods" {} classname { + lsort [lmap p [info procs "$classname *"] { + lindex [split $p " "] 1 + }] + } + # Pre-defined some instance methods + $classname method destroy {} { rename $self "" } + $classname method get {var} { set $var } + $classname method eval {{locals {}} code} { + foreach var $locals { upvar 2 $var $var } + eval $code + } + return $classname +} + +# From within a method, invokes the given method on the base class. +# Note that this will only call the last baseclass given +proc super {method args} { + upvar self self + uplevel 2 [$self baseclass] $method {*}$args +} |