# Commands covered:  trace
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: trace.test,v 1.28.2.8 2005/11/03 17:52:27 dgp Exp $
# RCS: @(#) $Id: trace.test,v 1.28.2.9 2005/12/02 18:42:53 dgp Exp $

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

testConstraint testcmdtrace [llength [info commands testcmdtrace]]

# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]

proc getbytes {} {
    set lines [split [memory info] "\n"]
    lindex [lindex $lines 3] 3
}

proc traceScalar {name1 name2 op} {
    global info
    set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg]
}
proc traceScalarAppend {name1 name2 op} {
    global info

} {0 xyzzy}
test trace-12.8 {errors when setting variable traces} {
    catch {unset x}
    set x 44
    list [catch {trace add variable x(0) write traceProc} msg] $msg
} {1 {can't trace "x(0)": variable isn't array}}

# Check deleting one trace from another.
# Check trace deletion

test trace-13.1 {delete one trace from another} {
    proc delTraces {args} {
	global x
	trace remove variable x read {traceTag 2}
	trace remove variable x read {traceTag 3}
	trace remove variable x read {traceTag 4}
    }
    catch {unset x}
    set x 44
    set info {}
    trace add variable x read {traceTag 1}
    trace add variable x read {traceTag 2}
    trace add variable x read {traceTag 3}
    trace add variable x read {traceTag 4}
    trace add variable x read delTraces 
    trace add variable x read {traceTag 5}
    set x
    set info
} {5 1}

test trace-13.2 {leak when unsetting traced variable} \
    -constraints memory -body {
	set end [getbytes]
	proc f args {}
	for {set i 0} {$i < 5} {incr i} {
	    trace add variable bepa write f
	    set bepa a
	    unset bepa
	    set tmp $end
	    set end [getbytes]
	}
	expr {$end - $tmp}
    } -cleanup {
	unset -nocomplain end i tmp
    } -result 0
test trace-13.3 {leak when removing traces} \
    -constraints memory -body {
	set end [getbytes]
	proc f args {}
	for {set i 0} {$i < 5} {incr i} {
	    trace add variable bepa write f
	    set bepa a
	    trace remove variable bepa write f
	    set tmp $end
	    set end [getbytes]
	}
	expr {$end - $tmp}
    } -cleanup {
	unset -nocomplain end i tmp
    } -result 0
test trace-13.4 {leaks in error returns from traces} \
    -constraints memory -body {
	set end [getbytes]
	for {set i 0} {$i < 5} {incr i} {
	    set apa {a 1 b 2}
	    set bepa [lrange $apa 0 end]
	    trace add variable bepa write {error hej}
	    catch {set bepa a}
	    unset bepa
	    set tmp $end
	    set end [getbytes]
	}
	expr {$end - $tmp}
    } -cleanup {
	unset -nocomplain end i tmp
    } -result 0

# Check operation and syntax of "trace" command.

# Syntax for adding/removing variable and command traces is basically the
# same:
#	trace add variable name opList command
#	trace remove variable name opList command

	global info
	append info [catch {set ::$vtraced}][llength [info vars ::ref::*]]
    }
    set info {}
    namespace delete ::ref
    rename doTrace {}
    set info
} 1010
} 1110

# Delete arrays when done, so they can be re-used as scalars
# elsewhere.

catch {unset x}
catch {unset y}

    catch {rename someothername {}}
    trace add command foo delete [list traceCmdrename foo]
    rename foo bar
    rename bar {}
    # None of these should exist.
    list [info commands foo] [info commands bar] [info commands someothername]
} {{} {} {}}

test trace-20.13 {rename trace discards result [Bug 1355342]} {
    proc foo {} {}
    trace add command foo rename {set w Aha!;#}
    list [rename foo bar] [rename bar {}]
} {{} {}}
test trace-20.14 {rename trace discards error result [Bug 1355342]} {
    proc foo {} {}
    trace add command foo rename {error}
    list [rename foo bar] [rename bar {}]
} {{} {}}
test trace-20.15 {delete trace discards result [Bug 1355342]} {
    proc foo {} {}
    trace add command foo delete {set w Aha!;#}
    rename foo {}
} {}
test trace-20.16 {delete trace discards error result [Bug 1355342]} {
    proc foo {} {}
    trace add command foo delete {error}
    rename foo {}
} {}


proc foo {b} { set a $b }


# Delete arrays when done, so they can be re-used as scalars
# elsewhere.

    proc foo {} {set x {}}
    proc bar args {trace remove execution foo enterstep soom}
    trace add execution foo enterstep soom
    trace add execution foo enterstep bar
    foo
} {}

# We test here for the half-documented and currently valid interplay between
# delete traces and namespace deletion.
test trace-34.4 {Bug 1047286} {
    variable x notrace
    proc callback {old - -} {
        variable x "$old exists: [namespace which -command $old]"
    }
    namespace eval ::foo {proc bar {} {}}
    trace add command ::foo::bar delete [namespace code callback]
    namespace delete ::foo
    set x
} {::foo::bar exists: ::foo::bar}

test trace-34.5 {Bug 1047286} {
    variable x notrace
    proc callback {old - -} {
        variable x "$old exists: [namespace which -command $old]"
    }
    namespace eval ::foo {proc bar {} {}}
    trace add command ::foo::bar delete [namespace code callback]
    namespace eval ::foo namespace delete ::foo
    set x
} {::foo::bar exists: }

test trace-35.1 {527164: Keep -errorinfo of traces} -setup {
    unset -nocomplain x y
} -body {
    trace add variable x write {error foo;#}
    trace add variable y write {set x 2;#}
    list [catch {set y 1} msg opts] $msg [dict get $opts -errorinfo]