ad-proc-test-procs.tcl

Tests for ad_proc.

Location:
packages/acs-tcl/tcl/test/ad-proc-test-procs.tcl
Created:
2005-03-11
Author:
Lee Denison lee@xarg.co.uk

Procedures in this file

Detailed information

_acs-tcl__ad_proc_create_callback (private)

 _acs-tcl__ad_proc_create_callback

Partial Call Graph (max 5 caller/called nodes):
%3 aa_log aa_log (public) aa_log_result aa_log_result (public) aa_true aa_true (public) _acs-tcl__ad_proc_create_callback _acs-tcl__ad_proc_create_callback _acs-tcl__ad_proc_create_callback->aa_log _acs-tcl__ad_proc_create_callback->aa_log_result _acs-tcl__ad_proc_create_callback->aa_true

Testcases:
No testcase defined.

_acs-tcl__ad_proc_fire_callback (private)

 _acs-tcl__ad_proc_fire_callback

Partial Call Graph (max 5 caller/called nodes):
%3 aa_false aa_false (public) aa_log aa_log (public) aa_log_result aa_log_result (public) aa_test_EvilCallback aa_test_EvilCallback (private) aa_true aa_true (public) _acs-tcl__ad_proc_fire_callback _acs-tcl__ad_proc_fire_callback _acs-tcl__ad_proc_fire_callback->aa_false _acs-tcl__ad_proc_fire_callback->aa_log _acs-tcl__ad_proc_fire_callback->aa_log_result _acs-tcl__ad_proc_fire_callback->aa_test_EvilCallback _acs-tcl__ad_proc_fire_callback->aa_true

Testcases:
No testcase defined.

aa_test_EvilCallback (private)

 aa_test_EvilCallback

This is a test callback implementation that should not be invoked.

Partial Call Graph (max 5 caller/called nodes):
%3

Testcases:
No testcase defined.

callback::a_callback::contract (private)

 callback::a_callback::contract -arg1 arg1 arg2

this is a test callback

Switches:
-arg1
(required)
Parameters:
arg2

Partial Call Graph (max 5 caller/called nodes):
%3

Testcases:
No testcase defined.

callback::a_callback::impl::an_impl1 (private)

 callback::a_callback::impl::an_impl1

this is a test callback implementation

See Also:

Partial Call Graph (max 5 caller/called nodes):
%3

Testcases:
No testcase defined.

callback::a_callback::impl::an_impl2 (private)

 callback::a_callback::impl::an_impl2

this is a test callback implementation which does an upvar of an array.

See Also:

Partial Call Graph (max 5 caller/called nodes):
%3

Testcases:
No testcase defined.

callback::a_callback::impl::fail_impl (private)

 callback::a_callback::impl::fail_impl

this is a test callback implementation

See Also:

Partial Call Graph (max 5 caller/called nodes):
%3

Testcases:
No testcase defined.

callback::b_callback::contract (private)

 callback::b_callback::contract -arg1 arg1 arg2

this is a test callback

Switches:
-arg1
(required)
Parameters:
arg2

Partial Call Graph (max 5 caller/called nodes):
%3

Testcases:
No testcase defined.

callback::c_callback::contract (private)

 callback::c_callback::contract -arg1 arg1 arg2

this is a test callback

Switches:
-arg1
(required)
Parameters:
arg2

Partial Call Graph (max 5 caller/called nodes):
%3

Testcases:
No testcase defined.
[ hide source ] | [ make this the default ]

Content File Source

ad_library {

    Tests for ad_proc.

    @author Lee Denison lee@xarg.co.uk
    @creation-date 2005-03-11
}

aa_register_case \
    -cats {api smoke} \
    -procs {d_proc callback} \
    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 {
            d_proc -callback a_callback { arg1 arg2 } { docs } { body }
        } error]

    aa_true "throw error for callback called contract" \
        [catch {
            d_proc -callback contract { arg1 arg2 } { docs } -
        } error]

    d_proc -callback a_callback { -arg1 arg2 } { this is a test callback } -
    set callback_procs [info commands ::callback::a_callback::*]
    aa_true "creation of a valid callback contract with '-' body" \
        {"::callback::a_callback::contract" in $callback_procs}

    d_proc -callback a_callback_2 { arg1 arg2 } { this is a test callback } {}
    set callback_procs [info commands ::callback::a_callback_2::*]
    aa_true "creation of a valid callback contract with no body" \
        {"::callback::a_callback_2::contract" in $callback_procs}

    aa_true "throw error for missing -callback on implementation definition" \
        [catch {
            d_proc -impl an_impl {} { docs } { body }
        } error]

    aa_true "throw error for implementation named impl" \
        [catch {
            d_proc -callback a_callback -impl impl {} { docs } { body }
        } error]

    d_proc -callback a_callback -impl an_impl {} {
        this is a test callback implementation
    } {
    }
    set impl_procs [info commands ::callback::a_callback::impl::*]
    aa_true "creation of a valid callback implementation" \
        {"::callback::a_callback::impl::an_impl" in $impl_procs}
}

d_proc -callback a_callback {
        -arg1:required arg2
} {
        this is a test callback
} -

d_proc -callback b_callback {
        -arg1:required arg2
} {
        this is a test callback
} -
d_proc -callback c_callback {
        -arg1:required arg2
} {
        this is a test callback
} -

d_proc -callback a_callback -impl an_impl1 {} {
        this is a test callback implementation
} {
        return 1
}

d_proc -callback a_callback -impl an_impl2 {} {
        this is a test callback implementation which does
        an upvar of an array.
} {
        upvar $arg1 arr
    if {[info exists arr(test)]} {
            return $arr(test)
    }
    return {}
}

d_proc -callback a_callback -impl fail_impl {} {
        this is a test callback implementation
} {
        error "should fail"
}


ad_proc -private aa_test_EvilCallback {} {
    This is a test callback implementation that should not be invoked.
} {
        error "Should not be invoked"
}

aa_register_case \
    -cats {api smoke} \
    -procs {callback} \
    ad_proc_fire_callback {

    Tests a callback with two implementations .

} {
    aa_true "throws error for invalid arguments even if no implementations" \
        [catch {callback c_callback bar} error]

    aa_true "callback returns empty list with no implementations" \
        {[llength [callback b_callback -arg1 foo bar]] == 0}

    set foo(test) 2

    aa_true "callback returns value for each defined callback and catches the error callback" \
        {[llength [callback -catch a_callback -arg1 foo bar]] == 2}

    aa_true "callback returns correct value for specified implementation" \
        {[callback -impl an_impl1 a_callback -arg1 foo bar] == 1}

    aa_true "callback returns correct value for an array ref" \
        {[callback -impl an_impl2 a_callback -arg1 foo bar] == 2}

    aa_true "callback works with {} args" \
        {[callback -impl an_impl2 a_callback -arg1 {} {}] == {}}

    aa_true "callback errors with missing arg" \
        {[catch {callback -impl an_impl2 a_callback -arg1 foo} err] == 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]

    aa_true "throws error without -catch when an error occurs in a callback" \
        [catch {callback a_callback -arg1 foo bar} error]

    set x [catch {callback -impl an_impl2 a_callback -arg1 foo {[aa_test_EvilCallback]}} error]
    aa_false "EvilCallback not invoked returned $error" $x

    set x [catch {callback -impl an_impl2 a_callback -arg1 {[aa_test_EvilCallback]} bar} error]
    aa_false "EvilCallback not invoked returned $error" $x


}

# Local variables:
#    mode: tcl
#    tcl-indent-level: 4
#    indent-tabs-mode: nil
# End: