aa_register

aa_register_case (public)

 aa_register_case [ -libraries libraries ] [ -cats cats ] \
    [ -error_level error_level ] [ -bugs bugs ] [ -procs procs ] \
    [ -urls urls ] [ -init_classes init_classes ] \
    [ -on_error on_error ] testcase_id testcase_desc [ args... ]

Defined in packages/acs-automated-testing/tcl/aa-test-procs.tcl

Registers a testcase with the acs-automated-testing system. Whenever possible, cases that fail to register are replaced with 'metatest' log cases, so that the register-time errors are visible at test time. See the tutorial for examples.

Switches:

-libraries (optional)

A list of keywords of additional code modules to load. The entire test case will fail if any package is missing. Currently includes tclwebtest.

-cats (optional)

Properties of the test case. Must be zero or more of the following:

db: Tests the database directly
api: tests the Tcl API
web: tests HTTP interface
smoke: Minimal test to assure functionality and catch basic errors.
stress: Puts heavy load on server or creates large numbers of records. Intended to simulate maximal production load.
security_risk: May introduce a security risk.
populator: Creates sample data for future use.
production_safe: Can be used on a live production site, i.e. for sanity checking or keepalive purposes. Implies: no risk of adding or deleting data; no risk of crashing; minimal cpu/db/net load.

-error_level (optional, defaults to "error")

Force all test failures to this error level. One of

notice: Informative. Does not indicate an error.
warning: May indicate an problem. Example: a non-critical bug repro case that hasn't been fixed.
error: normal error
metatest: Indicates a problem with the test framework, execution, or reporting. Suggests that current test results may be invalid. Use this for test cases that test the tests. Also used, automatically, for errors sourcing test cases.

-bugs (optional)

A list of integers corresponding to openacs.org bug numbers which relate to this test case.

-procs (optional)

A list of OpenACS procs which are tested by this case.

-urls (optional)

A list of URLs (relative to package) tested in web test case

-init_classes (optional)

Deprecated.

-on_error (optional)

Deprecated.

Parameters:

testcase_id (required)
testcase_desc (required)

Author:

Peter Harper

Created:

24 July 2001

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

Testcases:

webtest_example, aa__coverage_proc_coverage, aa__coverage_proc_proc_list_covered, aa__coverage_proc_coverage_level

Source code:

    # error reporting kludge: if there is any text in this variable
    # we'll not register this test case but indicate in the test case
    # body that there was an error.
    set case_error ""

    set allowed_error_levels { notice warning metatest error }
    if {$error_level ni $allowed_error_levels} {
        set error_level metatest
        append case_error "error_level must be one of following: $allowed_error_levels.\n\n"
    }

    set allowed_categories [nsv_get aa_test categories]
    foreach cat $cats {
        if {$cat ni $allowed_categories} {
            set error_level metatest
            append case_error "cats must contain only the following: $allowed_categories. You had a '$cat' in there.\n\n"
        }
    }

    #
    # Work out the package_key.
    #
    set package_root [file join $::acs::rootdir packages]
    set package_rel [string replace [info script] 0 [string length $package_root]]
    set package_key [lindex [file split $package_rel] 0]

    # run library specific code
    foreach library $libraries {
        if { $library eq "tclwebtest" } {

            # kludge: until tclwebtest installs itself in the proper
            # place following the Tcl way, we use this absolute path
            # hack.
            set tclwebtest_absolute_path "/usr/local/tclwebtest/lib"
            if { ![info exists ::auto_path] || $tclwebtest_absolute_path ni $::auto_path } {
                lappend ::auto_path $tclwebtest_absolute_path
            }
            if { [catch {
                package require tclwebtest
                package require http
            } err] } {
                set error_level metatest
                append case_error "tclwebtest is not available. Not registering this test case.\n\nError message: $err\n\n"
            }
        }
    }

    #
    # Print warnings for any unknown init_classes.  We actually mask out
    # any unknown init_classes here, so we don't get any script errors later.
    #
    set filtered_inits {}
    foreach init_class $init_classes {
        if {[llength $init_class] == 2} {
            set init_class [lindex $init_class 0]
        }
        if {[string trim $init_class] ne ""} {
            set found 0
            foreach init_class_info [nsv_get aa_test init_classes] {
                if {$init_class == [lindex $init_class_info 0]} {
                    set found 1
                }
            }
            if {!$found} {
                ns_log warning " aa_register_case: Unknown init class $init_class"
            } else {
                lappend filtered_inits $init_class
            }
        }
    }
    set init_classes $filtered_inits


    set test_case_list [list $testcase_id $testcase_desc  [info script] $package_key  $cats $init_classes $on_error $args $error_level  $bugs $procs $urls]
    foreach p $procs {
        set p [string trimleft $p :]
        api_add_to_proc_doc -proc_name $p -property testcase -value [list $testcase_id $package_key]
        #ns_log notice "TESTCASE: api_add_to_proc_doc -proc_name $p -property testcase -value $testcase_id -> [dict get [nsv_get api_proc_doc $p] testcase]"
    }
    #
    # First, search the current list of test cases. If an old version already
    # exists, replace it with the new version.
    #
    set lpos 0
    set found_pos -1
    foreach case [nsv_get aa_test cases] {
        if {[lindex $case 0] == $testcase_id
            && [lindex $case 3] == $package_key
        } {
            nsv_set aa_test cases [lreplace [nsv_get aa_test cases] $lpos $lpos  $test_case_list]
            set found_pos $lpos
            break
        }
        incr lpos
    }
    #
    # If we haven't already replaced an existing entry, append the new
    # entry to the list.
    #
    if {$found_pos == -1} {
        nsv_lappend aa_test cases $test_case_list
    }

    if { $case_error ne "" } {

        # we don't source this file but insert a little warning text
        # into the procs body. There seems to be no better way to
        # indicate that this test should be skipped.

        d_proc -private _${package_key}__$testcase_id {} "
          # make sure errorlevel gets through. this is not 100% cleaned up.
          global error_level
          set error_level $error_level
          aa_log_result $error_level \{${case_error}\}"
        return
    }

    if {[llength $init_classes] == 0} {
        set init_class_code ""
    } else {
        set init_class_code [string map [
        list @init_classes@ [list $init_classes] @package_key@ [list $package_key]] {
            upvar 2 _aa_exports _aa_exports
            foreach init_class @init_classes@ {
                if {[llength $init_class] == 2} {
                    lassign $init_class init_class init_package_key
                } else {
                    set init_package_key @package_key@
                }
                foreach v $_aa_exports([list $init_package_key $init_class]) {
                    upvar 2 $v $v
                }
                foreach logpair $::aa_init_class_logs([list $init_package_key $init_class]) {
                    aa_log_result [lindex $logpair 0] [lindex $logpair 1]
                }
            }
        }]
    }

    set body [string map [list @init_class_code@ $init_class_code @args@ [list $args] @testcase_id@ [list $testcase_id]] {
        @init_class_code@
        set _aa_export {}
        set body_count 1
        foreach testcase_body @args@ {
          aa_log "Running testcase body $body_count"
          set ::__aa_test_indent [info level]
          set catch_val [catch $testcase_body msg]
          if {$catch_val != 0 && $catch_val != 2} {
              aa_log_result "fail" "@testcase_id@ (body $body_count): Error during execution: $msg, stack trace: \n$::errorInfo"
          }
          incr body_count
        }
    }]

    d_proc -private _${package_key}__$testcase_id {} $body
    ns_log Debug "aa_register_case: Registered test case $testcase_id in package $package_key"

XQL Not present:

Generic, PostgreSQL, Oracle

[ hide source ] | [ make this the default ]