Tcl/Tk Benchmark Suite And Tools
Artifact Content
Not logged in
Bounty program for improvements to Tcl and certain Tcl packages.

Artifact 661f507c717016966042f975f77175f52ad93dde:


# -*- tcl -*-
# Benchmark "fcopy" command
#
# RCS: @(#) $Id: fcopy.bench,v 1.3 2006/11/11 02:33:13 hobbs Exp $
#

# 1. Create a big file to copy

set inFile  [bench_tmpfile]
set outFile [bench_tmpfile]

proc makeFile {file} {
    # 40 chars
    set line "abcdefghijklmnopqrstuvwxyz01234567890123"
    set fid [open $file w]
    # 40 * 4000 = 160K
    for {set i 0} {$i < 4000} {incr i} {
	puts $fid $line
    }
    close $fid
}
makeFile $inFile
set size "[expr {[file size $inFile] / 1024}]K"

# 2. Define the procedures to benchmark. We have to distinguish pre-
#    and post-8.0 versions of the core.
#    Post-7.6 : fcopy
#    7.4 - 7.6: unsupported0
#    Pre-7.4  : _functionality not available_
# ---------------------------------------------------------
set iters 100
if {[info command fcopy] != {}} {

    # Standard fcopy, system encoding, both sides have same encoding.
    proc fcopy-std {} {
	global inFile outFile
	set in  [open $inFile  r]
	set out [open $outFile w]
	fcopy $in $out
	close $in
	close $out
	return
    }

    # Binary copying, both sides have the same encoding
    proc fcopy-binary {} {
	global inFile outFile
	set in  [open $inFile  r]
	set out [open $outFile w]
	fconfigure $in  -encoding binary
	fconfigure $out -encoding binary
	fcopy $in $out
	close $in
	close $out
	return
    }

    # Copying with different encodings set on in- and output.
    # Only 8.4a3+ really respects the encoding in fcopy, which slightly
    # skews the validity of this test across earlier versions.
    proc fcopy-encoding {} {
	global inFile outFile
	set in  [open $inFile  r]
	set out [open $outFile w]
	fconfigure $out -encoding shiftjis
	fcopy $in $out
	close $in
	close $out
	return
    }

    # 3. Run the bench
    # ---------------------------------------------------------

    # We open some dummy channels to hold all the used encodings in memory
    # and to avoid benchmarking how fast they are (un)loaded.

    set tmp1 [bench_tmpfile]
    set tmp2 [bench_tmpfile]
    set d1 [open $tmp1 w]; # no fconfigure, holds system encoding
    set d2 [open $tmp2 w]

    # Interpreter does understand -encoding ...
    # Skip these tests if it doesn't.
    if {![catch {fconfigure $d2 -encoding shiftjis}]} {
	bench -desc "FCOPY binary: $size" -iter $iters -body {fcopy-binary}
	bench -desc "FCOPY encoding: $size" -iter $iters -body {fcopy-encoding}
    }

    bench -desc "FCOPY std: $size" -iter $iters -body {fcopy-std}

    # 4. Cleanup

    catch {close $d1}
    bench_rm $tmp1 $tmp2

} elseif {[info command unsupported0] != {}} {

    # Standard fcopy, system encoding, both sides have same encoding.
    proc fcopy-std {} {
	global inFile outFile
	set in  [open $inFile  r]
	set out [open $outFile w]
	unsupported0 $in $out
	close $in
	close $out
	return
    }

    bench -desc "FCOPY std: $size" -iter $iters -body {fcopy-std}

} else {
   # Functionality not available. Ignore
}

bench_rm $inFile $outFile