Index: openacs-4/packages/acs-tcl/tcl/object-type-procs-postgresql.xql
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/object-type-procs-postgresql.xql,v
diff -u -r1.7.20.1 -r1.7.20.2
--- openacs-4/packages/acs-tcl/tcl/object-type-procs-postgresql.xql	11 Dec 2019 16:35:11 -0000	1.7.20.1
+++ openacs-4/packages/acs-tcl/tcl/object-type-procs-postgresql.xql	8 Aug 2022 14:48:48 -0000	1.7.20.2
@@ -33,14 +33,14 @@
 
 <fullquery name="acs_object_type::supertypes.supertypes">
       <querytext>
-        select o2.object_type
-          from acs_object_types o1,
-               acs_object_types o2
-         where o1.object_type = :subtype
-           and o2.tree_sortkey < o1.tree_sortkey
-           and o1.tree_sortkey between o2.tree_sortkey
-                                   and tree_right(o2.tree_sortkey)
-         order by tree_level(o2.tree_sortkey) desc
+      WITH RECURSIVE supertypes AS (
+          select supertype as object_type from acs_object_types
+          where object_type = :subtype
+      UNION
+          select ot.supertype as object_type
+          from supertypes s, acs_object_types ot
+          where ot.object_type = s.object_type and ot.supertype is not NULL
+      ) SELECT object_type from supertypes;
       </querytext>
 </fullquery>
 
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 -r1.15.2.1 -r1.15.2.2
--- openacs-4/packages/acs-tcl/tcl/object-type-procs.tcl	8 Aug 2022 11:01:07 -0000	1.15.2.1
+++ openacs-4/packages/acs-tcl/tcl/object-type-procs.tcl	8 Aug 2022 14:48:48 -0000	1.15.2.2
@@ -99,14 +99,14 @@
     {-supertype:required}
     {-subtype:required}
 } {
-    Returns true if subtype is equal to, or a subtype of, supertype.
+    Returns true if subtype is equal to, or a subtype of supertype.
 
     @author Lee Denison (lee@thaum.net)
 } {
-    set supertypes [object_type::supertypes]
-    append supertypes $subtype
+    set supertypes [acs_object_type::supertypes -subtype $subtype]
+    lappend supertypes $subtype
 
-    return [expr {[lsearch $supertypes $supertype] >= 0}]
+    return [expr {$supertype in $supertypes}]
 }
 
 ad_proc -private acs_object_type::supertypes {
@@ -122,9 +122,9 @@
     } else {
         return [acs::per_thread_cache eval \
                     -key acs-tcl.acs_object_type.supertypes($subtype) {
-                        util_memoize [list acs_object_type::supertypes \
-                                          -subtype $subtype \
-                                          -no_cache]
+                        acs_object_type::supertypes \
+                            -subtype $subtype \
+                            -no_cache
                     }]
     }
 }
Index: openacs-4/packages/acs-tcl/tcl/test/object-test-case-procs.tcl
===================================================================
RCS file: /usr/local/cvsroot/openacs-4/packages/acs-tcl/tcl/test/object-test-case-procs.tcl,v
diff -u -r1.9.2.8 -r1.9.2.9
--- openacs-4/packages/acs-tcl/tcl/test/object-test-case-procs.tcl	8 Aug 2022 11:01:07 -0000	1.9.2.8
+++ openacs-4/packages/acs-tcl/tcl/test/object-test-case-procs.tcl	8 Aug 2022 14:48:48 -0000	1.9.2.9
@@ -168,6 +168,7 @@
 } -procs {
     acs_object::is_type_p
     acs_object_type::supertypes
+    acs_object_type::supertype
 } is_object_type_p {
     Test the acs_object::is_type_p proc.
 } {
@@ -187,6 +188,14 @@
         aa_true "Is $object_id an acs_object?" \
             [acs_object::is_type_p -object_id $object_id -object_type acs_object]
 
+        aa_section "Supertypes"
+        aa_true "true supertype" \
+            [acs_object_type::supertype -supertype acs_object -subtype user]
+        aa_true "equlas supertype" \
+            [acs_object_type::supertype -supertype user -subtype user]
+        aa_false "false supertype" \
+            [acs_object_type::supertype -supertype user -subtype party]
+
         aa_section "Fetch an existing user"
         set object_id [db_string q {select max(user_id) from users}]
         aa_true "Is $object_id a user?" \