Index: openacs-4/packages/xotcl-core/xotcl-core.info =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/xotcl-core.info,v diff -u -r1.106.2.54 -r1.106.2.55 --- openacs-4/packages/xotcl-core/xotcl-core.info 26 Jan 2024 16:37:28 -0000 1.106.2.54 +++ openacs-4/packages/xotcl-core/xotcl-core.info 19 Aug 2024 17:07:35 -0000 1.106.2.55 @@ -10,7 +10,7 @@ t xotcl - + Gustaf Neumann XOTcl library functionality (e.g. thread handling, online documentation, Generic Form and List Classes) 2024-01-26 @@ -42,7 +42,7 @@ BSD-Style 2 - + Index: openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl,v diff -u -r1.93.2.71 -r1.93.2.72 --- openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 5 Apr 2024 08:28:21 -0000 1.93.2.71 +++ openacs-4/packages/xotcl-core/tcl/01-debug-procs.tcl 19 Aug 2024 17:07:35 -0000 1.93.2.72 @@ -726,12 +726,13 @@ } proc ::xo::stats {{msg ""}} { - set xobjs [llength [::xotcl::Object info instances -closure]] - set nobjs [llength [::nx::Object info instances -closure]] - set tmpObjs [llength [info commands ::nsf::__#*]] - set tdoms [llength [list {*}[info commands domNode0*] {*}[info commands domDoc0x*]]] - set nssets [expr {[acs::icanuse "ns_set stats"] ? [list [ns_set stats]] : [llength [ns_set list]]}] - ns_log notice "xo::stats $msg: current objects xotcl $xobjs nx $nobjs tmp $tmpObjs tDOM $tdoms ns_set $nssets" + dict set stats xotcl [llength [::xotcl::Object info instances -closure]] + dict set stats nx [llength [::nx::Object info instances -closure]] + dict set stats tmpObjs [llength [info commands ::nsf::__#*]] + dict set stats tdom [llength [list {*}[info commands domNode0*] {*}[info commands domDoc0x*]]] + dict set stats nssets [expr {[acs::icanuse "ns_set stats"] ? [list [ns_set stats]] : [llength [ns_set list]]}] + ns_log notice "xo::stats $msg: $stats" + return $stats } # Index: openacs-4/packages/xotcl-core/tcl/test/xotcl-test-procs.tcl =================================================================== RCS file: /usr/local/cvsroot/openacs-4/packages/xotcl-core/tcl/test/xotcl-test-procs.tcl,v diff -u -r1.1.2.32 -r1.1.2.33 --- openacs-4/packages/xotcl-core/tcl/test/xotcl-test-procs.tcl 14 Jun 2023 08:40:23 -0000 1.1.2.32 +++ openacs-4/packages/xotcl-core/tcl/test/xotcl-test-procs.tcl 19 Aug 2024 17:07:35 -0000 1.1.2.33 @@ -2,26 +2,32 @@ Test xotcl-core features } -# -# This test could be used to make sure binaries in use in the code are -# actually available to the system. -# -# aa_register_case -cats { -# smoke production_safe -# } -procs { -# util::which -# apm_tar_cmd -# apm_gzip_cmd -# } xotcl_core_exec_dependencies { -# Test external command dependencies for this package. -# } { -# foreach cmd [list \ -# [::util::which dot] \ -# ] { -# aa_true "'$cmd' is executable" [file executable $cmd] -# } -# } +ad_proc ::xo::aa_check_leftovers {} { + # + # Perform cleanup tests to check for object/command leaks in + # either the called functions or in the test itself. + # +} { + set stats [::xo::stats] + dict with stats { + aa_equals "leftover temp objects" $tmpObjs 0 + if {$tmpObjs > 0} { + foreach obj [info commands ::nsf::__#*] { + set isXotcl [::nsf::dispatch $obj ::nsf::methods::object::info::hastype ::xotcl::Object] + set isNx [::nsf::dispatch $obj ::nsf::methods::object::info::hastype ::nx::Object] + aa_log obj $obj (isXotcl $isXotcl isNx $isNx) + aa_log 
[$obj serialize]
+ } + } + aa_equals "leftover tdom cmds" $tdom 0 + + aa_log "final xotcl objects: $xotcl" + aa_log "final nx objects: $nx" + aa_log "final nssets: $nssets" + } +} + aa_register_case -cats { api smoke } -procs { @@ -51,12 +57,15 @@ set orm_object [::xo::db::Object new] aa_log "Save new" set object_id [$orm_object save_new] + $orm_object destroy + aa_log "Fetch" set orm_object [::xo::db::Class get_instance_from_db -id $object_id] aa_log "Save" $orm_object save aa_log "Delete" $orm_object delete + #$orm_object destroy aa_section "Object creation" aa_log "Create object" @@ -122,7 +131,7 @@ aa_log "Setting a different context_id: $new_context_id" $orm_object set context_id $new_context_id - aa_log "Saving the object" + aa_log "Saving the object $orm_object" $orm_object save @@ -171,7 +180,9 @@ select 1 from acs_objects where object_id = :object_id }] aa_true "Object is not there anymore" {!$orm_exists_p && !$db_exists_p} + } + ::xo::aa_check_leftovers } aa_register_case -cats { @@ -205,14 +216,19 @@ aa_section "Quick trivial CRUD of an object" aa_log "Create object" set orm_object [::xo::db::CrItem new] + aa_log "Save new" set object_id [$orm_object save_new] + $orm_object destroy + aa_log "Fetch" set orm_object [::xo::db::CrClass get_instance_from_db -item_id $object_id] aa_log "Save" $orm_object save + aa_log "Delete" $orm_object delete + $orm_object destroy aa_section "Object creation" aa_log "Create object" @@ -230,11 +246,10 @@ }] aa_true "Object was created" {$orm_exists_p && $db_exists_p} - aa_section "Object fetching" aa_log "Fetching object from ORM" set orm_object [::xo::db::CrClass get_instance_from_db -item_id $object_id] - aa_log "Fetching object from DB" + aa_log "Fetching object from DB ($orm_object)" ::xo::dc 1row get_object_from_db { select creation_date, creation_user, @@ -340,7 +355,6 @@ } } - aa_section "Check modifications AFTER refetching" aa_log "Fetching object again from ORM" set orm_object [::xo::db::CrItem get_instance_from_db -item_id $object_id] @@ -359,7 +373,9 @@ select 1 from acs_objects where object_id = :object_id }] aa_true "Object is not there anymore" {!$orm_exists_p && !$db_exists_p} + } + ::xo::aa_check_leftovers } aa_register_case -cats { Fisheye: Tag 1.1 refers to a dead (removed) revision in file `openacs-4/packages/xotcl-core/tcl/test/zz-final-procs.tcl'. Fisheye: No comparison available. Pass `N' to diff?