[Poet-commit] SF.net SVN: poet:[56] trunk/lib

[<mer...@us...>]

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.