# 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.17 2002/03/29 22:47:22 hobbs Exp $

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

proc traceScalar {name1 name2 op} {

    unset x
    array set x {a 1}
    set ::info
} {}
test trace-5.4 {array traces properly listed in trace information} {
    catch {unset x}
    trace add variable x array traceArray2
    set result [trace list variable x]
    set result
} [list [list array traceArray2]]
test trace-5.5 {array traces properly listed in trace information} {
    catch {unset x}
    trace variable x a traceArray2
    set result [trace vinfo x]
    set result

    unset x
    concat $info [list [catch {set x} msg] $msg]
} {0 22 0 22}
test trace-9.3 {be sure traces are cleared before unset trace called} {
    catch {unset x}
    set x 33
    set info {}
    trace add variable x unset {traceCheck {uplevel trace list variable x}}
    unset x
    set info
} {0 {}}
test trace-9.4 {set new trace during unset trace} {
    catch {unset x}
    set x 33
    set info {}
    trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}}
    unset x
    concat $info [trace list variable x]
} {0 {} {unset traceProc}}

test trace-10.1 {make sure array elements are unset before traces are called} {
    catch {unset x}
    set x(0) 33
    set info {}
    trace add variable x(0) unset {traceCheck {uplevel set x(0)}}

    unset x(0)
    concat $info [list [catch {set x(0)} msg] $msg]
} {0 zzz 0 zzz}
test trace-10.3 {array elements are unset before traces are called} {
    catch {unset x}
    set x(0) 33
    set info {}
    trace add variable x(0) unset {traceCheck {global x; trace list variable x(0)}}
    unset x(0)
    set info
} {0 {}}
test trace-10.4 {set new array element trace during unset trace} {
    catch {unset x}
    set x(0) 33
    set info {}
    trace add variable x(0) unset {traceCheck {uplevel {trace add variable x(0) read {}}}}
    catch {unset x(0)}
    concat $info [trace list variable x(0)]
} {0 {} {read {}}}

test trace-11.1 {make sure arrays are unset before traces are called} {
    catch {unset x}
    set x(0) 33
    set info {}
    trace add variable x unset {traceCheck {uplevel set x(0)}}

    unset x
    set info
} {0 0}
test trace-11.4 {make sure arrays are unset before traces are called} {
    catch {unset x}
    set x(y) 33
    set info {}
    set cmd {traceCheck {uplevel {trace list variable x}}}
    trace add variable x unset $cmd
    unset x
    set info
} {0 {}}
test trace-11.5 {set new array trace during unset trace} {
    catch {unset x}
    set x(y) 33
    set info {}
    trace add variable x unset {traceCheck {global x; trace add variable x read {}}}
    unset x
    concat $info [trace list variable x]
} {0 {} {read {}}}
test trace-11.6 {create scalar during array unset trace} {
    catch {unset x}
    set x(y) 33
    set info {}
    trace add variable x unset {traceCheck {global x; set x 44}}
    unset x

	    list [catch {trace $op $type foo bar} msg] $msg
	} [list 1 "$start should be \"trace $op $type name opList command\""]
	test trace-14.0.[incr i] "trace command, wrong # args errors" {
	    list [catch {trace $op $type foo bar baz boo} msg] $msg
	} [list 1 "$start should be \"trace $op $type name opList command\""]
    }
    test trace-14.0.[incr i] "trace command, wrong # args errors" {
	list [catch {trace list $type foo bar} msg] $msg
    } [list 1 "$start should be \"trace list $type name\""]
    test trace-14.0.[incr i] "trace command, wrong # args errors" {
	list [catch {trace list $type} msg] $msg
    } [list 1 "$start should be \"trace list $type name\""]
}

test trace-14.1 "trace command, wrong # args errors" {
    list [catch {trace} msg] $msg
} [list 1 "wrong # args: should be \"trace option ?arg arg ...?\""]
test trace-14.2 "trace command, wrong # args errors" {
    list [catch {trace add} msg] $msg
} [list 1 "wrong # args: should be \"trace add type ?arg arg ...?\""]
test trace-14.3 "trace command, wrong # args errors" {
    list [catch {trace remove} msg] $msg
} [list 1 "wrong # args: should be \"trace remove type ?arg arg ...?\""]
test trace-14.4 "trace command, wrong # args errors" {
    list [catch {trace list} msg] $msg
} [list 1 "wrong # args: should be \"trace list type ?arg arg ...?\""]

test trace-14.5 {trace command, invalid option} {
    list [catch {trace gorp} msg] $msg
} [list 1 "bad option \"gorp\": must be add, list, remove, variable, vdelete, or vinfo"]

# Again, [trace ... command] and [trace ... variable] share syntax and
# error message styles for their opList options; these loops test those 
# error messages.

set i 0
set errs [list "array, read, unset, or write" "delete or rename"]

    set info
} {1}
test trace-14.15 {trace command ("list variable" option)} {
    catch {unset x}
    trace add variable x write {traceTag 1}
    trace add variable x write traceProc
    trace add variable x write {traceTag 2}
    trace list variable x
} {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}}
test trace-14.16 {trace command ("list variable" option)} {
    catch {unset x}
    trace list variable x
} {}
test trace-14.17 {trace command ("list variable" option)} {
    catch {unset x}
    trace list variable x(0)
} {}
test trace-14.18 {trace command ("list variable" option)} {
    catch {unset x}
    set x 44
    trace list variable x(0)
} {}
test trace-14.19 {trace command ("list variable" option)} {
    catch {unset x}
    set x 44
    trace add variable x write {traceTag 1}
    proc check {} {global x; trace list variable x}
    check
} {{write {traceTag 1}}}

# Check fancy trace commands (long ones, weird arguments, etc.)

test trace-15.1 {long trace command} {
    catch {unset x}

    trace add variable x unset {traceProc}
    list [catch {unset x} msg] $msg $info
} {1 {can't unset "x": no such variable} {x {} unset}}
test trace-17.2 {traced variables must survive procedure exits} {
    catch {unset x}
    proc p1 {} {global x; trace add variable x write traceProc}
    p1
    trace list variable x
} {{write traceProc}}
test trace-17.3 {traced variables must survive procedure exits} {
    catch {unset x}
    set info {}
    proc p1 {} {global x; trace add variable x write traceProc}
    p1
    set x 44

    rename foo bar
    rename bar foo
    set info
} {bar foo rename}
test trace-19.2.1 {trace add command rename trace exists} {
    proc foo {} {}
    trace add command foo rename traceCommand
    trace list command foo
} {{rename traceCommand}}
test trace-19.3 {command rename traces don't fire on command deletion} {
    proc foo {} {}
    set info {}
    trace add command foo rename traceCommand
    rename foo {}
    set info
} {}
test trace-19.4 {trace add command rename doesn't trace recreated commands} {
    proc foo {} {}
    catch {rename bar {}}
    trace add command foo rename traceCommand
    proc foo {} {}
    rename foo bar
    set info
} {}
test trace-19.5 {trace add command deleted removes traces} {
    proc foo {} {}
    trace add command foo rename traceCommand
    proc foo {} {}
    trace list command foo
} {}

namespace eval tc {}
proc tc::tcfoo {} {}
test trace-19.6 {trace add command rename in namespace} {
    trace add command tc::tcfoo rename traceCommand
    rename tc::tcfoo tc::tcbar

    proc foo {} {}
    rename foo ""
    set info
} {}
test trace-20.2.1 {trace add command delete trace info} {
    proc foo {} {}
    trace add command foo delete traceCommand
    trace list command foo
} {{delete traceCommand}}
test trace-20.3 {trace add command implicit delete} {
    proc foo {} {}
    trace add command foo delete traceCommand
    proc foo {} {}
    set info
} {foo {} delete}
test trace-20.3.1 {trace add command delete trace info} {
    proc foo {} {}
    trace list command foo
} {}
test trace-20.4 {trace add command rename followed by delete} {
    set infotemp {}
    proc foo {} {}
    trace add command foo {rename delete} traceCommand
    rename foo bar
    lappend infotemp $info

    $tc eval [list proc foo {} {}]
    $tc eval [list trace add command foo {rename delete} traceCommand]
    interp delete $tc
    set info
} {}

proc traceDelete {cmd old new op} {
    eval trace remove command $cmd [lindex [trace list command $cmd] 0]
    global info
    set info [list $old $new $op]
}
proc traceCmdrename {cmd old new op} {
    rename $old someothername
}
proc traceCmddelete {cmd old new op} {
    rename $old ""
}
test trace-20.8 {trace delete while trace is active} {
    set info {}
    proc foo {} {}
    catch {rename bar {}}
    trace add command foo {rename delete} [list traceDelete foo]
    rename foo bar
    list [set info] [trace list command bar]
} {{foo bar rename} {}}

test trace-20.9 {rename trace deletes command} {
    set info {}
    proc foo {} {}
    catch {rename bar {}}
    catch {rename someothername {}}