From: Eden Cardim <edencardim@gmail.com>
Date: Fri, 17 Aug 2012 14:20:25 +0000 (-0300)
Subject: final fixes for live reference objects as opposed to the clones which were being... 
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f3f2662494803d7ed93ab116bd118f86aa667ce2;p=scpubgit%2Fstemmatology.git

final fixes for live reference objects as opposed to the clones which were being created by the optimization

Conflicts:

	lib/Text/Tradition/Directory.pm
	lib/Text/Tradition/Parser/Self.pm
---

diff --git a/lib/Text/Tradition/Directory.pm b/lib/Text/Tradition/Directory.pm
index 311088a..51a4b89 100644
--- a/lib/Text/Tradition/Directory.pm
+++ b/lib/Text/Tradition/Directory.pm
@@ -12,7 +12,9 @@ use Text::Tradition::Error;
 
 ## users
 use KiokuX::User::Util qw(crypt_password);
+use Text::Tradition::Store;
 use Text::Tradition::User;
+use Text::Tradition::TypeMap::Entry;
 
 extends 'KiokuX::Model';
 
@@ -189,10 +191,20 @@ has +typemap => (
   default => sub {
     KiokuDB::TypeMap->new(
       isa_entries => {
+	# now that we fall back to YAML deflation, all attributes of
+	# Text::Tradition will be serialized to YAML as individual objects
+	# Except if we declare a specific entry type here
         "Text::Tradition" =>
-          Text::Tradition::TypeMap::Entry->new(),
-        "Graph" => Text::Tradition::TypeMap::Entry->new(),
-        "Graph::AdjacencyMap" => Text::Tradition::TypeMap::Entry->new(),
+          KiokuDB::TypeMap::Entry::MOP->new(),
+	# We need users to be naive entries so that they hold
+	# references to the original tradition objects, not clones
+        "Text::Tradition::User" =>
+          KiokuDB::TypeMap::Entry::MOP->new(),
+        "Text::Tradition::Collation" =>
+          KiokuDB::TypeMap::Entry::MOP->new(),
+        "Text::Tradition::Witness" =>
+          KiokuDB::TypeMap::Entry::MOP->new(),
+        "Graph" => Text::Tradition::TypeMap::Entry->new()
         "Set::Scalar" => Text::Tradition::TypeMap::Entry->new(),
       }
     );
@@ -209,22 +221,34 @@ around BUILDARGS => sub {
 	} else {
 		$args = { @_ };
 	}
+	my @column_args;
 	if( $args->{'dsn'} =~ /^dbi/ ) { # We're using Backend::DBI
-		my @column_args = ( 'columns',
+		@column_args = ( 'columns',
 			[ 'name' => { 'data_type' => 'varchar', 'is_nullable' => 1 } ] );
-		my $ea = $args->{'extra_args'};
-		if( ref( $ea ) eq 'ARRAY' ) {
-			push( @$ea, @column_args );
-		} elsif( ref( $ea ) eq 'HASH' ) {
-			$ea = { %$ea, @column_args };
-		} else {
-			$ea = { @column_args };
-		}
-		$args->{'extra_args'} = $ea;
 	}
+	my $ea = $args->{'extra_args'};
+	if( ref( $ea ) eq 'ARRAY' ) {
+		push( @$ea, @column_args );
+	} elsif( ref( $ea ) eq 'HASH' ) {
+		$ea = { %$ea, @column_args };
+	} else {
+		$ea = { @column_args };
+	}
+	$args->{'extra_args'} = $ea;
+
 	return $class->$orig( $args );
 };
 
+override _build_directory => sub {
+  my($self) = @_;
+  Text::Tradition::Store->connect(@{ $self->_connect_args },
+    resolver_constructor => sub {
+      my($class) = @_;
+      $class->new({ typemap => $self->directory->merged_typemap,
+                    fallback_entry => Text::Tradition::TypeMap::Entry->new() });
+  });
+};
+
 ## These checks don't cover store($id, $obj)
 # before [ qw/ store update insert delete / ] => sub {
 before [ qw/ delete / ] => sub {
diff --git a/lib/Text/Tradition/Parser/Self.pm b/lib/Text/Tradition/Parser/Self.pm
index 51c49aa..92ec2a1 100644
--- a/lib/Text/Tradition/Parser/Self.pm
+++ b/lib/Text/Tradition/Parser/Self.pm
@@ -229,13 +229,13 @@ sub parse {
     	# If it is the start or end node, we already have one, so
     	# grab the rank and go.
         if( defined $n->{'is_start'} ) {
-	  warn Data::Dump::dump($n);
-	  warn $collation->start->id;
+#	  warn Data::Dump::dump($n);
+#	  warn $collation->start->id;
 	  $collation->start->rank($n->{'rank'});
           next;
         }
     	if( defined $n->{'is_end'} ) {
-	  warn Data::Dump::dump($n);
+#	  warn Data::Dump::dump($n);
     		$collation->end->rank( $n->{'rank'} );
     		next;
     	}
diff --git a/lib/Text/Tradition/Store.pm b/lib/Text/Tradition/Store.pm
new file mode 100644
index 0000000..39c31ae
--- /dev/null
+++ b/lib/Text/Tradition/Store.pm
@@ -0,0 +1,19 @@
+package Text::Tradition::Store;
+use Moose;
+use Class::Load ();
+extends 'KiokuDB';
+
+has resolver_class =>
+  ( is => 'rw', isa => 'Str', default => 'KiokuDB::TypeMap::Resolver' );
+has resolver_constructor =>
+  ( is => 'rw', isa => 'Str|CodeRef', default => 'new' );
+
+override _build_typemap_resolver => sub {
+  my ($self) = @_;
+  my $rclass = $self->resolver_class;
+  Class::Load::load_class($rclass);
+  my $meth = $self->resolver_constructor;
+  return $rclass->$meth;
+};
+
+1;
diff --git a/lib/Text/Tradition/TypeMap/Entry.pm b/lib/Text/Tradition/TypeMap/Entry.pm
index 00cdfd1..50dfb51 100644
--- a/lib/Text/Tradition/TypeMap/Entry.pm
+++ b/lib/Text/Tradition/TypeMap/Entry.pm
@@ -16,7 +16,6 @@ sub compile_collapse_body {
         my ( $self, %args ) = @_;
 
         my $object = $args{object};
-
         return $self->make_entry(
             %args,
             data => YAML::XS::Dump($object)
@@ -29,9 +28,9 @@ sub compile_expand {
 
     return sub {
         my ( $self, $entry ) = @_;
-        $self->inflate_data( YAML::XS::Load($entry->data), \( my $obj ), $entry );
-
+	$self->inflate_data( YAML::XS::Load($entry->data), \(my $obj), $entry );
         bless $obj, $class;
+	return $obj;
     };
 }
 
diff --git a/t/load-save-speed.t b/t/load-save-speed.t
index 57aa714..ad4bf53 100644
--- a/t/load-save-speed.t
+++ b/t/load-save-speed.t
@@ -11,6 +11,7 @@ use File::Path 'mkpath';
 use Text::Tradition;
 use Text::Tradition::Directory;
 use Test::More;
+use Test::Memory::Cycle;
 
 ## Don't run this test when running make test or prove, to run it use perl -Ilib t/load-save-speed.t
 
@@ -28,7 +29,7 @@ my $test_name = 'besoin';
 my $benchmark_file = 't/data/load-save-benchmark.json';
 
 ## SQL file (previously dumped KiokuDB) for testing tradition directory loading:
-my $load_sql = 't/data/speed_test_load.sql';
+# my $load_sql = 't/data/speed_test_load.sql';
 
 ## uuid to load from the above stored db:
 my $load_uuid = 'load-test';
@@ -61,12 +62,13 @@ $tradition->add_stemma(dotfile => "t/data/${test_name}.dot");
 #$fh->close;
 ## use t/var so you can look at the results after if neccessary:
 
-my $load_db = 't/var/speed_test_load.db';
-unlink($load_db) if(-e $load_db);
-my $load_dsn = "dbi:SQLite:dbname=$load_db";
+#my $load_db = 't/var/speed_test_load.db';
+#unlink($load_db) if(-e $load_db);
+#my $load_dsn = "dbi:SQLite:dbname=$load_db";
 ## Prime db from .sql file:
 ## ?? fails
-`sqlite3 $load_db < $load_sql`;
+
+#`sqlite3 $load_db < $load_sql`;
 
 my $save_db = 't/var/speed_test_save.db';
 unlink($save_db) if(-e $save_db);
@@ -85,21 +87,20 @@ my $test_save = sub {
     my $scope = $dir->new_scope;
 
     ## save the tradition (with stemma) to the db:
-    my $uuid = $dir->save($tradition);
+    $dir->save($load_uuid => $tradition);
 #    print STDERR "UUID: $uuid\n";
 
 };
 
-my $load_tradition;
 my $test_load = sub {
     my $dir = Text::Tradition::Directory->new(
-        dsn => $load_dsn,
+        dsn => $save_dsn,
     );
 
     ## This seems to be a required magic incantation:
     my $scope = $dir->new_scope;
-
-    $load_tradition = $dir->tradition($load_uuid);
+    my $t = $dir->tradition($load_uuid);
+    return $t;
 #    print STDERR $load_tradition->name, $tradition->name, "\n";
 };
 
@@ -112,24 +113,24 @@ if(!$last_benchmark) {
 }
 
 
-## Benchmark current code:
-## Should probably run the test the same number of times as the last time it ran
-## Or compare results more sanely
+# Benchmark current code:
+# Should probably run the test the same number of times as the last time it ran
+# Or compare results more sanely
 my $new_save_result = timethis(5, $test_save);
 
 my $new_save = $new_save_result->[1] + $new_save_result->[2];
-use Data::Dump;
+#use Data::Dump;
 
 my $old_save = $last_benchmark->{save_times}[1] + $last_benchmark->{save_times}[2];
 ok( $new_save < $old_save, "Saving to a Tradition Directory got faster: $new_save vs $old_save");
 
-my $new_load_result = timethis(20, $test_load);
+my $new_load_result = timethis(5, $test_load);
 
 my $new_load = $new_load_result->[1] + $new_load_result->[2];
 my $old_load = $last_benchmark->{load_times}[1] + $last_benchmark->{load_times}[2];
 ok($new_load < $old_load, "Loading from a Tradition Directory got faster: $new_load vs $old_load");
 
-$test_load->();
+my $load_tradition = $test_load->();
 isa_ok($load_tradition, 'Text::Tradition');
 ok($load_tradition->collation->as_svg());
 
@@ -144,7 +145,7 @@ if($git_hash) {
     save_benchmark($benchmark_file, $benchmark_data);
 }
 
-## -----------------------------------------------------------------------------
+# -----------------------------------------------------------------------------
 
 sub load_benchmark {
     my ($filename) = @_;