This is a simple wrapper around Sleepycat's dbxml library version 2 to implement a remote XML database server.
To install:
Available commands:
Examples (using curl):
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 add variable $handle_r {unset write} "{[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 add variable $handle_r {unset write} "{[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
}