[Poet-commit] SF.net SVN: poet:[56] trunk/lib
Brought to you by:
mercurio
|
From: <mer...@us...> - 2008-12-13 07:33:36
|
Revision: 56
http://poet.svn.sourceforge.net/poet/?rev=56&view=rev
Author: mercurio
Date: 2008-12-13 07:33:33 +0000 (Sat, 13 Dec 2008)
Log Message:
-----------
Added a couple of debugging methods to ThingPool
Modified Paths:
--------------
trunk/lib/tier1/tier1-thingpool.tcl
trunk/lib/version.tcl
Modified: trunk/lib/tier1/tier1-thingpool.tcl
===================================================================
--- trunk/lib/tier1/tier1-thingpool.tcl 2008-11-17 02:39:37 UTC (rev 55)
+++ trunk/lib/tier1/tier1-thingpool.tcl 2008-12-13 07:33:33 UTC (rev 56)
@@ -356,13 +356,16 @@
return [expr {$result - [Thing_AnonCounter slot nDel] - 1}]
}
-# Output a report of the anonymous objects currently,
+# Output a report of the anonymous objects,
# both loaded and not loaded.
# If the proc ``operation`` is provided, invoke it on all
# not loaded (but loadable) objects. ``operation`` should
# take two arguments, the first is ``fp`` and the second
# is the loadable object.
#
+# This is a snapshot of the current pool, not what's saved
+# to disk.
+#
ThingPool method anonReport {{fp stdout} {operation ""}} {
set n [Thing_AnonCounter slot n]
set nDel [Thing_AnonCounter slot nDel]
@@ -392,3 +395,74 @@
puts $fp ""
}
}
+
+# Output a report on the contents of memory vs. the contents
+# of the repository.
+#
+# If ``tryToLoad`` is true, we attempt to load any objects
+# that are in the index but don't exist.
+#
+ThingPool method poolReport {{tryToLoad 0} {fp stdout}} {
+ set dir [$self slot dir]
+ set indexFile [file join $dir tclIndex]
+
+ set x [list]
+
+ set in [open $indexFile]
+ foreach line [split [read $in] \n] {
+ if {[regexp {set auto_index\(([^)]*)\).*$} $line -> obj]} {
+ set mom unknown
+ regexp {.*# parent: (.*)$} $line -> mom
+
+ if {[Object exists $obj]} {
+ puts $fp "+ $obj ($mom)"
+ } else {
+ if {$tryToLoad} {
+ if {[catch {$obj}]} {
+ puts $fp "- $obj ($mom)"
+ } else {
+ puts $fp "! $obj ($mom)"
+ }
+ } else {
+ puts $fp "- $obj ($mom)"
+ }
+ }
+ }
+ }
+
+ close $in
+}
+
+# Clean the pool of objects in the index but not loaded.
+# This should only be used when everything you need is
+# already loaded, and what's left should have been deleted
+# by other code.
+#
+# Note that the object has to be loaded to delete it.
+#
+ThingPool method cleanPool {} {
+ set dir [$self slot dir]
+ set indexFile [file join $dir tclIndex]
+
+ set x [list]
+
+ set in [open $indexFile]
+ foreach line [split [read $in] \n] {
+ if {[regexp {set auto_index\(([^)]*)\).*$} $line -> obj]} {
+ set mom unknown
+ regexp {.*# parent: (.*)$} $line -> mom
+
+ if {![Object exists $obj]} {
+ puts "Attempting to load $obj"
+ if {![catch {$obj}]} {
+ $obj destruct
+ puts "$obj destroyed"
+ } else {
+ puts "... failed"
+ }
+ }
+ }
+ }
+
+ close $in
+}
Modified: trunk/lib/version.tcl
===================================================================
--- trunk/lib/version.tcl 2008-11-17 02:39:37 UTC (rev 55)
+++ trunk/lib/version.tcl 2008-12-13 07:33:33 UTC (rev 56)
@@ -1 +1 @@
-set ::Poet::version 2.2.0
+set ::Poet::version 2.2.1
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|