Index: openacs-4/packages/acs-tcl/tcl/object-type-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/object-type-procs.tcl,v
diff -u -N -r1.4 -r1.5
--- openacs-4/packages/acs-tcl/tcl/object-type-procs.tcl	10 Nov 2003 12:35:13 -0000	1.4
+++ openacs-4/packages/acs-tcl/tcl/object-type-procs.tcl	3 Apr 2005 09:33:55 -0000	1.5
@@ -94,3 +94,41 @@
         where  object_type = :object_type
     } -column_array row
 }
+
+ad_proc -private acs_object_type::acs_object_instance_of {
+    {-object_id:required}
+    {-type:required}
+} {
+    Returns true if the specified object_id is a subtype of the specified type.
+    This is an inclusive check.
+
+    @author Lee Denison (lee@thaum.net)
+} {
+    acs_object::get -object_id $object_id -array obj
+
+    return [acs_object_type::supertype \
+        -supertype $type \
+        -subtype $obj(object_type)]
+}
+
+ad_proc -private acs_object_type::supertype {
+    {-supertype:required}
+    {-subtype:required}
+    {-no_cache:boolean}
+} {
+    Returns true if subtype is equal to, or a subtype of, supertype.
+
+    @author Lee Denison (lee@thaum.net)
+} {
+    if {$no_cache_p} {
+        set supertypes [db_list supertypes {}]
+
+        return [expr {[lsearch $supertypes $supertype] >= 0}]
+    } else {
+        return [util_memoize [list acs_object_type::supertype \
+            -supertype $supertype \
+            -subtype $subtype \
+            -no_cache]]
+    }
+}
+