tclhttpd XML server

This is a simple wrapper around Sleepycat's dbxml library version 2 to implement a remote XML database server.

To install:

  • 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

Available commands:

  • 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

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
    }

Category TclHttpd | Category XML