# Profiler tests.                                              -*- tcl -*-
#
# Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# All rights reserved.
#
# RCS: @(#) $Id: profiler.test,v 1.13 2003/05/02 19:27:36 andreas_kupries Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import ::tcltest::*
}

# This constraint restricts certain tests to run on tcl8.3 version only
if {[package vsatisfies [package provide tcltest] 2.0]} {
    # tcltest2.0+ has an API to specify a test constraint
    ::tcltest::testConstraint tcl8.3only \
        [expr {![package vsatisfies [package provide Tcl] 8.4]}]
} else {
    # In tcltest1.0, a global variable needs to be set directly.
    set ::tcltest::testConstraints(tcl8.3only) \
        [expr {![package vsatisfies [package provide Tcl] 8.4]}]
}

# -------------------------------------------------------------------------
# Ensure we test _this_ local copy and one installed somewhere else.
#
package forget profiler
catch {namespace delete ::profiler}
if {[catch {source [file join [file dirname [info script]] profiler.tcl]} msg]} {
    puts "skipped [file tail [info script]]: $msg"
    return
}

# Set the auto_path for the child interps.
set auto_path [concat [file dirname [info script]] $auto_path]

puts "- profiler [package provide profiler]"

# -------------------------------------------------------------------------

test profiler-1.0 {profiler::init redirects the proc command} {
    set c [interp create]
    interp alias $c parentSet {} set
    set result [$c eval {
	set auto_path [parentSet auto_path]
	package require profiler
	profiler::init
	list [interp alias {} proc] [info commands ::_oldProc]
    }]
    interp delete $c
    set result
} [list ::profiler::profProc ::_oldProc]

test profiler-2.0 {profiler creates two wrapper proc and real proc} {tcl8.3only} {
    set c [interp create]
    interp alias $c parentSet {} set
    set result [$c eval {
	set auto_path [parentSet auto_path]
	package require profiler
	profiler::init
	proc foo {} {
	    puts "foo!"
	}
	list [info commands foo] [info commands fooORIG]
    }]
    interp delete $c
    set result
} [list foo fooORIG]
test profiler-2.1 {profiler creates procs in correct scope} {tcl8.3only} {
    set c [interp create]
    interp alias $c parentSet {} set
    set result [$c eval {
	set auto_path [parentSet auto_path]
	package require profiler
	profiler::init
	namespace eval foo {}
	proc ::foo::foo {} {
	    puts "foo!"
	}
	list [info commands ::foo::foo] [info commands ::foo::fooORIG]
    }]
    interp delete $c
    set result
} [list ::foo::foo ::foo::fooORIG]
test profiler-2.2 {profiler creates procs in correct scope} {tcl8.3only} {
    set c [interp create]
    interp alias $c parentSet {} set
    set result [$c eval {
	set auto_path [parentSet auto_path]
	package require profiler
	profiler::init
	namespace eval foo {
	    proc foo {} {
		puts "foo!"
	    }
	}
	list [info commands ::foo::foo] [info commands ::foo::fooORIG]
    }]
    interp delete $c
    set result
} [list ::foo::foo ::foo::fooORIG]
test profiler-2.3 {profiler creates procs in correct scope} {tcl8.3only} {
    set c [interp create]
    interp alias $c parentSet {} set
    set result [$c eval {
	set auto_path [parentSet auto_path]
	package require profiler
	profiler::init
	namespace eval foo {
	    namespace eval bar {}
	    proc bar::foo {} {
		puts "foo!"
	    }
	}
	list [info commands ::foo::bar::foo] \
		[info commands ::foo::bar::fooORIG]
    }]
    interp delete $c
    set result
} [list ::foo::bar::foo ::foo::bar::fooORIG]
test profiler-2.4 {profiler creates procs in correct scope} {tcl8.3only} {
    set c [interp create]
    interp alias $c parentSet {} set
    set result [$c eval {
	set auto_path [parentSet auto_path]
	package require profiler
	profiler::init
	namespace eval foo {
	    proc ::foo {} {
		puts "foo!"
	    }
	}
	list [info commands ::foo] \
		[info commands ::fooORIG]
    }]
    interp delete $c
    set result
} [list ::foo ::fooORIG]

test profiler-3.1 {profiler wrappers do profiling} {
    set c [interp create]
    interp alias $c parentSet {} set
    set result [$c eval {
	set auto_path [parentSet auto_path]
	package require profiler
	profiler::init
	proc ::foo {} {
	    set foobar 0
	}
	foo
	foo
	foo
	foo
	profiler::dump ::foo
    }]
    interp delete $c
    array set bar $result
    array set foo $bar(::foo)
    list callCount $foo(callCount) callerDist $foo(callerDist)
} [list callCount 4 callerDist [list GLOBAL 4]]

test profiler-4.1 {profiler::print produces nicer output than dump} {
    set c [interp create]
    interp alias $c parentSet {} set
    set result [$c eval {
	set auto_path [parentSet auto_path]
	package require profiler
	profiler::init
	proc ::foo {} {
	    set foobar 0
	}
	foo
	foo
	foo
	foo
	profiler::print ::foo
    }]
    interp delete $c
    regsub {Compile time:.*} $result {} result
    string trim $result
} "Profiling information for ::foo
============================================================
            Total calls:  4
    Caller distribution:
  GLOBAL:  4"

test profiler-5.1 {profiler respects suspend/resume} {
    set c [interp create]
    interp alias $c parentSet {} set
    set result [$c eval {
	set auto_path [parentSet auto_path]
	package require profiler
	profiler::init
	proc ::foo {} {
	    set foobar 0
	}
	foo
	foo
	foo
	foo
	profiler::suspend ::foo ; # note the qualification, has to match proc!
	foo
	foo
	set res [profiler::print ::foo]
	profiler::resume
	set res
    }]
    interp delete $c
    regsub {Compile time:.*} $result {} result
    string trim $result
} "Profiling information for ::foo
============================================================
            Total calls:  4
    Caller distribution:
  GLOBAL:  4"

test profiler-6.1 {profiler handles functions with funny names} {
    set c [interp create]
    interp alias $c parentSet {} set
    set result [$c eval {
	set     auto_path [parentSet auto_path]
	lappend auto_path [file dirname [file dirname [info script]]]
	package require profiler
	profiler::init
	proc ::foo(bar) {} {
	    set foobar 0
	}
	foo(bar); foo(bar); foo(bar)
	profiler::dump ::foo(bar)
    }]
    interp delete $c
    array set bar $result
    array set foo ${bar(::foo(bar))}
    list callCount $foo(callCount) callerDist $foo(callerDist)
} [list callCount 3 callerDist [list GLOBAL 3]]

test profiler-7.1 {sortFunctions} {
    set c [interp create]
    interp alias $c parentSet {} set
    set result [$c eval {
	set auto_path [parentSet auto_path]
	package require profiler
	profiler::init
	catch {profiler::sortFunctions} res
	set res
    }]
    interp delete $c
    set result
} "unknown statistic \"\": should be calls, compileTime, exclusiveRuntime,\
nonCompileTime, totalRuntime, avgExclusiveRuntime, or avgRuntime"
test profiler-7.2 {sortFunctions} {
    set c [interp create]
    interp alias $c parentSet {} set
    set result [$c eval {
	set auto_path [parentSet auto_path]
	package require profiler
	profiler::init
	proc ::foo {} {
	    set foobar 0
	}
	proc ::bar {} {
	    set foobar 1
	}
	foo; foo; bar;
	profiler::sortFunctions calls
    }]
    interp delete $c
    set result
} [list [list ::bar 1] [list ::foo 2]]
test profiler-7.3 {sortFunctions} {
    set c [interp create]
    interp alias $c parentSet {} set
    set result [$c eval {
	set auto_path [parentSet auto_path]
	package require profiler
	profiler::init
	proc ::foo {} {
	    set foobar 0
	}
	proc ::bar {} {
	    set foobar 1
	}
	foo; foo; bar;
	catch {profiler::sortFunctions compileTime}
    }]
    interp delete $c
    set result
} 0
test profiler-7.4 {sortFunctions} {
    set c [interp create]
    interp alias $c parentSet {} set
    set result [$c eval {
	set auto_path [parentSet auto_path]
	package require profiler
	profiler::init
	proc ::foo {} {
	    set foobar 0
	}
	proc ::bar {} {
	    set foobar 1
	}
	foo; foo; bar;
	catch {profiler::sortFunctions totalRuntime}
    }]
    interp delete $c
    set result
} 0
test profiler-7.5 {sortFunctions} {
    set c [interp create]
    interp alias $c parentSet {} set
    set result [$c eval {
	set auto_path [parentSet auto_path]
	package require profiler
	profiler::init
	proc ::foo {} {
	    set foobar 0
	}
	proc ::bar {} {
	    set foobar 1
	}
	foo; foo; bar;
	catch {profiler::sortFunctions avgRuntime}
    }]
    interp delete $c
    set result
} 0

test profiler-8.1 {reset} {
    set c [interp create]
    interp alias $c parentSet {} set
    set result [$c eval {
	set auto_path [parentSet auto_path]
	package require profiler
	profiler::init
	proc ::foo {} {
	    set foobar 0
	}
	proc ::bar {} {
	    set foobar 1
	}
	foo; foo; bar;
	profiler::reset
	profiler::dump ::foo
    }]
    interp delete $c
    array set bar $result
    array set foo $bar(::foo)
    list callCount $foo(callCount) callerDist $foo(callerDist)
} [list callCount 0 callerDist [list ]]
test profiler-8.2 {reset with a pattern} {
    set c [interp create]
    interp alias $c parentSet {} set
    set result [$c eval {
	set auto_path [parentSet auto_path]
	package require profiler
	profiler::init
	proc ::foo {} {
	    set foobar 0
	}
	proc ::bar {} {
	    set foobar 1
	}
	foo; foo; bar;
	profiler::reset ::foo
	profiler::dump *
    }]
    interp delete $c
    array set data $result
    catch {unset foo}
    catch {unset bar}
    array set foo $data(::foo)
    array set bar $data(::bar)
    list [list callCount $foo(callCount) callerDist $foo(callerDist)] \
	    [list callCount $bar(callCount) callerDist $bar(callerDist)]
} [list [list callCount 0 callerDist [list ]] \
	[list callCount 1 callerDist [list GLOBAL 1]]]

test profiler-9.1 {dump for multiple functions} {
    set c [interp create]
    interp alias $c parentSet {} set
    set result [$c eval {
	set auto_path [parentSet auto_path]
	package require profiler
	profiler::init
	proc ::foo {} {
	    set foobar 0
	}
	proc ::bar {} {
	    set foobar 1
	}
	foo; foo; bar;
	profiler::dump *
    }]
    interp delete $c
    array set data $result
    catch {unset foo}
    catch {unset bar}
    array set foo $data(::foo)
    array set bar $data(::bar)
    list [list callCount $foo(callCount) callerDist $foo(callerDist)] \
	    [list callCount $bar(callCount) callerDist $bar(callerDist)]
} [list [list callCount 2 callerDist [list GLOBAL 2]] \
	[list callCount 1 callerDist [list GLOBAL 1]]]

catch {unset foo}
catch {unset bar}

::tcltest::cleanupTests