- 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