testutils.tcl

这是linux下运行的mysql软件包,可用于linux 下安装 php + mysql + apach 的网络配置

		return 1
	} else {
		return 0
	}
}

proc convert_method { method } {
	switch -- $method {
		-btree -
		-dbtree -
		dbtree -
		-ddbtree -
		ddbtree -
		-rbtree -
		BTREE -
		DB_BTREE -
		DB_RBTREE -
		RBTREE -
		bt -
		btree -
		db_btree -
		db_rbtree -
		rbt -
		rbtree { return "-btree" }

		-dhash -
		-ddhash -
		-hash -
		DB_HASH -
		HASH -
		dhash -
		ddhash -
		db_hash -
		h -
		hash { return "-hash" }

		-queue -
		DB_QUEUE -
		QUEUE -
		db_queue -
		q -
		qam -
		queue { return "-queue" }

		-queueextent -
		QUEUEEXTENT -
		qe -
		qamext -
		-queueext -
		queueextent -
		queueext { return "-queue" }

		-frecno -
		-recno -
		-rrecno -
		DB_FRECNO -
		DB_RECNO -
		DB_RRECNO -
		FRECNO -
		RECNO -
		RRECNO -
		db_frecno -
		db_recno -
		db_rrecno -
		frec -
		frecno -
		rec -
		recno -
		rrec -
		rrecno { return "-recno" }

		default { error "FAIL:[timestamp] $method: unknown method" }
	}
}

proc split_encargs { largs encargsp } {
	global encrypt
	upvar $encargsp e
	set eindex [lsearch $largs "-encrypta*"]
	if { $eindex == -1 } {
		set e ""
		set newl $largs
	} else {
		set eend [expr $eindex + 1]
		set e [lrange $largs $eindex $eend]
		set newl [lreplace $largs $eindex $eend "-encrypt"]
	}
	return $newl
}

proc convert_encrypt { largs } {
	global encrypt
	global old_encrypt

	set old_encrypt $encrypt
	set encrypt 0
	if { [lsearch $largs "-encrypt*"] != -1 } {
		set encrypt 1
	}
}

# If recno-with-renumbering or btree-with-renumbering is specified, then
# fix the arguments to specify the DB_RENUMBER/DB_RECNUM option for the
# -flags argument.
proc convert_args { method {largs ""} } {
	global fixed_len
	global fixed_pad
	global gen_upgrade
	global upgrade_be
	source ./include.tcl

	if { [string first - $largs] == -1 &&\
	    [string compare $largs ""] != 0 &&\
	    [string compare $largs {{}}] != 0 } {
		set errstring "args must contain a hyphen; does this test\
		    have no numeric args?"
		puts "FAIL:[timestamp] $errstring (largs was $largs)"
		return -code return
	}

	convert_encrypt $largs
	if { $gen_upgrade == 1 && $upgrade_be == 1 } {
		append largs " -lorder 4321 "
	} elseif { $gen_upgrade == 1 && $upgrade_be != 1 } {
		append largs " -lorder 1234 "
	}

	if { [is_rrecno $method] == 1 } {
		append largs " -renumber "
	} elseif { [is_rbtree $method] == 1 } {
		append largs " -recnum "
	} elseif { [is_dbtree $method] == 1 } {
		append largs " -dup "
	} elseif { [is_ddbtree $method] == 1 } {
		append largs " -dup "
		append largs " -dupsort "
	} elseif { [is_dhash $method] == 1 } {
		append largs " -dup "
	} elseif { [is_ddhash $method] == 1 } {
		append largs " -dup "
		append largs " -dupsort "
	} elseif { [is_queueext $method] == 1 } {
		append largs " -extent 2 "
	}

	if {[is_fixed_length $method] == 1} {
		append largs " -len $fixed_len -pad $fixed_pad "
	}
	return $largs
}

proc is_btree { method } {
	set names { -btree BTREE DB_BTREE bt btree }
	if { [lsearch $names $method] >= 0 } {
		return 1
	} else {
		return 0
	}
}

proc is_dbtree { method } {
	set names { -dbtree dbtree }
	if { [lsearch $names $method] >= 0 } {
		return 1
	} else {
		return 0
	}
}

proc is_ddbtree { method } {
	set names { -ddbtree ddbtree }
	if { [lsearch $names $method] >= 0 } {
		return 1
	} else {
		return 0
	}
}

proc is_rbtree { method } {
	set names { -rbtree rbtree RBTREE db_rbtree DB_RBTREE rbt }
	if { [lsearch $names $method] >= 0 } {
		return 1
	} else {
		return 0
	}
}

proc is_recno { method } {
	set names { -recno DB_RECNO RECNO db_recno rec recno}
	if { [lsearch $names $method] >= 0 } {
		return 1
	} else {
		return 0
	}
}

proc is_rrecno { method } {
	set names { -rrecno rrecno RRECNO db_rrecno DB_RRECNO rrec }
	if { [lsearch $names $method] >= 0 } {
		return 1
	} else {
		return 0
	}
}

proc is_frecno { method } {
	set names { -frecno frecno frec FRECNO db_frecno DB_FRECNO}
	if { [lsearch $names $method] >= 0 } {
		return 1
	} else {
		return 0
	}
}

proc is_hash { method } {
	set names { -hash DB_HASH HASH db_hash h hash }
	if { [lsearch $names $method] >= 0 } {
		return 1
	} else {
		return 0
	}
}

proc is_dhash { method } {
	set names { -dhash dhash }
	if { [lsearch $names $method] >= 0 } {
		return 1
	} else {
		return 0
	}
}

proc is_ddhash { method } {
	set names { -ddhash ddhash }
	if { [lsearch $names $method] >= 0 } {
		return 1
	} else {
		return 0
	}
}

proc is_queue { method } {
	if { [is_queueext $method] == 1 } {
		return 1
	}

	set names { -queue DB_QUEUE QUEUE db_queue q queue qam }
	if { [lsearch $names $method] >= 0 } {
		return 1
	} else {
		return 0
	}
}

proc is_queueext { method } {
	set names { -queueextent queueextent QUEUEEXTENT qe qamext \
	    queueext -queueext }
	if { [lsearch $names $method] >= 0 } {
		return 1
	} else {
		return 0
	}
}

proc is_record_based { method } {
	if { [is_recno $method] || [is_frecno $method] ||
	    [is_rrecno $method] || [is_queue $method] } {
		return 1
	} else {
		return 0
	}
}

proc is_fixed_length { method } {
	if { [is_queue $method] || [is_frecno $method] } {
		return 1
	} else {
		return 0
	}
}

# Sort lines in file $in and write results to file $out.
# This is a more portable alternative to execing the sort command,
# which has assorted issues on NT [#1576].
# The addition of a "-n" argument will sort numerically.
proc filesort { in out { arg "" } } {
	set i [open $in r]

	set ilines {}
	while { [gets $i line] >= 0 } {
		lappend ilines $line
	}

	if { [string compare $arg "-n"] == 0 } {
		set olines [lsort -integer $ilines]
	} else {
		set olines [lsort $ilines]
	}

	close $i

	set o [open $out w]
	foreach line $olines {
		puts $o $line
	}

	close $o
}

# Print lines up to the nth line of infile out to outfile, inclusive.
# The optional beg argument tells us where to start.
proc filehead { n infile outfile { beg 0 } } {
	set in [open $infile r]
	set out [open $outfile w]

	# Sed uses 1-based line numbers, and so we do too.
	for { set i 1 } { $i < $beg } { incr i } {
		if { [gets $in junk] < 0 } {
			break
		}
	}

	for { } { $i <= $n } { incr i } {
		if { [gets $in line] < 0 } {
			break
		}
		puts $out $line
	}

	close $in
	close $out
}

# Remove file (this replaces $RM).
# Usage: fileremove filenames =~ rm;  fileremove -f filenames =~ rm -rf.
proc fileremove { args } {
	set forceflag ""
	foreach a $args {
		if { [string first - $a] == 0 } {
			# It's a flag.  Better be f.
			if { [string first f $a] != 1 } {
				return -code error "bad flag to fileremove"
			} else {
				set forceflag "-force"
			}
		} else {
			eval {file delete $forceflag $a}
		}
	}
}

proc findfail { args } {
	foreach a $args {
		if { [file exists $a] == 0 } {
			continue
		}
		set f [open $a r]
		while { [gets $f line] >= 0 } {
			if { [string first FAIL $line] == 0 } {
				close $f
				return 1
			}
		}
		close $f
	}
	return 0
}

# Sleep for s seconds.
proc tclsleep { s } {
	# On Windows, the system time-of-day clock may update as much
	# as 55 ms late due to interrupt timing.  Don't take any
	# chances;  sleep extra-long so that when tclsleep 1 returns,
	# it's guaranteed to be a new second.
	after [expr $s * 1000 + 56]
}

# Kill a process.
proc tclkill { id } {
	source ./include.tcl

	while { [ catch {exec $KILL -0 $id} ] == 0 } {
		catch {exec $KILL -9 $id}
		tclsleep 5
	}
}

# Compare two files, a la diff.  Returns 1 if non-identical, 0 if identical.
proc filecmp { file_a file_b } {
	set fda [open $file_a r]
	set fdb [open $file_b r]

	set nra 0
	set nrb 0

	# The gets can't be in the while condition because we'll
	# get short-circuit evaluated.
	while { $nra >= 0 && $nrb >= 0 } {
		set nra [gets $fda aline]
		set nrb [gets $fdb bline]

		if { $nra != $nrb || [string compare $aline $bline] != 0} {
			close $fda
			close $fdb
			return 1
		}
	}

	close $fda
	close $fdb
	return 0
}

# Give two SORTED files, one of which is a complete superset of the other,
# extract out the unique portions of the superset and put them in
# the given outfile.
proc fileextract { superset subset outfile } {
	set sup [open $superset r]
	set sub [open $subset r]
	set outf [open $outfile w]

	# The gets can't be in the while condition because we'll
	# get short-circuit evaluated.
	set nrp [gets $sup pline]
	set nrb [gets $sub bline]
	while { $nrp >= 0 } {
		if { $nrp != $nrb || [string compare $pline $bline] != 0} {
			puts $outf $pline
		} else {
			set nrb [gets $sub bline]
		}
		set nrp [gets $sup pline]
	}

	close $sup
	close $sub
	close $outf
	return 0
}

# Verify all .db files in the specified directory.
proc 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 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/*.db} dbs] != 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 -create -private} $encarg \
	    {-cachesize [list 0 $cachesize 0]}]
	set earg " -env $env $errarg "

	foreach db $dbs {
		if { [catch {eval {berkdb dbverify} $earg $db} res] != 0 } {
			puts $res
			puts "FAIL:[timestamp] Verification of $db failed."
			set ret 1
			continue
		} else {
			error_check_good verify:$db $res 0
			if { $quiet == 0 } {
				puts "${pref}Verification of $db succeeded."
			}
		}

		# Skip the dump if it's dangerous to do it.
		if { $nodump == 0 } {
			if { [catch {eval dumploadtest $db} res] != 0 } {
				puts $res
				puts "FAIL:[timestamp] Dump/load of $db failed."
				set ret 1
				continue
			} else {
				error_check_good dumpload:$db $res 0
				if { $quiet == 0 } {
					puts \
					    "${pref}Dump/load of $db succeeded."
				}
			}
		}
	}

	error_check_good vrfyenv_close [$env close] 0

	return $ret
}

# Is the database handle in $db a master database containing subdbs?
proc check_for_subdbs { db } {
	set stat [$db stat]
	for { set i 0 } { [string length [lindex $stat $i]] > 0 } { incr i } {
		set elem [lindex $stat $i]
		if { [string compare [lindex $elem 0] Flags] == 0 } {
			# This is the list of flags;  look for
			# "subdatabases".
			if { [is_substr [lindex $elem 1] subdatabases] } {
				return 1
			}
		}
	}
	return 0
}

proc dumploadtest { db {subdb ""} } {
	global util_path
	global encrypt
	global passwd

	set newdbname $db-dumpload.db

	# Open original database, or subdb