home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / tests / basic.test < prev    next >
Encoding:
Text File  |  1997-08-15  |  13.5 KB  |  397 lines  |  [TEXT/ALFA]
  1. # This file contains tests for the tclBasic.c source file. Tests appear in
  2. # the same order as the C code that they test. The set of tests is
  3. # currently incomplete since it currently includes only new tests for
  4. # code changed for the addition of Tcl namespaces. Other variable-
  5. # related tests appear in several other test files including
  6. # assocd.test, cmdInfo.test, eval.test, expr.test, interp.test,
  7. # and trace.test.
  8. #
  9. # Sourcing this file into Tcl runs the tests and generates output for
  10. # errors. No output means no errors were found.
  11. #
  12. # Copyright (c) 1997 Sun Microsystems, Inc.
  13. #
  14. # See the file "license.terms" for information on usage and redistribution
  15. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  16. #
  17. # SCCS: @(#) basic.test 1.18 97/08/07 10:36:59
  18. #
  19.  
  20. if {[string compare test [info procs test]] == 1} then {source defs}
  21.  
  22. catch {namespace delete test_ns_basic}
  23. catch {interp delete test_interp}
  24. catch {rename p ""}
  25. catch {rename q ""}
  26. catch {rename cmd ""}
  27. catch {unset x}
  28.  
  29. test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} {
  30.     catch {interp delete test_interp}
  31.     interp create test_interp
  32.     interp eval test_interp {
  33.         namespace eval test_ns_basic {
  34.             proc p {} {
  35.                 return [namespace current]
  36.             }
  37.         }
  38.     }
  39.     list [interp eval test_interp {test_ns_basic::p}] \
  40.          [interp delete test_interp]
  41. } {::test_ns_basic {}}
  42.  
  43. test basic-2.1 {DeleteInterpProc, destroys interp's global namespace} {
  44.     catch {interp delete test_interp}
  45.     interp create test_interp
  46.     interp eval test_interp {
  47.         namespace eval test_ns_basic {
  48.             namespace export p
  49.             proc p {} {
  50.                 return [namespace current]
  51.             }
  52.         }
  53.         namespace eval test_ns_2 {
  54.             namespace import ::test_ns_basic::p
  55.             variable v 27
  56.             proc q {} {
  57.                 variable v
  58.                 return "[p] $v"
  59.             }
  60.         }
  61.     }
  62.     list [interp eval test_interp {test_ns_2::q}] \
  63.          [interp eval test_interp {namespace delete ::}] \
  64.          [catch {interp eval test_interp {set a 123}} msg] $msg \
  65.          [interp delete test_interp]
  66. } {{::test_ns_basic 27} {} 1 {invalid command name "set"} {}}
  67.  
  68. test basic-3.1 {HiddenCmdsDeleteProc, invalidate cached refs to deleted hidden cmd} {
  69.     catch {interp delete test_interp}
  70.     interp create test_interp
  71.     interp eval test_interp {
  72.         proc p {} {
  73.             return 27
  74.         }
  75.     }
  76.     interp alias {} localP test_interp p
  77.     list [interp eval test_interp {p}] \
  78.          [localP] \
  79.          [test_interp hide p] \
  80.          [catch {localP} msg] $msg \
  81.          [interp delete test_interp] \
  82.          [catch {localP} msg] $msg
  83. } {27 27 {} 1 {invalid command name "p"} {} 1 {invalid command name "localP"}}
  84.  
  85. # NB: More tests about hide/expose are found in interp.test
  86.  
  87. test basic-4.1 {Tcl_HideCommand, names of hidden cmds can't have namespace qualifiers} {
  88.     catch {interp delete test_interp}
  89.     interp create test_interp
  90.     interp eval test_interp {
  91.         namespace eval test_ns_basic {
  92.             proc p {} {
  93.                 return [namespace current]
  94.             }
  95.         }
  96.     }
  97.     list [catch {test_interp hide test_ns_basic::p x} msg] $msg \
  98.      [catch {test_interp hide x test_ns_basic::p} msg1] $msg1 \
  99.          [interp delete test_interp]
  100. } {1 {can only hide global namespace commands (use rename then hide)} 1 {cannot use namespace qualifiers as hidden commandtoken (rename)} {}}
  101.  
  102. test basic-4.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace} {
  103.     catch {namespace delete test_ns_basic}
  104.     catch {rename cmd ""}
  105.     proc cmd {} {   ;# note that this is global
  106.         return [namespace current]
  107.     }
  108.     namespace eval test_ns_basic {
  109.         proc hideCmd {} {
  110.             interp hide {} cmd
  111.         }
  112.         proc exposeCmd {} {
  113.             interp expose {} cmd
  114.         }
  115.         proc callCmd {} {
  116.             cmd
  117.         }
  118.     }
  119.     list [test_ns_basic::callCmd] \
  120.          [test_ns_basic::hideCmd] \
  121.          [catch {cmd} msg] $msg \
  122.          [test_ns_basic::exposeCmd] \
  123.          [test_ns_basic::callCmd] \
  124.          [namespace delete test_ns_basic]
  125. } {:: {} 1 {invalid command name "cmd"} {} :: {}}
  126.  
  127. test basic-5.1 {Tcl_ExposeCommand, a command stays in the global namespace and can not go to another namespace} {
  128.     catch {namespace delete test_ns_basic}
  129.     catch {rename cmd ""}
  130.     proc cmd {} {   ;# note that this is global
  131.         return [namespace current]
  132.     }
  133.     namespace eval test_ns_basic {
  134.         proc hideCmd {} {
  135.             interp hide {} cmd
  136.         }
  137.         proc exposeCmdFailing {} {
  138.             interp expose {} cmd ::test_ns_basic::newCmd
  139.         }
  140.         proc exposeCmdWorkAround {} {
  141.             interp expose {} cmd;
  142.         rename cmd ::test_ns_basic::newCmd;
  143.         }
  144.         proc callCmd {} {
  145.             cmd
  146.         }
  147.     }
  148.     list [test_ns_basic::callCmd] \
  149.          [test_ns_basic::hideCmd] \
  150.          [catch {test_ns_basic::exposeCmdFailing} msg] $msg \
  151.          [test_ns_basic::exposeCmdWorkAround] \
  152.          [test_ns_basic::newCmd] \
  153.          [namespace delete test_ns_basic]
  154. } {:: {} 1 {can not expose to a namespace (use expose to toplevel, then rename)} {} ::test_ns_basic {}}
  155. test basic-5.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being exposed} {
  156.     catch {rename p ""}
  157.     catch {rename cmd ""}
  158.     proc p {} {
  159.         cmd
  160.     }
  161.     proc cmd {} {
  162.         return 42
  163.     }
  164.     list [p] \
  165.          [interp hide {} cmd] \
  166.          [proc cmd {} {return Hello}] \
  167.          [cmd] \
  168.          [rename cmd ""] \
  169.          [interp expose {} cmd] \
  170.          [p]
  171. } {42 {} {} Hello {} {} 42}
  172.  
  173. if {[info commands testcreatecommand] != {}} {
  174.     test basic-6.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} {
  175.         catch {eval namespace delete [namespace children :: test_ns_*]}
  176.         list [testcreatecommand create] \
  177.              [test_ns_basic::createdcommand] \
  178.              [testcreatecommand delete]
  179.     } {{} {CreatedCommandProc in ::test_ns_basic} {}}
  180.     test basic-6.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} {
  181.         catch {eval namespace delete [namespace children :: test_ns_*]}
  182.         catch {rename value:at: ""}
  183.         list [testcreatecommand create2] \
  184.              [value:at:] \
  185.              [testcreatecommand delete2]
  186.     } {{} {CreatedCommandProc2 in ::} {}}
  187. }
  188. test basic-6.3 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in its name, if any} {
  189.     catch {eval namespace delete [namespace children :: test_ns_*]}
  190.     namespace eval test_ns_basic {}
  191.     proc test_ns_basic::cmd {} {  ;# proc requires that ns already exist
  192.         return [namespace current]
  193.     }
  194.     list [test_ns_basic::cmd] \
  195.          [namespace delete test_ns_basic]
  196. } {::test_ns_basic {}}
  197.  
  198. test basic-7.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} {
  199.     catch {eval namespace delete [namespace children :: test_ns_*]}
  200.     catch {rename cmd ""}
  201.     namespace eval test_ns_basic {
  202.         proc p {} {
  203.             return "p in [namespace current]"
  204.         }
  205.     }
  206.     list [test_ns_basic::p] \
  207.          [rename test_ns_basic::p test_ns_basic::q] \
  208.          [test_ns_basic::q] 
  209. } {{p in ::test_ns_basic} {} {p in ::test_ns_basic}}
  210. test basic-7.2 {TclRenameCommand, existing cmd must be found} {
  211.     catch {eval namespace delete [namespace children :: test_ns_*]}
  212.     list [catch {rename test_ns_basic::p test_ns_basic::q} msg] $msg
  213. } {1 {can't rename "test_ns_basic::p": command doesn't exist}}
  214. test basic-7.3 {TclRenameCommand, delete cmd if new name is empty} {
  215.     catch {eval namespace delete [namespace children :: test_ns_*]}
  216.     namespace eval test_ns_basic {
  217.         proc p {} {
  218.             return "p in [namespace current]"
  219.         }
  220.     }
  221.     list [info commands test_ns_basic::*] \
  222.          [rename test_ns_basic::p ""] \
  223.          [info commands test_ns_basic::*]
  224. } {::test_ns_basic::p {} {}}
  225. test basic-7.4 {TclRenameCommand, bad new name} {
  226.     catch {eval namespace delete [namespace children :: test_ns_*]}
  227.     namespace eval test_ns_basic {
  228.         proc p {} {
  229.             return "p in [namespace current]"
  230.         }
  231.     }
  232.     rename test_ns_basic::p :::george::martha
  233. } {}
  234. test basic-7.5 {TclRenameCommand, new name must not already exist} {
  235.     namespace eval test_ns_basic {
  236.         proc q {} {
  237.             return 42
  238.         }
  239.     }
  240.     list [catch {rename test_ns_basic::q :::george::martha} msg] $msg
  241. } {1 {can't rename to ":::george::martha": command already exists}}
  242. test basic-7.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} {
  243.     catch {eval namespace delete [namespace children :: test_ns_*]}
  244.     catch {rename p ""}
  245.     catch {rename q ""}
  246.     proc p {} {
  247.         return "p in [namespace current]"
  248.     }
  249.     proc q {} {
  250.         return "q in [namespace current]"
  251.     }
  252.     namespace eval test_ns_basic {
  253.         proc callP {} {
  254.             p
  255.         }
  256.     }
  257.     list [test_ns_basic::callP] \
  258.          [rename q test_ns_basic::p] \
  259.          [test_ns_basic::callP]
  260. } {{p in ::} {} {q in ::test_ns_basic}}
  261.  
  262. test basic-8.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {
  263.     catch {eval namespace delete [namespace children :: test_ns_*]}
  264.     catch {rename p ""}
  265.     catch {rename q ""}
  266.     catch {unset x}
  267.     set x [namespace eval test_ns_basic::test_ns_basic2 {
  268.         # the following creates a cmd in the global namespace
  269.         testcmdtoken create p
  270.     }]
  271.     list [testcmdtoken name $x] \
  272.          [rename ::p q] \
  273.          [testcmdtoken name $x]
  274. } {{p ::p} {} {q ::q}}
  275. test basic-8.2 {Tcl_GetCommandInfo, names for commands created outside namespaces} {
  276.     catch {rename q ""}
  277.     set x [testcmdtoken create test_ns_basic::test_ns_basic2::p]
  278.     list [testcmdtoken name $x] \
  279.          [rename test_ns_basic::test_ns_basic2::p q] \
  280.          [testcmdtoken name $x]
  281. } {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}}
  282.  
  283. test basic-9.1 {Tcl_GetCommandFullName} {
  284.     catch {eval namespace delete [namespace children :: test_ns_*]}
  285.     namespace eval test_ns_basic1 {
  286.         namespace export cmd*
  287.         proc cmd1 {} {}
  288.         proc cmd2 {} {}
  289.     }
  290.     namespace eval test_ns_basic2 {
  291.         namespace export *
  292.         namespace import ::test_ns_basic1::*
  293.         proc p {} {}
  294.     }
  295.     namespace eval test_ns_basic3 {
  296.         namespace import ::test_ns_basic2::*
  297.         proc q {} {}
  298.         list [namespace which -command foreach] \
  299.              [namespace which -command q] \
  300.              [namespace which -command p] \
  301.              [namespace which -command cmd1] \
  302.              [namespace which -command ::test_ns_basic2::cmd2]
  303.     }
  304. } {::foreach ::test_ns_basic3::q ::test_ns_basic3::p ::test_ns_basic3::cmd1 ::test_ns_basic2::cmd2}
  305.  
  306. test basic-10.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} {
  307.     catch {interp delete test_interp}
  308.     catch {unset x}
  309.     interp create test_interp
  310.     interp eval test_interp {
  311.         proc useSet {} {
  312.             return [set a 123]
  313.         }
  314.     }
  315.     set x [interp eval test_interp {useSet}]
  316.     interp eval test_interp {
  317.         rename set ""
  318.         proc set {args} {
  319.             return "set called with $args"
  320.         }
  321.     }
  322.     list $x \
  323.          [interp eval test_interp {useSet}] \
  324.          [interp delete test_interp]
  325. } {123 {set called with a 123} {}}
  326. test basic-10.2 {Tcl_DeleteCommandFromToken, deleting commands changes command epoch} {
  327.     catch {eval namespace delete [namespace children :: test_ns_*]}
  328.     catch {rename p ""}
  329.     proc p {} {
  330.         return "global p"
  331.     }
  332.     namespace eval test_ns_basic {
  333.         proc p {} {
  334.             return "namespace p"
  335.         }
  336.         proc callP {} {
  337.             p
  338.         }
  339.     }
  340.     list [test_ns_basic::callP] \
  341.          [rename test_ns_basic::p ""] \
  342.          [test_ns_basic::callP]
  343. } {{namespace p} {} {global p}}
  344. test basic-10.3 {Tcl_DeleteCommandFromToken, delete imported cmds that refer to a deleted cmd} {
  345.     catch {eval namespace delete [namespace children :: test_ns_*]}
  346.     catch {rename p ""}
  347.     namespace eval test_ns_basic {
  348.         namespace export p
  349.         proc p {} {return 42}
  350.     }
  351.     namespace eval test_ns_basic2 {
  352.         namespace import ::test_ns_basic::*
  353.         proc callP {} {
  354.             p
  355.         }
  356.     }
  357.     list [test_ns_basic2::callP] \
  358.          [info commands test_ns_basic2::*] \
  359.          [rename test_ns_basic::p ""] \
  360.          [catch {test_ns_basic2::callP} msg] $msg \
  361.          [info commands test_ns_basic2::*]
  362. } {42 {::test_ns_basic2::callP ::test_ns_basic2::p} {} 1 {invalid command name "p"} ::test_ns_basic2::callP}
  363.  
  364. test basic-11.1 {TclObjInvoke, lookup of "unknown" command} {
  365.     catch {eval namespace delete [namespace children :: test_ns_*]}
  366.     catch {interp delete test_interp}
  367.     interp create test_interp
  368.     interp eval test_interp {
  369.         proc unknown {args} {
  370.             return "global unknown"
  371.         }
  372.         namespace eval test_ns_basic {
  373.             proc unknown {args} {
  374.                 return "namespace unknown"
  375.             }
  376.         }
  377.     }
  378.     list [interp alias test_interp newAlias test_interp doesntExist] \
  379.          [catch {interp eval test_interp {newAlias}} msg] $msg \
  380.          [interp delete test_interp]
  381. } {newAlias 0 {global unknown} {}}
  382.  
  383. test basic-12.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {
  384.     testcmdtrace {set stuff [info tclversion]}
  385. } {{info tclversion} {info tclversion} {set stuff [info tclversion]} {set stuff 8.0}}
  386.  
  387. catch {eval namespace delete [namespace children :: test_ns_*]}
  388. catch {namespace delete george}
  389. catch {interp delete test_interp}
  390. catch {rename p ""}
  391. catch {rename q ""}
  392. catch {rename cmd ""}
  393. catch {rename value:at: ""}
  394. catch {unset x}
  395. set x 0
  396. unset x
  397.