# See the file LICENSE for redistribution information.
#
# Copyright (c) 1996-2003
#	Sleepycat Software.  All rights reserved.
#
# $Id: xmlutils.tcl,v 1.20 2003/08/25 17:52:05 mjc Exp $
#
# DB XML test system utilities
#

proc xml_cleanup { dir env { quiet 0 } } {
	global old_encrypt
	global passwd
	source ./include.tcl

	set ret [catch { glob $dir/*.dbxml } result]
	if { $ret == 0 } {
		foreach fileorig $result {
			set remove_flags 0
			if { $env != "NULL" } {
				set file [file tail $fileorig]
				if { [is_txnenv $env] } {
					set remove_flags $DB_AUTO_COMMIT
				}
			} else {
				set file $fileorig
			}

			set ret [catch {
				new XmlContainer container $env $file
				$container remove $remove_flags
				delete container
			} res]

			if { $ret != 0 && $quiet == 0 } {
				puts "FAIL: xml_cleanup failed for $file: $res"
			}
		}
	}
	
	# Now call DB's cleanup, which will remove all remaining files
	cleanup $dir $env $quiet
}

# Verify all XmlContainers in the specified directory.
proc xml_verify_dir { {directory $testdir} \
    { pref "" } { noredo 0 } { quiet 0 } { nodump 0 } { cachesize 0 } } {
	global encrypt
	global passwd

	# If we're doing database verification between tests, we don't
	# want to do verification twice without an intervening cleanup--some
	# test was skipped.  Always verify by default (noredo == 0) so
	# that explicit calls to xml_verify_dir during tests don't require
	# cleanup commands.
	if { $noredo == 1 } {
		if { [file exists $directory/NOREVERIFY] == 1 } {
			if { $quiet == 0 } {
				puts "Skipping verification."
			}
			return
		}
		set f [open $directory/NOREVERIFY w]
		close $f
	}

	if { [catch {glob $directory/*.dbxml} containers] != 0 } {
		# No files matched
		return
	}
	if { [file exists /dev/stderr] == 1 } {
		set errfilearg "-errfile /dev/stderr "
	} else {
		set errfilearg ""
	}
	set errpfxarg {-errpfx "FAIL: verify" }
	set errarg $errfilearg$errpfxarg
	set ret 0

	# Open an env, so that we have a large enough cache.  Pick
	# a fairly generous default if we haven't specified something else.

	if { $cachesize == 0 } {
		set cachesize [expr 1024 * 1024]
	}
	set encarg ""
	if { $encrypt != 0 } {
		set encarg "-encryptaes $passwd"
	}

	set env [eval {berkdb_env -home $directory -create -private} $encarg \
	    {-cachesize [list 0 $cachesize 0]}]
	set earg " -env $env $errarg "

	foreach cpath $containers {
		set container [file tail $cpath]

		new XmlContainer xc $env $container

		if { [catch {$xc verify "" 0} res] != 0 } {
			puts $res
			puts "FAIL:[timestamp] $container verification failed."
			set ret 1
			continue
		}

		if { $quiet == 0 } {
			puts "${pref}Verification of $container succeeded."
		}

		delete xc

		# Skip the dump if it's dangerous to do it.
		if { $nodump == 0 } {
			if { [catch {xml_dumploadtest $directory $container $pref $quiet} res] != 0 } {
				puts $res
				puts "FAIL:[timestamp] Dump/load of $container failed."
				set ret 1
				continue
			}

			error_check_good dumpload:$container $res 0
			if { $quiet == 0 } {
				puts \
				    "${pref}Dump/load of $container succeeded."
			}
		}
	}

	error_check_good vrfyenv_close [$env close] 0

	return $ret
}

proc xml_dumploadtest { directory container pref quiet } {
	global util_path
	global xmlutil_path
	global encrypt
	global passwd

	set ret 0
	set newname $container-dumpload

	set utilflag "-h $directory"
	if { $encrypt != 0 } {
		set utilflag "$utilflag -P $passwd"
	}

	# Do a db_dump test.  Dump/load each file.
	set rval [catch {eval {exec $xmlutil_path/dbxml_dump} $utilflag \
	        $container | $xmlutil_path/dbxml_load $utilflag $newname} res]
	error_check_good dbxml_dump/dbxml_load($container:$res) $rval 0

	foreach dbname [eval {exec $util_path/db_dump} $utilflag -l $container] {
		# Don't check the dictionary or statistics databases - it's
		# okay if the are different.  We can't easily check
		# index_number - it has a custom bt_compare, which isn't
		# accessible from Tcl.
		if { [ string first "primary_dictionary" $dbname ] != -1 ||
		     [ string first "document_statistics" $dbname ] != -1 ||
		     [ string first "index_number" $dbname ] != -1 } {
			continue
		}

		if { [catch {eval xml_dbcmp $dbname $directory/$container $directory/$newname} res] != 0 } {
			puts $res
			puts "FAIL:[timestamp] Check of $dbname failed."
			set ret 1
			continue
		}

		error_check_good xml_dbcmp:$dbname $res 0
		if { $quiet == 0 } {
			puts "${pref}Check of $dbname succeeded."
		}
	}

	eval berkdb dbremove $directory/$newname

	return $ret
}

proc xml_dbcmp { dbname oldfile newfile } {
	global encrypt
	global passwd
	
	# Open original database
	set dbarg ""
	if { $encrypt != 0 } {
		set dbarg "-encryptany $passwd"
	}

	# Open old database.
	set olddb [eval {berkdb_open -rdonly} $dbarg $oldfile $dbname]
	error_check_good olddb($oldfile:$dbname) [is_valid_db $olddb] TRUE

	# Now open new database.
	set newdb [eval {berkdb_open -rdonly} $dbarg $newfile $dbname]
	error_check_good newdb($newfile:$dbname) [is_valid_db $newdb] TRUE

	# Walk through olddb and newdb and make sure their contents
	# are identical.
	set oc [$olddb cursor]
	set nc [$newdb cursor]
	error_check_good orig_cursor($oldfile:$dbname) \
	    [is_valid_cursor $oc $olddb] TRUE
	error_check_good new_cursor($newfile:$dbname) \
	    [is_valid_cursor $nc $newdb] TRUE

	set ret 0
	for { set odbt [$oc get -first] } { [llength $odbt] > 0 } \
	    { set odbt [$oc get -next] } {
		set ndbt [$nc get -get_both \
		    [lindex [lindex $odbt 0] 0] [lindex [lindex $odbt 0] 1]]
		if { [ catch { error_check_good \
		    db_compare($oldfile:$dbname) $ndbt $odbt } res ] != 0 } {
			puts $res
			set ret 1
		}
	}

	for { set ndbt [$nc get -first] } { [llength $ndbt] > 0 } \
	    { set ndbt [$nc get -next] } {
		set odbt [$oc get -get_both \
		    [lindex [lindex $ndbt 0] 0] [lindex [lindex $ndbt 0] 1]]
		if { [ catch { error_check_good \
		    db_compare_back($oldfile:$dbname) $odbt $ndbt } res ] != 0 } {
			puts $res
			set ret 1
		}
	}

	error_check_good orig_cursor_close($oldfile:$dbname) [$oc close] 0
	error_check_good new_cursor_close($newfile:$dbname) [$nc close] 0

	error_check_good orig_db_close($$oldfile:$dbname) [$olddb close] 0
	error_check_good new_db_close($newfile:$dbname) [$newdb close] 0

	return $ret
}

proc readFile { filename } {
	set fd [open $filename r]
	fconfigure $fd -encoding binary
	set data [read $fd]
	close $fd
	return $data
}

proc readFileUTF8 { filename } {
	set fd [open $filename r]
	fconfigure $fd -encoding utf-8
	set data [read $fd]
	close $fd
	return $data
}

proc putFileInContainer { container filename {txn "NULL"}} {
	if { [catch {
		new XmlDocument xd
		$xd setContent [readFile $filename]
		$xd setName $filename
		$container putDocument $txn $xd
		set id [$xd getID]
		delete xd
	}] != 0 } {
		set id 0
	}
	return $id
}

proc getDocumentContent { container txn id } {
	if { [catch {
		wrap XmlDocument xd [$container getDocument $txn $id]
		set data [$xd getContentAsString]
		delete xd
	} ret] != 0 } {
		puts "exception: xmlutils.tcl getDocumentContent: $ret"
		set data ""
	}
	return $data
}

proc enableDebugLog {} {
	source ./include.tcl
	setLogLevel $LEVEL_DEBUG 1
	setLogCategory $CATEGORY_INDEXER 1
	setLogCategory $CATEGORY_QUERY 1
	setLogCategory $CATEGORY_OPTIMIZER 0
	setLogCategory $CATEGORY_DICTIONARY 1
	setLogCategory $CATEGORY_CONTAINER 1
}

proc disableDebugLog {} {
	source ./include.tcl
#	setLogLevel $LEVEL_DEBUG 0
	setLogCategory $CATEGORY_INDEXER 0
	setLogCategory $CATEGORY_QUERY 0
	setLogCategory $CATEGORY_OPTIMIZER 0
	setLogCategory $CATEGORY_DICTIONARY 0
	setLogCategory $CATEGORY_CONTAINER 0
}

#
# 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 "{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".
    #
    # 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
    if {$obj == "NULL"} {
        error "Attempt to wrap NULL object"
    }
    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 "{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
}

proc delete {handle_r} {
    #
    # A synonym for unset that is more familiar to C++ programmers
    #
    uplevel unset $handle_r
}

proc dbxml_error_check_bad { func result bad {txn 0}} {
	error_check_bad $func $result $bad $txn
#	if { [binary_compare $result $bad] == 0 } {
#		if { $txn != 0 } {
#			$txn abort
#		}
#		flush stdout
#		flush stderr
#		puts "FAIL:[timestamp] $func returned error value $bad"
#		return 1
#	}
#	return 0
}

proc dbxml_error_check_good { func result desired {txn 0} } {
	error_check_good $func $result $desired $txn
#	if { [binary_compare $desired $result] != 0 } {
#		if { $txn != 0 } {
#			$txn abort
#		}
#		flush stdout
#		flush stderr
#		puts "FAIL:[timestamp]\
#		    $func: expected $desired, got $result"
#		return 1
#	}
#	return 0
}

proc set_openargs { args } {
	source ./include.tcl

	# Default to use of DB_CREATE flag.  
	set openargs $DB_CREATE

	# Turn on threads.
	#  
	# Tcl interface is NOT safe for multi-threading!
	# This is just for testing the API. 
	#
	if { [lsearch -exact $args thread] >= 0 } {
		set openargs [expr $openargs + $DB_THREAD]
	}
	
	return $openargs
}

proc start_txn { env } {
	set txn [$env txn]
	dbxml_error_check_good start_txn [is_valid_txn $txn $env] TRUE
	
	return $txn
}

proc commit_txn { txn } {
	dbxml_error_check_good txn_commit [$txn commit] 0
}
