Index: openacs-4/packages/acs-tcl/tcl/test/ad-proc-test-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/test/ad-proc-test-procs.tcl,v
diff -u
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-tcl/tcl/test/ad-proc-test-procs.tcl	11 Mar 2005 23:49:22 -0000	1.1
@@ -0,0 +1,100 @@
+ad_library {
+
+    Tests for ad_proc.
+
+    @creation-date 2005-03-11
+}
+
+aa_register_case -cats {api smoke} ad_proc_create_callback {
+
+    Tests the creation of a callback and an implementation with 
+    some forced error cases.
+
+} {
+    aa_true "throw error for ad_proc -callback with extraneous proc body" \
+        [catch {
+            ad_proc -callback a_callback { arg1 arg2 } { docs } { body }
+        } error]
+
+    aa_true "throw error for callback called contract" \
+        [catch {
+            ad_proc -callback contract { arg1 arg2 } { docs } -
+        } error]
+
+    ad_proc -callback a_callback { arg1 arg2 } { this is a test callback } -
+    set callback_procs [info procs ::callback::a_callback::*]
+    aa_true "creation of a valid callback contract with '-' body" \
+        [expr {[lsearch -exact \
+            $callback_procs \
+            ::callback::a_callback::contract] >= 0}]
+
+    ad_proc -callback a_callback_2 { arg1 arg2 } { this is a test callback }
+    set callback_procs [info procs ::callback::a_callback_2::*]
+    aa_true "creation of a valid callback contract with no body" \
+        [expr {[lsearch -exact \
+            $callback_procs \
+            ::callback::a_callback_2::contract] >= 0}]
+
+    aa_true "throw error for missing -callback on implementation definition" \
+        [catch {
+            ad_proc -impl an_impl {} { docs } { body }
+        } error]
+
+    aa_true "throw error for implementation named impl" \
+        [catch {
+            ad_proc -callback a_callback -impl impl {} { docs } { body }
+        } error]
+
+    ad_proc -callback a_callback -impl an_impl {} { 
+        this is a test callback implementation 
+    } {
+        return 1
+    }
+    set impl_procs [info procs ::callback::a_callback::impl::*]
+    aa_true "creation of a valid callback implementation" \
+        [expr {[lsearch -exact \
+            $impl_procs \
+            ::callback::a_callback::impl::an_impl] >= 0}]
+}
+
+aa_register_case -cats {api smoke} ad_proc_fire_callback {
+
+    Tests a callback with two implementations .
+
+} {
+    ad_proc -callback a_callback { 
+        -arg1:required arg2 
+    } { 
+        this is a test callback 
+    } -
+
+    aa_true "throws error for invalid arguments with no implementations" \
+        [catch {callback a_callback bar} error]
+
+    aa_true "callback returns empty list with no implementations" \
+        [expr {[llength [callback a_callback -arg1 foo bar]] == 0}]
+
+    ad_proc -callback a_callback -impl an_impl1 {} { 
+        this is a test callback implementation 
+    } {
+        return 1
+    }
+
+    ad_proc -callback a_callback -impl an_impl2 {} { 
+        this is a test callback implementation 
+    } {
+        return 2
+    }
+
+    aa_true "callback returns value for each defined callback" \
+        [expr {[llength [callback a_callback -arg1 foo bar]] == 2}]
+
+    aa_true "callback returns correct value for specified implementation" \
+        [expr {[callback -impl an_impl1 a_callback -arg1 foo bar] == 1}]
+
+    aa_true "throws error for invalid arguments with implementations" \
+        [catch {callback a_callback bar} error]
+
+    aa_true "throws error when a non-existent implementation is specified" \
+        [catch {callback -impl non_existent a_callback -arg1 foo bar} error]
+}