From: Brandon Black <blblack@gmail.com>
Date: Sat, 14 Apr 2007 20:12:50 +0000 (+0000)
Subject: more dumping tests
X-Git-Tag: 0.03999_01~1
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a4187fdf58a28e2ec8a4905b2164c3a6ec297fa9;p=dbsrgits%2FDBIx-Class-Schema-Loader.git

more dumping tests
---

diff --git a/t/23dumpmore.t b/t/23dumpmore.t
index d41fb66..beb1cdd 100644
--- a/t/23dumpmore.t
+++ b/t/23dumpmore.t
@@ -5,44 +5,169 @@ use File::Path;
 use make_dbictest_db;
 require DBIx::Class::Schema::Loader;
 
-plan tests => 5;
+plan tests => 40;
 
-plan skip_all => "ActiveState perl produces additional warnings"
+plan skip_all => "ActiveState perl produces additional warnings, and this test uses unix paths"
     if ($^O eq 'MSWin32');
 
-my $dump_path = './t/_dump';
+my $DUMP_PATH = './t/_dump';
 
 sub do_dump_test {
-    my ($schema_class, $opts) = @_;
+    my %tdata = @_;
 
-    rmtree($dump_path, 1, 1);
+    my $schema_class = $tdata{classname};
 
     no strict 'refs';
     @{$schema_class . '::ISA'} = ('DBIx::Class::Schema::Loader');
-    $schema_class->loader_options(dump_directory => $dump_path, %$opts);
+    $schema_class->loader_options(dump_directory => $DUMP_PATH, %{$tdata{options}});
 
-    my @warn_output;
+    my @warns;
     eval {
-        local $SIG{__WARN__} = sub { push(@warn_output, @_) };
+        local $SIG{__WARN__} = sub { push(@warns, @_) };
         $schema_class->connect($make_dbictest_db::dsn);
     };
     my $err = $@;
     $schema_class->storage->disconnect if !$err && $schema_class->storage;
     undef *{$schema_class};
-    return ($err, \@warn_output);
+
+    is($err, $tdata{error});
+
+    my $check_warns = $tdata{warnings};
+    is(@warns, @$check_warns);
+    for(my $i = 0; $i <= $#$check_warns; $i++) {
+        like($warns[$i], $check_warns->[$i]);
+    }
+
+    my $file_regexes = $tdata{regexes};
+    my $file_neg_regexes = $tdata{neg_regexes} || {};
+    my $schema_regexes = delete $file_regexes->{schema};
+    
+    my $schema_path = $DUMP_PATH . '/' . $schema_class;
+    $schema_path =~ s{::}{/}g;
+    dump_file_like($schema_path . '.pm', @$schema_regexes);
+    foreach my $src (keys %$file_regexes) {
+        my $src_file = $schema_path . '/' . $src . '.pm';
+        dump_file_like($src_file, @{$file_regexes->{$src}});
+    }
+    foreach my $src (keys %$file_neg_regexes) {
+        my $src_file = $schema_path . '/' . $src . '.pm';
+        dump_file_not_like($src_file, @{$file_neg_regexes->{$src}});
+    }
 }
 
+sub dump_file_like {
+    my $path = shift;
+    open(my $dumpfh, '<', $path) or die "Failed to open '$path': $!";
+    my $contents = do { local $/; <$dumpfh>; };
+    close($dumpfh);
+    like($contents, $_) for @_;
+}
 
-{
-    my ($err, $warn) = do_dump_test('DBICTest::Schema::1', { });
-    ok(!$err);
-    is(@$warn, 2);
-    like($warn->[0], qr/Dumping manual schema for DBICTest::Schema::1 to directory /);
-    like($warn->[1], qr/Schema dump completed/);
+sub dump_file_not_like {
+    my $path = shift;
+    open(my $dumpfh, '<', $path) or die "Failed to open '$path': $!";
+    my $contents = do { local $/; <$dumpfh>; };
+    close($dumpfh);
+    unlike($contents, $_) for @_;
 }
 
-ok(1);
+sub append_to_class {
+    my ($class, $string) = @_;
+    $class =~ s{::}{/}g;
+    $class = $DUMP_PATH . '/' . $class . '.pm';
+    open(my $appendfh, '>>', $class) or die "Failed to open '$class' for append: $!";
+    print $appendfh $string;
+    close($appendfh);
+}
+
+rmtree($DUMP_PATH, 1, 1);
+
+do_dump_test(
+    classname => 'DBICTest::DumpMore::1',
+    options => { },
+    error => '',
+    warnings => [
+        qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
+        qr/Schema dump completed/,
+    ],
+    regexes => {
+        schema => [
+            qr/package DBICTest::DumpMore::1;/,
+            qr/->load_classes/,
+        ],
+        Foo => [
+            qr/package DBICTest::DumpMore::1::Foo;/,
+            qr/->set_primary_key/,
+            qr/1;\n$/,
+        ],
+        Bar => [
+            qr/package DBICTest::DumpMore::1::Bar;/,
+            qr/->set_primary_key/,
+            qr/1;\n$/,
+        ],
+    },
+);
+
+append_to_class('DBICTest::DumpMore::1::Foo',q{# XXX This is my custom content XXX});
+
+do_dump_test(
+    classname => 'DBICTest::DumpMore::1',
+    options => { },
+    error => '',
+    warnings => [
+        qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
+        qr/Schema dump completed/,
+    ],
+    regexes => {
+        schema => [
+            qr/package DBICTest::DumpMore::1;/,
+            qr/->load_classes/,
+        ],
+        Foo => [
+            qr/package DBICTest::DumpMore::1::Foo;/,
+            qr/->set_primary_key/,
+            qr/1;\n# XXX This is my custom content XXX/,
+        ],
+        Bar => [
+            qr/package DBICTest::DumpMore::1::Bar;/,
+            qr/->set_primary_key/,
+            qr/1;\n$/,
+        ],
+    },
+);
 
-# XXX obviously this test file needs to be fleshed out more :)
+do_dump_test(
+    classname => 'DBICTest::DumpMore::1',
+    options => { dump_overwrite => 1 },
+    error => '',
+    warnings => [
+        qr/Dumping manual schema for DBICTest::DumpMore::1 to directory /,
+        qr/Deleting existing file /,
+        qr/Deleting existing file /,
+        qr/Deleting existing file /,
+        qr/Schema dump completed/,
+    ],
+    regexes => {
+        schema => [
+            qr/package DBICTest::DumpMore::1;/,
+            qr/->load_classes/,
+        ],
+        Foo => [
+            qr/package DBICTest::DumpMore::1::Foo;/,
+            qr/->set_primary_key/,
+            qr/1;\n$/,
+        ],
+        Bar => [
+            qr/package DBICTest::DumpMore::1::Bar;/,
+            qr/->set_primary_key/,
+            qr/1;\n$/,
+        ],
+    },
+    neg_regexes => {
+        Foo => [
+            qr/# XXX This is my custom content XXX/,
+        ],
+    },
+);
 
-# END { rmtree($dump_path, 1, 1); }
+END { rmtree($DUMP_PATH, 1, 1); }