Index: openacs-4/packages/acs-tcl/tcl/test/datamodel-test-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/test/datamodel-test-procs.tcl,v
diff -u
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-tcl/tcl/test/datamodel-test-procs.tcl	27 Feb 2005 16:16:17 -0000	1.1
@@ -0,0 +1,149 @@
+ad_library {
+    Sweep the all the files in the system looking for systematic errors.
+
+    @author Jeff Davis
+    @creation-date 2005-02-28
+    @cvs-id $Id: datamodel-test-procs.tcl,v 1.1 2005/02/27 16:16:17 jeffd Exp $
+}
+
+
+aa_register_case -cats {db smoke production_safe} datamodel__named_constraints {
+    Check that there are no tables with unnamed constraints
+
+    @author Jeff Davis davis@xarg.net
+} {
+    switch -exact -- [db_name] {
+        PostgreSQL {
+            db_foreach check_constraints {
+                select relname as table, conname from pg_constraint r join (select relname,oid from pg_class) c on (c.oid = r.conrelid) where
+                not ( conname like '%_pk' or conname like '%_un' or conname like '%_fk' or conname like '%_ck')
+            } {
+                aa_log_result fail "Table $table constraints name $conname violates contraint naming standard"
+            }
+        }
+        default {
+            aa_log "Not run for [db_name]"
+        }
+    }
+}
+
+
+
+aa_register_case -cats {db smoke production_safe} datamodel__acs_object_type_check {
+    Check that the object type tables exist and that th
+
+    @author Jeff Davis davis@xarg.net
+} {
+    db_foreach object_type {select * from acs_object_types} {
+        if {![string eq [string tolower $table_name] $table_name]} {
+            aa_log_result fail "Type $object_type: table_name $table_name mixed case"
+        }
+        if {![string eq [string tolower $id_column] $id_column]} {
+            aa_log_result fail "Type $object_type: id_column $id_column mixed case"
+        }
+        set table_name [string tolower $table_name]
+        set id_column [string tolower $id_column]
+
+        set __pk {}
+        if {![db_table_exists $table_name]} {
+            aa_log_result fail "Type $object_type: table $table_name does not exit"
+        } else {
+            if {[string is space $id_column]} {
+                aa_log_result fail "Type $object_type: id_column not specified"
+            } else {
+                # limit pg only?
+                # we could just check the column exists but since we want to 
+                # check the name method try at least to get a real object_id
+                if {[catch {db_0or1row check_exists "select $id_column as __pk from $table_name limit 1"} errMsg]} { 
+                    aa_log_result fail "Type $object_type: select $id_column from $table_name failed:\n$errMsg"
+                }
+            }
+        }
+
+        if {![string is space $name_method]} {
+            if {![string eq [string tolower $name_method] $name_method]} {
+                aa_log_result fail "Type $object_type: name method $name_method mixed case"
+            }
+            set name_method [string tolower $name_method]
+            if {[string is integer -strict $__pk]} {
+                # intentionally don't use bind variables here which is ok 
+                # since we just checked __pk was an integer
+                if { [catch {db_0or1row name_method "select ${name_method}($__pk) as NAME from dual"} errMsg] } { 
+                    aa_log_result fail "Type $object_type: name method $name_method failed\n$errMsg"
+                }
+            }
+        }
+        if {![string is space $type_extension_table] 
+            && ![db_table_exists $type_extension_table]} { 
+            aa_log_result fail "Type $object_type: type extension table $type_extension_table does not exist"
+        }
+    }
+}
+
+
+
+aa_register_case -cats {db smoke production_safe} datamodel__acs_attribute_check {
+    Check that the object type tables exist and that th
+
+    @author Jeff Davis davis@xarg.net
+} {
+    array set allow_types {
+        string {TEXT VARCHAR CHAR}
+        boolean {BOOL INT2 INT4}
+        number {NUMERIC INT2 INT4 INT8 FLOAT4 FLOAT8}
+        integer {INT2 INT4 INT8}
+        money {NUMERIC FLOAT4 FLOAT8}
+        timestamp {TIMESTAMPTZ}
+        time_of_day {TIMESTAMPTZ}
+        enumeration {INT2 INT4 INT8}
+        url {VARCHAR TEXT}
+        email {VARCHAR TEXT}
+        text  {VARCHAR TEXT CLOB}
+        keyword {CHAR VARCHAR TEXT}
+    }
+
+    db_foreach attribute {select a.*, lower(ot.table_name) as obj_type_table from acs_attributes a, acs_object_types ot where ot.object_type = a.object_type order by object_type} {
+
+        if {![string eq [string tolower $table_name] $table_name]} {
+            aa_log_result fail "Type $object_type attribute $attribute table name $table_name mixed case"
+            set table_name [string tolower $table_name]
+        } elseif {[string is space $table_name]} {
+            set table_name $obj_type_table
+        }
+
+        switch -exact $storage {
+            type_specific {
+                if {![info exists columns($table_name)]} {
+                    set columns($table_name) [db_columns $table_name]
+                }
+
+                if {[string is space $column_name]} {
+                    set column_name $attribute_name
+                }
+
+                if {[lsearch $columns($obj_type_table) $column_name] < 0} {
+                    aa_log_result fail "Type $object_type attribute column $column_name not found in $obj_type_table"
+                } else {
+                    # check the type of the column is vaguely like the acs_datatype type.
+                    if {[info exists allow_types($datatype)]} {
+                        set actual_type [db_column_type $table_name $column_name]
+                        if {$actual_type eq "-1"} {
+                            aa_log_result fail "Type $object_type attribute $attribute_name database type get for ($table_name.$column_name) failed"
+                        } else {
+                            if {[lsearch $allow_types($datatype) $actual_type] < 0} {
+                                aa_log_result fail "Type $object_type attribute $attribute_name database type was $actual_type for $datatype"
+                            }
+                        }
+                    }
+                }
+            }
+            generic {
+                # nothing really to do here...
+            }
+            default {
+                # it was null which is probably not sensible.
+                aa_log_result fail "Type $object_type attribute $attribute storage type null"
+            }
+        }
+    }
+}
Index: openacs-4/packages/acs-tcl/tcl/test/doc-check-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/test/doc-check-procs.tcl,v
diff -u
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ openacs-4/packages/acs-tcl/tcl/test/doc-check-procs.tcl	27 Feb 2005 16:16:17 -0000	1.1
@@ -0,0 +1,78 @@
+ad_library {
+    Check all the proc documentation 
+
+    @author Jeff Davis
+    @creation-date 2005-02-28
+    @cvs-id $Id: doc-check-procs.tcl,v 1.1 2005/02/27 16:16:17 jeffd Exp $
+}
+
+aa_register_case -cats {smoke production_safe} documentation__check_proc_interface_status {
+    checks all procs have an interface status (-public or -private)
+
+    @author Jeff Davis davis@xarg.net
+} {
+    set count 0 
+    set good 0
+    foreach p [lsort -dictionary [nsv_array names api_proc_doc]] {
+        array set pa [nsv_get api_proc_doc $p]
+        if { !($pa(deprecated_p) || $pa(warn_p)) } {
+            incr count
+            if { !($pa(public_p) || $pa(private_p)) } {
+                aa_log_result fail "No interface status for $p"
+            } else {
+                incr good
+            }
+        }
+        array unset pa
+    }
+    aa_log "Found $good good of $count checked"
+}
+
+aa_register_case -cats {smoke production_safe} documentation__check_proc_doc {
+    checks if documentation exists for public procs.
+
+    @author Jeff Davis davis@xarg.net
+} {
+    set count 0
+    set good 0
+    foreach p [lsort -dictionary [nsv_array names api_proc_doc]] {
+        array set pa [nsv_get api_proc_doc $p]
+        if { $pa(public_p)
+             && !($pa(deprecated_p) || $pa(warn_p))
+         } {
+            incr count
+            if { [string is space $pa(main)] } {
+                aa_log_result fail "No documentation for public proc $p"
+            } else {
+                incr good
+            }
+        }
+        array unset pa
+    }
+    aa_log "Found $good good of $count checked"
+}
+
+
+
+aa_register_case -cats {smoke production_safe} documentation__check_deprecated_see {
+    checks if deprecated procs have an @see clause
+
+    @author Jeff Davis davis@xarg.net
+} {
+    set count 0
+    set good 0
+    foreach p [lsort -dictionary [nsv_array names api_proc_doc]] {
+        array set pa [nsv_get api_proc_doc $p]
+        if { $pa(deprecated_p)||$pa(warn_p) } {
+            incr count
+            if { ![info exists pa(see)] || [string is space $pa(see)] } {
+                aa_log_result fail "No @see for deprecated proc $p"
+            } else {
+                incr good
+            }
+        }
+        array unset pa
+    }
+    aa_log "Found $good of $count procs checked"
+}
+
Index: openacs-4/packages/acs-tcl/tcl/test/file-test-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/test/file-test-procs.tcl,v
diff -u -r1.1 -r1.2
--- openacs-4/packages/acs-tcl/tcl/test/file-test-procs.tcl	26 Feb 2005 21:26:45 -0000	1.1
+++ openacs-4/packages/acs-tcl/tcl/test/file-test-procs.tcl	27 Feb 2005 16:16:17 -0000	1.2
@@ -6,7 +6,7 @@
     @cvs-id $Id$
 }
 
-aa_register_case -cats {smoke} acs_tcl__tcl_file_syntax_errors {
+aa_register_case -cats {smoke production_safe} files__tcl_file_syntax_errors {
     Test all known tcl files for successful parsing "(in the [info complete] sense at least)" and other common errors.
 
     @author Jeff Davis davis@xarg.net
@@ -41,7 +41,7 @@
     aa_log "$good good of $nfiles checked"
 }
 
-aa_register_case -cats {} -error_level notice acs_tcl__tcl_file_common_errors {
+aa_register_case -cats {smoke production_safe} -error_level notice files__tcl_file_common_errors {
     Check for some common error patterns 
 
     @author Jeff Davis davis@xarg.net
@@ -69,26 +69,7 @@
     }
 }
 
-aa_register_case -cats {db smoke production_safe} acs-tcl__named_constraints {
-    Check that there are no tables with unnamed constraints
-
-    @author Jeff Davis davis@xarg.net
-} {
-    switch -exact -- [db_name] {
-        PostgreSQL {
-            db_foreach check_constraints {
-                select relname as table from pg_constraint r join (select relname,oid from pg_class) c on (c.oid = r.conrelid) where conname like '$%'
-            } {
-                aa_true "Table $table constraints named" [string is space $table]
-            }
-        }
-        default {
-            aa_log "Not run for [db_name]"
-        }
-    }
-}
-
-aa_register_case -cats {smoke production_safe} acs-tcl__check_info_files {
+aa_register_case -cats {smoke production_safe} files__check_info_files {
     Check that all the info files parse correctly
 
     @author Jeff Davis davis@xarg.net
@@ -137,7 +118,7 @@
     }
 }
 
-aa_register_case -cats {smoke production_safe} acs-tcl__check_upgrade_ordering { 
+aa_register_case -cats {smoke production_safe} files__check_upgrade_ordering { 
     Check that all the upgrade files are well ordered (non-overlapping and v1 > v2)
 
     @author Jeff Davis davis@xarg.net
@@ -195,9 +176,11 @@
 
 
 
-aa_register_case -cats {smoke} acs_tcl__check_xql_files {
+aa_register_case -cats {smoke} files__check_xql_files {
     Check for some common errors in the xql files.
 
+    Not production safe since malformed xql can crass aolserver in the parse.
+
     @author Jeff Davis davis@xarg.net
 } {
     # couple of local helper procs 
@@ -238,57 +221,57 @@
 
         regexp {(.*)[.]xql$} $file match base
 
-        if {![file exists ${base}.tcl] && ![file exists ${base}.vuh]} {
 
+        if {![file exists ${base}.tcl] && ![file exists ${base}.vuh]} {
             # the file did not exist so we must have a -db extension...
             regexp {(.*?)(-)?([A-Za-z_]*)[.]xql$} $file match base dummy db
             ns_log debug "JCD: acs_tcl__check_xql_files: $db $base from $file"
             if { ![empty_string_p $db]
                  && ![string match $db oracle]
                  && ![string match $db postgresql] } {
-                aa_log_result fail "bad db name $db file $file (or maybe .tcl or .vuh missing)"
+                aa_log_result fail "bad db name \"$db\" file $file (or maybe .tcl or .vuh missing)"
             } elseif { ![empty_string_p $db]
                        && ![regexp $db $data] } {
-                aa_log_result fail "rdbms $db missing $file"
-
+                aa_log_result fail "rdbms \"$db\" missing $file"
             } elseif {[empty_string_p $db]
                       && [regexp {<rdbms>} $data] } {
                 aa_log_result fail "rdbms found in generic $file"
-            } else {
-                set allxql($base) 1
             }
 
             if {[string equal $db postgresql] || [empty_string_p $db]} {
                 if {[regexp {(nvl[ ]*\(|decode[ ]*\()} $data]} {
                     aa_log_result fail "postgres or generic with oracle code $file" 
                 }
+                set allxql($base) $file
             } else {
                 if {[regexp {(now[ ]*\()} $data] || [empty_string_p $db]} {
                     aa_log_result fail "oracle or generic with oracle code $file" 
                 }
+                set allxql($base) $file
             }
-
+        } else {
+            set allxql($base) $file
         }
     }
 
     foreach xql [array names allxql] {
         # check there is a corresponding .tcl file
         if {![file exists ${xql}.tcl]
             && ![file exists ${xql}.vuh]} {
-            aa_log_result fail "missing .tcl or .vuh file for $xql" 
+            aa_log_result fail "missing .tcl or .vuh file for $allxql($xql)" 
         }
         if { 0 } { 
             # check that if there is a db specific version that the corresponding
             # generic or other db file exists...
             if {[info exists onexql(${xql}-oracle)]
                 && !([info exists onexql(${xql}-postgresql)]
                      || [info exists onexql(${xql})]) } {
-                aa_log_result fail "No postgresql or generic $xql" 
+                aa_log_result fail "No postgresql or generic $allxql($xql)" 
             }
             if {[info exists onexql(${xql}-postgresql)]
                 && !([info exists onexql(${xql}-oracle)]
                      || [info exists onexql(${xql})]) } {
-                aa_log_result fail "No oracle or generic $xql" 
+                aa_log_result fail "No oracle or generic $allxql($xql)" 
             }
 
         }
Index: openacs-4/packages/acs-tcl/tcl/test/log-test-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/test/log-test-procs.tcl,v
diff -u -r1.2 -r1.3
--- openacs-4/packages/acs-tcl/tcl/test/log-test-procs.tcl	15 Feb 2004 11:15:43 -0000	1.2
+++ openacs-4/packages/acs-tcl/tcl/test/log-test-procs.tcl	27 Feb 2005 16:16:17 -0000	1.3
@@ -5,9 +5,9 @@
     @creation-date 22 January 2003
 }
 
-aa_register_case -cats {smoke} server_error_log {
+aa_register_case -cats {smoke} -error_level warning server_error_log {
     Examine server error log.
-    } {
+} {
     # Log error lines start with something like this:
     # [19/Nov/2003:00:54:45][10491.319494][-conn1-] Error: