- get dbxml-2.07 (or higher) from http://www.sleepycat.com/products/xml.shtml
- build and install dbxml
- Copy the code below into 'xmlsvr.tcl' in the tclhttpd lib directory, changing the two variables at the top to the correct paths
- add 'package require XmlSvr' and 'XmlDb_Url /XDB' to the tclhttpd startup file
- insert - 'doc' argument - inserts the xml document into the database and returns the generated name
- delete - 'name' argument - deletes the names xml document from the database
- update - 'name','doc' arguments - overwrites the named doc with the given document
- get - 'name' argument - retrieves the named document
- find - 'path' argument - searches the repository for documents matching the given XPath argument and returns their names
- findNode - 'path' argument - searches the repository for documents matching the given XPath argument and returns the nodes
curl http://localhost:8015/XDB/insert -d doc="<document><x/><y>hello, world</y></document"
=> dbxml_2
curl http://localhost:8015/XDB/get -d name=dbxml_2
=> <document><x/><y>hello, world</y></document>
curl http://localhost:8015/XDB/findNode -d path=/document/y
=> {<y>hello, world</y>}
package provide XmlSvr 0.1
### SET THESE TO THE CORRECT LOCATIONS ###
set dbxml_install /usr/local/dbxml-2.0.7/install
set xdb_home /tmp/xdb
load $dbxml_install/lib/libdb_tcl.so
load $dbxml_install/lib/libdbxml_tcl.so
# dbxml wrappers
namespace eval ::xdb {
# Provides a simple object oriented interface using
# SWIG's low level interface.
proc new {objectType handle_r args} {
# Creates a new SWIG object of the given type,
# returning a handle in the variable "handle_r".
#
# Also creates a procedure for the object and a trace on
# the handle variable that deletes the object when the
# handle varibale is overwritten or unset
upvar $handle_r handle
#
# Create the new object
#
eval set handle \[new_$objectType $args\]
#
# Set up the object procedure
#
proc $handle {cmd args} "eval ${objectType}_\$cmd $handle \$args"
#
# And the trace ...
#
uplevel trace variable $handle_r uw "{[namespace current]::deleteObject $objectType $handle}"
#
# Return the handle so that 'new' can be used as an argument to a procedure
#
return $handle
}
proc wrap {objectType handle_r obj} {
# Creates a new SWIG object of the given type,
# returning a handle in the variable "handle_r".
# Use "wrap <type> var [expr]" instead of "set var [expr]".
#
# Also creates a procedure for the object and a trace on
# the handle variable that deletes the object when the
# handle varibale is overwritten or unset
upvar $handle_r handle
#
# Setup the object
#
eval set handle {$obj}
#
# Set up the object procedure
#
proc $handle {cmd args} "eval ${objectType}_\$cmd $handle \$args"
#
# And the trace ...
#
uplevel trace variable $handle_r uw "{[namespace current]::deleteObject $objectType $handle}"
#
# Return the handle so that 'new' can be used as an argument to a procedure
#
return $handle
}
proc deleteObject {objectType handle name element op} {
#
# Check that the object handle has a reasonable form
#
if {![regexp {_[0-9a-f]*_p_(.+)} $handle]} {
error "deleteObject: not a valid object handle: $handle"
}
#
# Remove the object procedure
#
catch {rename $handle {}}
#
# Delete the object
#
delete_$objectType $handle
}
variable dbc 0
proc opendb {{cn default.xdb}} {
set dbt ::xdb::db${::xdb::dbc}
incr ::xdb::dbc
array set $dbt {}
upvar #0 $dbt db
set db(cn) $cn
set db(en) [berkdb env -create -home $::xdb_home]
new XmlManager db(db) $db(en) 0
wrap XmlContainer db(ct) [$db(db) openContainer $cn $::DB_CREATE]
return $dbt
}
proc closedb {dbt} {
upvar #0 $dbt db
unset db(ct)
unset db(db)
$db(en) close
}
proc addDoc {dbt doc} {
upvar #0 $dbt db
wrap XmlDocument xdoc [$db(db) createDocument]
$xdoc setContent $doc
wrap XmlUpdateContext uc [$db(db) createUpdateContext]
$db(ct) putDocument $xdoc $uc $::DBXML_GEN_NAME
$db(ct) sync
return [$xdoc getName]
}
proc updateDoc {dbt name doc} {
upvar #0 $dbt db
wrap XmlDocument xdoc [$db(ct) getDocument $name]
$xdoc setContent $doc
wrap XmlUpdateContext uc [$db(db) createUpdateContext]
$db(ct) updateDocument $xdoc $uc
$db(ct) sync
return [$xdoc getName]
}
proc getDoc {dbt name} {
upvar #0 $dbt db
wrap XmlDocument xdoc [$db(ct) getDocument $name]
return [$xdoc getContent]
}
proc deleteDoc {dbt name} {
upvar #0 $dbt db
wrap XmlUpdateContext uc [$db(db) createUpdateContext]
$db(ct) deleteDocument $name $uc
$db(ct) sync
return
}
proc findDoc {dbt path} {
upvar #0 $dbt db
wrap XmlQueryContext qc [$db(db) createQueryContext]
wrap XmlResults xr [$db(db) query collection('$db(cn)')$path $qc]
set rl {}
wrap XmlDocument xd [$db(db) createDocument]
while {[$xr hasNext]} {
$xr next $xd
lappend rl [$xd getName]
}
return [lsort -unique $rl]
}
proc findNode {dbt path} {
upvar #0 $dbt db
wrap XmlQueryContext qc [$db(db) createQueryContext]
wrap XmlResults xr [$db(db) query collection('$db(cn)')$path $qc]
set rl {}
new XmlValue xv
while {[$xr hasNext]} {
$xr next $xv
lappend rl [$xv asString]
}
return $rl
}
}
# tclhttpd procs
proc XmlDb_Url {url} {
Direct_Url $url XmlDb 1
}
set ::mydb [xdb::opendb]
# this wraps all of the real calls. This could be used to
# open and close the database on each call (commented out),
# or whatever else you might want (logging, transactions)
proc XmlOp {op args} {
# set db [xdb::opendb]
set err [catch {eval [concat xdb::$op $::mydb $args]} res]
# xdb::closedb $db
return -code return $res
}
proc XmlDb/insert {doc} {
XmlOp addDoc $doc
}
proc XmlDb/update {name doc} {
XmlOp updateDoc $name $doc
}
proc XmlDb/delete {name} {
XmlOp deleteDoc $name
}
proc XmlDb/get {name} {
XmlOp getDoc $name
}
proc XmlDb/find {path} {
XmlOp findDoc $path
}
proc XmlDb/findNode {path} {
XmlOp findNode $path
}Category TclHttpd | Category XML
