archie/tcl7.3/tests/proc.test

# Commands covered:  proc, return, global
#
# 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.
# All rights reserved.
#
# Permission is hereby granted, without written agreement and without
# license or royalty fees, to use, copy, modify, and distribute this
# software and its documentation for any purpose, provided that the
# above copyright notice and the following two paragraphs appear in
# all copies of this software.
#
# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
# AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
#
# $Header: /user6/ouster/tcl/tests/RCS/proc.test,v 1.15 93/08/03 16:10:28 ouster Exp $ (Berkeley)

if {[string compare test [info procs test]] == 1} then {source defs}

proc tproc {} {return a; return b}
test proc-1.1 {simple procedure call and return} {tproc} a
proc tproc x {
    set x [expr $x+1]
    return $x
}
test proc-1.2 {simple procedure call and return} {tproc 2} 3
test proc-1.3 {simple procedure call and return} {
    proc tproc {} {return foo}
} {}
test proc-1.4 {simple procedure call and return} {
    proc tproc {} {return}
    tproc
} {}

test proc-2.1 {local and global variables} {
    proc tproc x {
	set x [expr $x+1]
	return $x
    }
    set x 42
    list [tproc 6] $x
} {7 42}
test proc-2.2 {local and global variables} {
    proc tproc x {
	set y [expr $x+1]
	return $y
    }
    set y 18
    list [tproc 6] $y
} {7 18}
test proc-2.3 {local and global variables} {
    proc tproc x {
	global y
	set y [expr $x+1]
	return $y
    }
    set y 189
    list [tproc 6] $y
} {7 7}
test proc-2.4 {local and global variables} {
    proc tproc x {
	global y
	return [expr $x+$y]
    }
    set y 189
    list [tproc 6] $y
} {195 189}
catch {unset _undefined_}
test proc-2.5 {local and global variables} {
    proc tproc x {
	global _undefined_
	return $_undefined_
    }
    list [catch {tproc xxx} msg] $msg
} {1 {can't read "_undefined_": no such variable}}
test proc-2.6 {local and global variables} {
    set a 114
    set b 115
    global a b
    list $a $b
} {114 115}

proc do {cmd} {eval $cmd}
test proc-3.1 {local and global arrays} {
    catch {unset a}
    set a(0) 22
    list [catch {do {global a; set a(0)}} msg] $msg
} {0 22}
test proc-3.2 {local and global arrays} {
    catch {unset a}
    set a(x) 22
    list [catch {do {global a; set a(x) newValue}} msg] $msg $a(x)
} {0 newValue newValue}
test proc-3.3 {local and global arrays} {
    catch {unset a}
    set a(x) 22
    set a(y) 33
    list [catch {do {global a; unset a(y)}; array names a} msg] $msg
} {0 x}
test proc-3.4 {local and global arrays} {
    catch {unset a}
    set a(x) 22
    set a(y) 33
    list [catch {do {global a; unset a; info exists a}} msg] $msg \
	    [info exists a]
} {0 0 0}
test proc-3.5 {local and global arrays} {
    catch {unset a}
    set a(x) 22
    set a(y) 33
    list [catch {do {global a; unset a(y); array names a}} msg] $msg
} {0 x}
catch {unset a}
test proc-3.6 {local and global arrays} {
    catch {unset a}
    set a(x) 22
    set a(y) 33
    do {global a; do {global a; unset a}; set a(z) 22}
    list [catch {array names a} msg] $msg
} {0 z}
test proc-3.7 {local and global arrays} {
    proc t1 {args} {global info; set info 1}
    catch {unset a}
    set info {}
    do {global a; trace var a(1) w t1}
    set a(1) 44
    set info
} 1
test proc-3.8 {local and global arrays} {
    proc t1 {args} {global info; set info 1}
    catch {unset a}
    trace var a(1) w t1
    set info {}
    do {global a; trace vdelete a(1) w t1}
    set a(1) 44
    set info
} {}
test proc-3.9 {local and global arrays} {
    proc t1 {args} {global info; set info 1}
    catch {unset a}
    trace var a(1) w t1
    do {global a; trace vinfo a(1)}
} {{w t1}}
catch {unset a}

test proc-3.1 {arguments and defaults} {
    proc tproc {x y z} {
	return [list $x $y $z]
    }
    tproc 11 12 13
} {11 12 13}
test proc-3.2 {arguments and defaults} {
    proc tproc {x y z} {
	return [list $x $y $z]
    }
    list [catch {tproc 11 12} msg] $msg
} {1 {no value given for parameter "z" to "tproc"}}
test proc-3.3 {arguments and defaults} {
    proc tproc {x y z} {
	return [list $x $y $z]
    }
    list [catch {tproc 11 12 13 14} msg] $msg
} {1 {called "tproc" with too many arguments}}
test proc-3.4 {arguments and defaults} {
    proc tproc {x {y y-default} {z z-default}} {
	return [list $x $y $z]
    }
    tproc 11 12 13
} {11 12 13}
test proc-3.5 {arguments and defaults} {
    proc tproc {x {y y-default} {z z-default}} {
	return [list $x $y $z]
    }
    tproc 11 12
} {11 12 z-default}
test proc-3.6 {arguments and defaults} {
    proc tproc {x {y y-default} {z z-default}} {
	return [list $x $y $z]
    }
    tproc 11
} {11 y-default z-default}
test proc-3.7 {arguments and defaults} {
    proc tproc {x {y y-default} {z z-default}} {
	return [list $x $y $z]
    }
    list [catch {tproc} msg] $msg
} {1 {no value given for parameter "x" to "tproc"}}
test proc-3.8 {arguments and defaults} {
    list [catch {
	proc tproc {x {y y-default} z} {
	    return [list $x $y $z]
	}
	tproc 2 3
    } msg] $msg
} {1 {no value given for parameter "z" to "tproc"}}
test proc-3.9 {arguments and defaults} {
    proc tproc {x {y y-default} args} {
	return [list $x $y $args]
    }
    tproc 2 3 4 5
} {2 3 {4 5}}
test proc-3.10 {arguments and defaults} {
    proc tproc {x {y y-default} args} {
	return [list $x $y $args]
    }
    tproc 2 3
} {2 3 {}}
test proc-3.11 {arguments and defaults} {
    proc tproc {x {y y-default} args} {
	return [list $x $y $args]
    }
    tproc 2
} {2 y-default {}}
test proc-3.12 {arguments and defaults} {
    proc tproc {x {y y-default} args} {
	return [list $x $y $args]
    }
    list [catch {tproc} msg] $msg
} {1 {no value given for parameter "x" to "tproc"}}

test proc-4.1 {variable numbers of arguments} {
    proc tproc args {return $args}
    tproc
} {}
test proc-4.2 {variable numbers of arguments} {
    proc tproc args {return $args}
    tproc 1 2 3 4 5 6 7 8
} {1 2 3 4 5 6 7 8}
test proc-4.3 {variable numbers of arguments} {
    proc tproc args {return $args}
    tproc 1 {2 3} {4 {5 6} {{{7}}}} 8
} {1 {2 3} {4 {5 6} {{{7}}}} 8}
test proc-4.4 {variable numbers of arguments} {
    proc tproc {x y args} {return $args}
    tproc 1 2 3 4 5 6 7
} {3 4 5 6 7}
test proc-4.5 {variable numbers of arguments} {
    proc tproc {x y args} {return $args}
    tproc 1 2
} {}
test proc-4.6 {variable numbers of arguments} {
    proc tproc {x missing args} {return $args}
    list [catch {tproc 1} msg] $msg
} {1 {no value given for parameter "missing" to "tproc"}}

test proc-5.1 {error conditions} {
    list [catch {proc} msg] $msg
} {1 {wrong # args: should be "proc name args body"}}
test proc-5.2 {error conditions} {
    list [catch {proc tproc b} msg] $msg
} {1 {wrong # args: should be "proc name args body"}}
test proc-5.3 {error conditions} {
    list [catch {proc tproc b c d e} msg] $msg
} {1 {wrong # args: should be "proc name args body"}}
test proc-5.4 {error conditions} {
    list [catch {proc tproc \{xyz {return foo}} msg] $msg
} {1 {unmatched open brace in list}}
test proc-5.5 {error conditions} {
    list [catch {proc tproc {{} y} {return foo}} msg] $msg
} {1 {procedure "tproc" has argument with no name}}
test proc-5.6 {error conditions} {
    list [catch {proc tproc {{} y} {return foo}} msg] $msg
} {1 {procedure "tproc" has argument with no name}}
test proc-5.7 {error conditions} {
    list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg
} {1 {too many fields in argument specifier "x 1 2"}}
test proc-5.8 {error conditions} {
    catch {return}
} 2
test proc-5.9 {error conditions} {
    list [catch {global} msg] $msg
} {1 {wrong # args: should be "global varName ?varName ...?"}}
proc tproc {} {
    set a 22
    global a
}
test proc-5.10 {error conditions} {
    list [catch {tproc} msg] $msg
} {1 {variable "a" already exists}}
test proc-5.11 {error conditions} {
    catch {rename tproc {}}
    catch {
	proc tproc {x {} z} {return foo}
    }
    list [catch {tproc 1} msg] $msg
} {1 {invalid command name: "tproc"}}
test proc-5.12 {error conditions} {
    proc tproc {} {
	set a 22
	error "error in procedure"
	return
    }
    list [catch tproc msg] $msg
} {1 {error in procedure}}
test proc-5.13 {error conditions} {
    proc tproc {} {
	set a 22
	error "error in procedure"
	return
    }
    catch tproc msg
    set errorInfo
} {error in procedure
    while executing
"error "error in procedure""
    (procedure "tproc" line 3)
    invoked from within
"tproc"}
test proc-5.14 {error conditions} {
    proc tproc {} {
	set a 22
	break
	return
    }
    catch tproc msg
    set errorInfo
} {invoked "break" outside of a loop
    while executing
"tproc"}
test proc-5.15 {error conditions} {
    proc tproc {} {
	set a 22
	continue
	return
    }
    catch tproc msg
    set errorInfo
} {invoked "continue" outside of a loop
    while executing
"tproc"}

# The tests below will really only be useful when run under Purify or
# some other system that can detect accesses to freed memory...

test proc-6.1 {procedure that redefines itself} {
    proc tproc {} {
	proc tproc {} {
	    return 44
	}
	return 45
    }
    tproc
} 45
test proc-6.2 {procedure that deletes itself} {
    proc tproc {} {
	rename tproc {}
	return 45
    }
    tproc
} 45

proc tproc code {
    return -code $code abc
}
test proc-7.1 {return with special completion code} {
    list [catch {tproc ok} msg] $msg
} {0 abc}
test proc-7.2 {return with special completion code} {
    list [catch {tproc error} msg] $msg $errorInfo $errorCode
} {1 abc {abc
    while executing
"tproc error"} NONE}
test proc-7.3 {return with special completion code} {
    list [catch {tproc return} msg] $msg
} {2 abc}
test proc-7.4 {return with special completion code} {
    list [catch {tproc break} msg] $msg
} {3 abc}
test proc-7.5 {return with special completion code} {
    list [catch {tproc continue} msg] $msg
} {4 abc}
test proc-7.6 {return with special completion code} {
    list [catch {tproc -14} msg] $msg
} {-14 abc}
test proc-7.7 {return with special completion code} {
    list [catch {tproc gorp} msg] $msg
} {1 {bad completion code "gorp": must be ok, error, return, break, continue, or an integer}}
test proc-7.8 {return with special completion code} {
    list [catch {tproc 10b} msg] $msg
} {1 {bad completion code "10b": must be ok, error, return, break, continue, or an integer}}
test proc-7.9 {return with special completion code} {
    proc tproc2 {} {
	tproc return
    }
    list [catch tproc2 msg] $msg
} {0 abc}
test proc-7.10 {return with special completion code} {
    proc tproc2 {} {
	return -code error
    }
    list [catch tproc2 msg] $msg
} {1 {}}
test proc-7.11 {return with special completion code} {
    proc tproc2 {} {
	global errorCode errorInfo
	catch {open _bad_file_name r} msg
	return -code error -errorinfo $errorInfo -errorcode $errorCode $msg
    }
    string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode]
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
    while executing
"open _bad_file_name r"
    invoked from within
"tproc2"} {posix enoent {no such file or directory}}}
test proc-7.12 {return with special completion code} {
    proc tproc2 {} {
	global errorCode errorInfo
	catch {open _bad_file_name r} msg
	return -code error -errorcode $errorCode $msg
    }
    string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode]
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
    while executing
"tproc2"} {posix enoent {no such file or directory}}}
test proc-7.13 {return with special completion code} {
    proc tproc2 {} {
	global errorCode errorInfo
	catch {open _bad_file_name r} msg
	return -code error -errorinfo $errorInfo $msg
    }
    string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode]
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
    while executing
"open _bad_file_name r"
    invoked from within
"tproc2"} none}
test proc-7.14 {return with special completion code} {
    proc tproc2 {} {
	global errorCode errorInfo
	catch {open _bad_file_name r} msg
	return -code error $msg
    }
    string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode]
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
    while executing
"tproc2"} none}
test proc-7.14 {return with special completion code} {
    list [catch {return -badOption foo message} msg] $msg
} {1 {bad option "-badOption: must be -code, -errorcode, or -errorinfo}}