Tcl Source Code

Artifact [5d3657d540]
Login
☰Core Home Timeline Branches Tags Tickets Download Wiki
Download Hex

Artifact 5d3657d540da643bf786ea6500a769fae4987603:

Attachment "file.bench" to ticket [871583ffff] added by vincentdarley 2004-01-22 17:53:47. 
# file.bench --
#

# setup routines
proc contents {file str} {
    set fp [open $file w]
    puts $fp $str
    close $fp
}

proc setup {dir size {subdirsize 1}} {
    for {set i 0} {$i < $size} {incr i} {
	file mkdir [file join $dir _benchdir.$i]
	for {set j 0} {$j < $subdirsize} {incr j} {
	    contents [file join $dir _benchdir.$i _benchfile.$j] "delete me"
	}
	contents [file join $dir _benchfile.$i] "delete me"
    }
}

set file [bench_tmpfile]
set dir  $file.DIR
file mkdir $dir
setup $dir 30 30

# test procs

if {$tcl_version >= 8.3} {
    proc listfiles {dir ptn} { glob -nocomplain -directory $dir $ptn }
    proc listdeepfiles {dir ptn} { 
	glob -nocomplain -directory $dir -join * $ptn 
    }
    proc listdirectories {dir ptn} { 
	glob -nocomplain -directory $dir -types d $ptn
    }
} else {
    proc listfiles {dir ptn} { glob -nocomplain $dir/$ptn }
    proc listdeepfiles {dir ptn} {  
	glob -nocomplain $dir/*/$ptn
    }
    proc listdirectories {dir ptn} {  
	glob -nocomplain $dir/${ptn}/
    }
}

proc listfiles2 {dir ptn} { 
    set old [pwd]
    cd $dir
    set res [glob -nocomplain $ptn]
    cd $old
    return $res
}

proc checkone {dir cmd} {
    foreach f [listfiles $dir *] { file $cmd $f }
}
proc checkstat {dir} {
    foreach f [listfiles $dir *] { file stat $f var }
}
proc checkall {dir} {
    foreach f [listfiles $dir *] {
	foreach fcmd {
	    atime attributes dirname executable exists extension
	    isdirectory isfile mtime owned readable rootname size
	    tail writable
	} { file $fcmd $f }
	file stat $f var
    }
}

# Uses 'glob -dir' where possible, and otherwise 'glob */*'
proc recurseAndExamine1 {dir recurse examine} {
    foreach f [listfiles $dir *] {
	if {$examine} {
	    file stat $f arr
	}
	if {$recurse && [file isdirectory $f]} {
	    recurseAndExamine1 $f $recurse $examine
	}
    }
}

# Uses 'cd' and relative paths throughout
proc recurseAndExamine2 {dir recurse examine} {
    set orig [pwd]
    cd $dir
    foreach f [glob -nocomplain *] {
	if {$examine} {
	    file stat $f arr
	}
	if {$recurse && [file isdirectory $f]} {
	    recurseAndExamine2 $f $recurse $examine
	}
    }
    cd $orig
}

set fileBogusAsObj $file.BOGUS]
set relativeFileObj bogusFile
if {[info tclversion] < 8.4} {
    set absoluteFileObj [file join [pwd] bogusFile]
} else {
    set absoluteFileObj [file normalize bogusFile]
}

bench -desc "FILE exists ~" -iter 1000 \
	-body {file exists ~}
bench -desc "FILE exists tmpfile (obj)" -iter 10000 \
	-body {file exists $file}
bench -desc "FILE exists! tmpfile (str)" -iter 10000 \
	-body {file exists $file.BOGIE}
bench -desc "FILE exists! tmpfile (obj)" -iter 10000 \
	-body {file exists $fileBogusAsObj}
bench -desc "FILE exists! relative tmpfile (str)" -iter 10000 \
        -body {file exists $relativeFileObj.BOGIE}
bench -desc "FILE exists! relative tmpfile (obj)" -iter 10000 \
        -body {file exists $relativeFileObj}
bench -desc "FILE exists! absolute tmpfile (str)" -iter 10000 \
	-body {file exists $absoluteFileObj.BOGIE}
bench -desc "FILE exists! absolute tmpfile (obj)" -iter 10000 \
	-body {file exists $absoluteFileObj}

bench -desc "FILE dirname absolute tmpfile (obj)" -iter 10000 \
	-body {file dirname $absoluteFileObj}
bench -desc "FILE dirname absolute tmpfile (str)" -iter 10000 \
	-body {file dirname $absoluteFileObj.BOGIE}
bench -desc "FILE dirname relative tmpfile (obj)" -iter 10000 \
	-body {file dirname $file}
bench -desc "FILE dirname relative tmpfile (str)" -iter 10000 \
	-body {file dirname $file.BOGIE}
bench -desc "FILE tail absolute tmpfile (obj)" -iter 10000 \
	-body {file tail $absoluteFileObj}
bench -desc "FILE tail absolute tmpfile (str)" -iter 10000 \
	-body {file tail $absoluteFileObj.BOGIE}
bench -desc "FILE tail relative tmpfile (obj)" -iter 10000 \
	-body {file tail $file}
bench -desc "FILE tail relative tmpfile (str)" -iter 10000 \
	-body {file tail $file.BOGIE}
bench -desc "FILE tail ~" -iter 1000 \
	-body {file tail ~}
bench -desc "FILE dirname ~" -iter 1000 \
	-body {file dirname ~}

set num [llength [listfiles $dir */]]
bench -desc "FILE glob  tmpdir ($num entries) / -dir" -iter 100 \
	-body {listfiles $dir *}
bench -desc "FILE glob  tmpdir ($num entries) / cd" -iter 100 \
        -body {listfiles2 $dir *}
bench -desc "FILE glob  tmpdir (subset of $num entries)" -iter 100 \
        -body {listfiles $dir *.1*}

set num [llength [listdirectories $dir */]]
bench -desc "FILE glob dirs ($num entries)" -iter 100 \
	-body {listdirectories $dir *}
bench -desc "FILE glob deep dirs ($num entries+)" -iter 100 \
	-body {listdeepfiles $dir *}
bench -desc "FILE glob deep dirs (subset of $num entries+)" -iter 100 \
        -body {listdeepfiles $dir *.1*}

foreach fcmd {
    atime attributes dirname executable exists extension isdirectory
    isfile mtime owned readable rootname size tail writable
} {
    bench -desc "FILE glob / $fcmd" -iter 100 \
	    -body {checkone $dir $fcmd}
}

bench -desc "FILE glob / all subcommands" -iter 100 \
	-body {checkall $dir}

bench -desc "FILE recurse / -dir" -iter 100 \
  -body {recurseAndExamine1 $dir 1 0}

bench -desc "FILE recurse / cd" -iter 100 \
  -body {recurseAndExamine2 $dir 1 0}

bench -desc "FILE recurse+stat / -dir" -iter 100 \
  -body {recurseAndExamine1 $dir 1 1}

bench -desc "FILE recurse+stat / cd" -iter 100 \
  -body {recurseAndExamine2 $dir 1 1}

contents $file "exit"

bench -desc "FILE exec interp" -iter 100 \
	-body {exec $BENCH(INTERP) $file}

contents $file "catch {package require bogus-name}; package names; exit"

bench -desc "FILE exec interp: pkg require" -iter 100 \
	-body {exec $BENCH(INTERP) $file}

# Make a dummy pkgIndex to test speed of pkg require when the
# auto_path is changed on the fly
contents [file join $dir pkgIndex.tcl]  {
    if {[lsearch -exact $::auto_path $dir] == -1} {
       lappend ::auto_path $dir
    }
}

contents $file {lappend ::auto_path [file dirname [info script]] ;\
  catch {package require bogus-name}; package names; exit}

bench -desc "FILE exec interp: pkg require+" -iter 30 \
  -body {exec $BENCH(INTERP) $file}

contents $file {
    lappend ::auto_path [info library] [info library] [info library]
    lappend ::auto_path [info library] [info library] [info library]
    catch {package require bogus-name}; package names; exit
}

bench -desc "FILE exec interp: pkg require+auto_path" -iter 30 \
  -body {exec $BENCH(INTERP) $file}

contents $file {
    exit
}

bench -desc "FILE exec interp: exit" -iter 100 \
  -body {exec $BENCH(INTERP) $file}

proc setuppkg {dir size {subdirsize 1}} {
    for {set i 0} {$i < $size} {incr i} {
	file mkdir [file join $dir _benchpkgdir.$i]
	for {set j 0} {$j < $subdirsize} {incr j} {
	    contents [file join $dir _benchpkgdir.$i pkgIndex.tcl] \
	      [list package ifneeded pkg$i$j $i$j [list package provide pkg$i$j $i$j]]
	}
	contents [file join $dir _benchpkgfile.$i] "delete me"
    }
}

setuppkg $dir 30 1

set old_auto $::auto_path

proc pkgtestprepare {} {
    catch {package require foo}
    foreach p [package names] {
	if {$p != "Tcl"} {
	    package forget $p
	}
    }
    set ::auto_path {}
    lappend ::auto_path $::dir
}

bench -desc "FILE standard directory 'package require'" -iter 30 \
  -pre pkgtestprepare -body {catch {package require bogus-name; package names}}

set ::auto_path $old_auto
unset old_auto

bench_rm pkgIndex.tcl

bench_rm $file
file delete -force $dir
This page was generated in about 0.008s by Fossil 2.25 [2ba99c273b] 2024-05-21 11:18:46