Forum OpenACS Development: Re: OpenACS, XoTcl, and ActiveRecord
with the short answers, such people can skip the long answers
below:
Lars first question: i think, you questions concerning
the class name and the colon handling are sorted out.
A simple thing, to make things a little more pretty is
to define an instproc name available for all objects
(and classes) such as
Object instproc name {} {return [namespace tail [self]]}
then you can do a ... [my name] in each object or class.
---
Guan: keeping business logic in one class: you can
keep things certainly "in one class",
ActiveRecord Person -parameter {{credit 0}}
Person instproc email_addr {} {
return [namespace tail [mailto:self]]@somehost.somedomain
}
Person instproc send_email {subject message} {
puts "send_email_proc [my email_addr] $subject $message"
}
Person jeff
jeff send_email "hi" "some text"
The only separation here is that xotcl/tcl uses separate
commands to define methods/procs which can be incrementally
redefined. If you prefer a more close appearance, one
can use
ActiveRecord Person -parameter {{credit 0}} \
-proc table_name {} { return "people" } \
-proc id_column {} { return "people_id" } \
-instproc email_addr {} {
return [namespace tail [mailto:self]]@somehost.somedomain
} \
-instproc send_email {subject msg} {
puts "send_email_proc [my email_addr] $subject $msg"
}
since one can call every method via the configure call
in the creation.
---
Concering the active record example: Lars, you
might find some usage of the following code, that
i posting here, since it is not very long. I wrote
this code two years ago, which follows the idea that
one creates classes/object in xotcl and xotcl
tries to create query and update the database underneath.
This might not the best thing for usage in openacs,
where you probably want more control over the database,
use stored procedures and such, but anyhow, one can
use it as a source for ideas and code snipplets. One
can subclass the provided methods to make use
of faster queries and use the generic ones as default.
When i remember correctly, neophytos did some experiences
with the code below, and came most probably up with
something better and more clever than this little demo....
I will add this to the xotcl distro and put it
under the tcl-style open license.
Basically,
- one creates classes and objects,
- during the creation of classes, the system
checks for the existance of corresponding tables and
creates it on the fly if necessary;
- on the creation of objects, it checks for
the existance of tuples and fetches it if possible.
- The system uses write traces for variables to
maintain a dirty flag;
- when the flag is set, an update call updates the
database;
- when the object is destroyed, it performs the
update as well.
Here is a sample file. the DB_Manager defines
the linkage with the database. DB_Classes are
Classes with persistent data in the database.
The database attributes are defined via '-att',
which are embedded objects that might contain
more metadata (such the name of the attributes,
its datatype, wether it is a primary key or not, etc.)
For fun, i defined two different mapping strategies,
relational and object-relational, where the latter
one is using postgres' object relational definitions.
----
package require xotcl::store::reldb
package require xotcl::store::postgres
DB_Manager dbm1
DB_Table parameter {{dbmgr dbm1}}
DB_Class Person -superclass DB_Object \
-att {id -attname PERSON_ID -pk 1 -type integer} \
-att {count -type integer} \
-att age \
-att name
DB_Class Employee -superclass Person \
-mapping object-relational \
-att ssn
DB_Class ProjectLeader -superclass Employee -table LEADER \
-mapping object-relational \
-att {project -attname PROJECT_ID -type integer}
DB_Class Project -superclass DB_Object \
-att {id -attname PROJECT_ID -pk 1 -type integer} \
-att name \
-att {mgr -attname MANAGER}
DB_Class DevelopmentProject -superclass Project -table DEVPROJECT \
-att {product -attname PRODUCT_ID -type integer}
Person p -id 111 -age 22 -name "Gustaf" -count 0
Employee e1 -id 4711
ProjectLeader pp -id 333
Person p1 -id 111
p incr count
DevelopmentProject openacs -id 123 -name OpenACS -mgr nobody -product 222
--------------
The db mapping is defined below.
It contains the definition for
- DB_Att (database attributes)
These hold metadata about attributes, such as
name of the attribute in the database, data type,
the name of the corresponding variable in the
xotcl object, etc.)
- DB_Table (class for maintaining tables)
for the tables, subobjects are defined on the
class level (e.g. Person::table), which do all
perform the datbase logic; the tables contain
as subobjects instances of DB_ATT, which
contain the meta data about the attributes
of the table (e.g. Person::table::age)
It has methods for defining e.q.
SQL create, select or insert statements.
- DB_Class (similar do ::xotcl::Class):
a meta class providing the linkage
between application classes and DB_Tables.
- DB_Mapping (the two experimental mappings)
- DB_Object (similar to ::xotcl::Object), containing
methods avaiable to all objects with persistant
data.
--------------
package provide xotcl::store::reldb 0.9
Class DB_Att -parameter {
{type varchar(255)}
{attname {[namespace tail [self]]}}
{pk 0}
}
DB_Att instproc varname {} {
return [namespace tail [self]]
}
DB_Att instproc quoted {value} {
if {[my type] == "integer"} { return $value }
return '$value'
}
DB_Att instproc = o {
return [my attname]=[my quoted [$o set [my varname]]]
}
Class DB_Table -parameter {table inherits references}
DB_Table instproc allAtts {} {
set atts [my info children]
if {[my exists inherits]} {
set atts [concat $atts [[my inherits] allAtts]]
}
return $atts
}
DB_Table instproc pk {} {
foreach a [my info children] {if {[$a pk]} { return $a }}
if {[my exists inherits]} {return [[my set inherits] pk]}
if {[my exists references]} {return [[my set references] pk]}
return ""
}
DB_Table instproc Select {o} {
my instvar dbmgr
set dbatts [list]
set vars [list]
foreach a [my allAtts] {
lappend dbatts [$a attname]
lappend vars [$a varname]
}
if {[my exists references]} {
set r [my references]
#set rpk [$r pk]
#lappend dbatts [$rpk attname]
#lappend vars [$rpk varname]
$r Select $o
}
set cmd "SELECT [join $dbatts ,] FROM [my table] WHERE [[my pk] = $o]"
return [$dbmgr fetch "$cmd;" $o $vars]
}
DB_Table instproc Insert {o} {
my instvar dbmgr
set dbatts [list]
set values [list]
foreach a [my allAtts] {
set vn [$a varname]
if {[$o exists $vn]} {
lappend dbatts [$a attname]
lappend values [$a quoted [$o set $vn]]
}
}
if {[my exists references]} {
set r [my references]
set rpk [$r pk]
set vn [$rpk varname]
lappend dbatts [$rpk attname]
lappend values [$rpk quoted [$o set $vn]]
$r Insert $o
}
set cmd "INSERT into [my table] ([join $dbatts {, }]) \
VALUES ([join $values {, }])"
return [$dbmgr doSql "$cmd;"]
}
DB_Table instproc Create {} {
my instvar dbmgr
if {[$dbmgr tableExists [my table]]} return
set dbatts [list]
foreach a [my info children] {
set decl "[$a attname] [$a type]"
if {[$a pk]} {append decl " PRIMARY KEY"}
lappend dbatts $decl
}
set ref ""
if {[my exists references]} {
set r [my references]
set a [$r pk]
lappend dbatts "[$a attname] [$a type]"
set ref ", FOREIGN KEY([$a attname]) REFERENCES [$r table]"
}
set attspec [join $dbatts ",\n\t"]
set cmd "CREATE TABLE [my table] (\n\t$attspec$ref\n)"
if {[my exists inherits]} {
append cmd " INHERITS ([[my inherits] table])"
}
$dbmgr doSql "$cmd;"
}
DB_Table instproc Update {o} {
my instvar dbmgr
set pairs [list]
foreach a [my allAtts] {
if {[$o exists [$a varname]]} {
lappend pairs [$a = $o]
}
}
if {[my exists references]} {
set r [my references]
lappend pairs [[$r pk] = $o]
$r Update $o
}
set cmd "UPDATE [my table] SET [join $pairs ,] WHERE [[my pk] = $o]"
return [$dbmgr doSql "$cmd;"]
}
Class DB_Class -superclass Class -parameter {
{mapping relational}
{table {[namespace tail [self]]}}
}
DB_Class instproc att list {
if {![my isobject [self]::table]} {
DB_Table create [self]::table -table [my table]
}
eval DB_Att create [self]::table::$list
my parameter [lindex $list 0]
}
DB_Class instproc init {} {
my mixin DB_mapping=[my mapping]
my tableLinkage
if {[my isobject [self]::table]} {
[self]::table Create
}
}
DB_Class instproc update o {
if {[$o exists __dirty_flag__]} {
[self]::table Update $o
$o unset __dirty_flag__
}
}
DB_Class instproc instdestroy {o args} {
my update $o
set pk [[self]::table pk]
set vn [$pk varname]
if {[$o exists $vn]} {
set key [$o set $vn]
my unset keys($key)
}
catch {[[self]::table dbmgr] unset fetched($o)}
next
}
DB_Class instproc create args {
set o [next]
set pk [[self]::table pk]
set vn [$pk varname]
if {[$o exists $vn]} {
set key [$o set $vn]
if {[my exists keys($key)]} {
set obj [my set keys($key)]
puts "object of class my key $key was fetched already, returning object $obj\n"
$o destroy ;# destroy unsets keys($key)
return [my set keys($key) $obj]
} else {
if {![[self]::table Select $o]} {
[self]::table Insert $o
}
my set keys($key) $o
}
} else {
puts "no key specified"
}
return $o
}
Class DB_mapping
Class DB_mapping=relational -superclass DB_mapping
DB_mapping=relational instproc tableLinkage {} {
set sc [my info superclass]
if {[my isobject [self]::table] && $sc != "::DB_Object"} {
[self]::table references ${sc}::table
}
}
Class DB_mapping=object-relational -superclass DB_mapping
DB_mapping=object-relational instproc tableLinkage {} {
set sc [my info superclass]
if {[my isobject [self]::table] && $sc != "::DB_Object"} {
[self]::table inherits ${sc}::table
}
}
DB_Class DB_Object
DB_Object instproc vartrace {name sub op} {
if {$op == "w"} {
#puts "my set __dirty_flag__ 1"
my set __dirty_flag__ 1
}
}
-----
Below is the little postgres driver for libpgtcl
which connects to the database, queries the
table catalog and performs the real queries. The class should be replaced by something
more appropriate in openacs...
-----
package provide xotcl::store::postgres 0.9
load /usr/lib/libpgtcl.so
Class DB_Manager -parameter {
{host localhost}
{port 5432}
{dbname test}
{recreate 0}
}
DB_Manager instproc init {} {
my instvar host port dbname conn
set dbn [string tolower $dbname]
set conn [pg_connect template1 -host $host -port $port]
#set conn [pg_connect template1 -options user=postgres]
set res [pg_exec $conn "SELECT datname FROM pg_database where datname='$dbn'"]
set ntups [pg_result $res -numTuples]
pg_result $res -clear
if {$ntups == 0} {
puts "we have to create database $dbname"
set res [pg_exec $conn "CREATE DATABASE $dbname;"]
pg_result $res -clear
} else {
pg_disconnect $conn
puts "opening database $dbname"
set conn [pg_connect $dbname -host $host -port $port]
}
}
DB_Manager instproc tableExists {name} {
my instvar conn
if {[my recreate]} {
set res [pg_exec $conn "DROP TABLE $name;"]
pg_result $res -clear
return 0
}
set n [string tolower $name]
set res [pg_exec $conn \
"SELECT tablename FROM pg_tables WHERE tablename='$n';"]
set ntups [pg_result $res -numTuples]
pg_result $res -clear
return $ntups
}
DB_Manager instproc doSql {cmd} {
my instvar conn
set res [pg_exec $conn $cmd]
puts "*** doSql $cmd"
pg_result $res -clear
}
DB_Manager instproc fetch {cmd o vars} {
my instvar conn
set res [pg_exec $conn $cmd]
set ntups [pg_result $res -numTuples]
puts "$o: $cmd got $ntups tuples"
if {$ntups > 0} {
my set fetched($o) 1
foreach var $vars value [pg_result $res -getTuple 0] {
$o set $var $value
$o trace variable $var w [list $o vartrace]
}
}
pg_result $res -clear
return $ntups
}
DB_Manager instproc disconnect {} {
my instvar conn
foreach o [my array names fetched] {
[$o info class] update $o
}
puts "*** closing connection"
pg_disconnect $conn
my unset conn
}
DB_Manager instproc destroy {} {
my disconnect
}
