package provide boop 1.0
########################################################################
#
# BOOP stands for "basic object oriented programming" -- this is a minimal
# object oriented helper that gives you tcl objects, member functions,
# object-local storage, memory cleanup all with one tiny ::boop function of
# less than 100 lines of tcl.
#
# The aim of BOOP is to provide a very simple object oriented programming
# helper in Tcl, without doing anything fancy or complicated, that requires
# a learning curve or causes other problems. If you want a full OOP Tcl
# environment, go for "incr Tcl" or "stoop".
#
# I tried to use stoop, but ran into a number of problems, namely: 1) it
# clashes badly with the TclPro debugger, 2) member functions seem to be
# wrapped in a silent catch{} statement, making debugging buggy member
# functions very difficult and 3) no array support. Incr Tcl was too huge
# for my needs, and I wanted an all Tcl-solution, with a minimal learning
# curve for my coworkers. I didn't want write OOPy Tcl code that no-one
# else would understand.
#
# In short, I wanted a Tcl OOP helper to be as simple, transparent as
# possible, and not to muck with built in commands or cause problems with
# the TclPro debugger or confuse people reading my OOPy code.
#
# Here is an example of using a boop object:
#
# # A simple member function:
# proc test::example {this arg} {
# # local member variable
# variable ${this}::x
# variable ${this}::z
# incr x
# puts "I am $this, passed '$arg' and x is '$x' and z(y) is '$z(y)'"
# }
#
# # "test" is the class name, "myobject" is the local object name
# boop test myobject
#
# # using the object and member function
# $myobject example "argument1"
# $myobject example "argument2"
#
# Boop automatically cleans up the object when it goes out of scope.
#
########################################################################
#
# AN COMPLETE EXAMPLE
#
# First, a source code example of using BOOP (FYI, init and deinit
# are optional):
#
# package require boop
#
# namespace eval test {}
#
# set test::line_colors { 255 13408767 6684876 10079487 39423 }
#
# proc test::init {this} {
# puts "initializing $this"
# namespace eval $this {
# variable x 0
# variable z
# set z(y) 99
# }
# }
#
# proc test::deinit {this} {
# puts "deinitializing $this"
# }
#
# proc test::example {this arg} {
# variable ${this}::x
# variable ${this}::z
# incr x
# puts "I am $this, passed '$arg' and x is '$x' and z(y) is '$z(y)'"
# }
#
# proc boop_test {} {
# boop test myobject
# $myobject example "argument1"
# $myobject example "argument2"
# }
#
# boop_test
#
# Running this code with yield this screen output:
#
# initializing ::test_1
# I am ::test_1 and was passed 'argument1' and x is '1' and z(y) is '99'
# I am ::test_1 and was passed 'argument2' and x is '2' and z(y) is '99'
# deinitializing ::test_1
#
########################################################################
#
# HOW TO USE BOOP
#
# First, define functions in a namespace, like so:
#
# namespace eval test {}
#
# proc test::example {this arg} {
# variable ${this}::x
# variable ${this}::z
# incr x
# puts "I am $this, passed '$arg' and x is '$x' and z(y) is '$z(y)'"
# }
#
#
# If you want to initialize some member variables in the namespace for this
# object, you can do it in an init function, but this is optional (the
# namespace's init function is called automatically at object construction
# time) and the objectid is passed in "this". You can also optionally create
# a deinit function:
#
# proc test::init {this} {
# namespace eval $this {
# variable x 0
# variable z
# set z(y) 99
# }
# }
#
# proc test::deinit {this} {
# puts "deinitializing $this"
# }
#
# Note how variables for the object are stored in the namespace for the
# dynamically created object, allowing easy memory cleanup.
#
# If you want static member variables, put them in as namespace variables
# outside of any proc, like so:
#
# set test::line_colors { 255 13408767 6684876 10079487 39423 }
#
# and then refer to then as namespace variables, like so:
#
# proc test::showcolors {} { puts $test::line_colors }
#
# Next, create your object with the ::boop command, passing the namespace
# name and the variable name that will hold the object, like so:
#
# boop test myobject
#
# If your namespace has a namespace::init function it is called automatically
# by BOOP at this point.
#
# Then, just use the proc name (w/o the namespace name) as the 1st parameter,
# using the objectid as the proc name, like so:
#
# $myobject example "argument1"
# $myobject example "argument2"
#
# BOOP will automatically call your namespace::functionname with the namespace
# as the first parameter, so be sure that all your member functions take
# "this" as their first parameter.
#
# There is no need to delete your object -- it will clean itself up when its
# name goes out of scope.
#
#
# UPVAR note
#
# If you want to upvar a variable passed to you, use "upvar 2" so as to skip
# over the shim function, otherwise you won't get the right variable. You
# can get rid of this need for "upvar 2" by changing the boop code to use
# "uplevel 1" (as indicated below in the source code comments) but if you do
# this the TclPro debugger won't show you the stack frame of the calling
# functions, as it doesn't like the uplevel command. If you don't use TclPro,
# then this won't matter to you.
#
# By default, BOOP requires the "upvar 2", so where you used to write:
#
# proc f {varname} { upvar $varname myvar }
#
# In BOOP you write:
#
# proc x::f {this varname} { upvar 2 $varname myvar }
#
###########
###########
#
# This is Boop version 1.0b, released 11/20/2003.
#
# Boop is a minimal object-oriented interface for Tcl, written entirely
# in Tcl, and which plays nicely with debuggers.
#
# Copyright (C) 2003 John Buckman
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public
# License as published by the Free Software Foundation; either
# version 2.1 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public
# License along with this library; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
# USA
#
###########
proc ::boop {class objectname} {
# make a number variable for this
if {![info exists ${class}::boop_number]} {
namespace eval ${class} { variable boop_number 0 }
}
# keep track of the number of the object, so we don't duplicate
variable ${class}::boop_number
# increment the number of the object
incr ${class}::boop_number
# make a namespace for this object, so that member functions can store
# variables in the namespace if they want to.
set namespacename "::${class}_$boop_number"
namespace eval $namespacename {}
# place a trace statement on the object var so it can be auto-destroyed.
uplevel 1 "set $objectname $namespacename"
upvar $objectname myobjectname
trace variable myobjectname u ${namespacename}::boop_unset
# make a command based on this name of the object, and a delete member function
#
# note, you can run the function given inside an 'uplevel' command if you like, and if you
# do, your function can 'upvar' variables as normal, because then the shim disappears.
# However, if you do this, then the TclPro debugger can't show you the any info of the state
# of the procs above you, and this is a very useful feature of TclPro. So, if you need
# to upvar inside a boop function, use "upvar 2 $x y" to skip over the shim function.
set helper " \
proc $namespacename {args} { \n\
set function \[lindex \$args 0\] \n\
set args \[lreplace \$args 0 0\] \n\
set newfunction \[concat ::${class}::\${function} ${namespacename} \$args\] \n\
return \[eval \$newfunction\]
#return \[uplevel 1 \$newfunction\]
} \n\
# delete member function for the object \n \
proc ${class}::delete {this} { \n \
\
# call the deinit function if it exists \n \
set deinitfunction ::${class}::deinit \n \
if {\[info procs \$deinitfunction\] != \"\"} { \n \
eval \[list \$deinitfunction \$this\] \n \
} \n \
\
# delete the name space, in case it was used for anything \n \
namespace delete ::\$this \n \
\
# remove the object command
rename \$this {} \n \
} \n
\n \
# destroy object when the variable name that holds it goes out of scope \n \
proc ${namespacename}::boop_unset {name1 name2 op} { \n \
${namespacename} delete \n \
} \n \
\
"
eval $helper
set initfunction ${class}::init
if {[info procs $initfunction] != ""} {
eval [list $initfunction $namespacename]
}
# return the object id
return $namespacename
}Sarnold 22may2005 IMHO the trace add variable should have the following options :
{write unset}because setting an already existing command make things confuse ; consider the following : proc ::thing::init {args} {
variable myTest
boop test myTest
$myTest doSomething "Arnold"
}
::thing::init
::thing::initIn the code above a memory leak is showed.Personally, I adapted BOOP with little enhancements to the {*} syntax introduced in Tcl 8.5, and it showed very acceptable perfs.