poet-commit Mailing List for Poet

SourceForge Headquarters 1320 Columbia Street Suite 310 San Diego, CA 92101 +1 (858) 422-6466

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.




2007	Jan	Feb	Mar	Apr	May	Jun	Jul	Aug	Sep (10)	Oct (7)	Nov	Dec
2008	Jan (15)	Feb (1)	Mar	Apr (2)	May	Jun	Jul	Aug (1)	Sep	Oct (6)	Nov (11)	Dec (1)

poet-commit Mailing List for Poet

poet-commit — Changes sent to Subversion