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

[ 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]

    aa_silence_log_entries -severities warning {
        #
        # In this situation, [info script] returns empty, and no
        # package_key can be determined
        #
        #     Warning: cannot determine package key from script ''
        #
        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}

    aa_silence_log_entries -severities warning {
        #
        # In this situation, [info script] returns empty, and no
        # package_key can be determined
        #
        #     Warning: cannot determine package key from script ''
        #
        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]

    aa_silence_log_entries -severities warning {
        #
        # In this situation, [info script] returns empty, and no
        # package_key can be determined
        #
        #     Warning: cannot determine package key from script ''
        #
        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_silence_log_entries -severities warning {
        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: