[Bast-commits] r4395 - in
branches/DBIx-Class-Schema-Loader/current: . script t
ilmari at dev.catalyst.perl.org
ilmari at dev.catalyst.perl.org
Sat May 24 02:18:27 BST 2008
Author: ilmari
Date: 2008-05-24 02:18:27 +0100 (Sat, 24 May 2008)
New Revision: 4395
Added:
branches/DBIx-Class-Schema-Loader/current/script/
branches/DBIx-Class-Schema-Loader/current/script/dbicdump
Modified:
branches/DBIx-Class-Schema-Loader/current/Changes
branches/DBIx-Class-Schema-Loader/current/Makefile.PL
branches/DBIx-Class-Schema-Loader/current/t/23dumpmore.t
Log:
Add "dbicdump" script for easy commandline dumping
Modified: branches/DBIx-Class-Schema-Loader/current/Changes
===================================================================
--- branches/DBIx-Class-Schema-Loader/current/Changes 2008-05-23 16:48:22 UTC (rev 4394)
+++ branches/DBIx-Class-Schema-Loader/current/Changes 2008-05-24 01:18:27 UTC (rev 4395)
@@ -3,6 +3,7 @@
0.04999_06 Not Yet Released
- Singularise table monikers by default
- Strip trailing _id from single-column belongs_to relationships
+ - Add "dbicdump" script for easy commandline dumping
0.04999_05 Mon Apr 14, 2008
- Fix limiting table list to the specified schema for DB2
Modified: branches/DBIx-Class-Schema-Loader/current/Makefile.PL
===================================================================
--- branches/DBIx-Class-Schema-Loader/current/Makefile.PL 2008-05-23 16:48:22 UTC (rev 4394)
+++ branches/DBIx-Class-Schema-Loader/current/Makefile.PL 2008-05-24 01:18:27 UTC (rev 4395)
@@ -9,6 +9,7 @@
test_requires 'DBD::SQLite' => '1.12';
test_requires 'File::Path' => 0;
test_requires 'Class::Unload' => 0;
+test_requires 'IPC::Open3' => 0;
requires 'File::Spec' => 0;
requires 'Scalar::Util' => 0;
@@ -24,6 +25,8 @@
requires 'Class::Inspector' => 0;
requires 'DBIx::Class' => '0.07006';
+install_script 'script/dbicdump';
+
# This is my manual hack for better feature control
# If you want to change the default answer for a feature,
# set the appropriate environment variable, like
Added: branches/DBIx-Class-Schema-Loader/current/script/dbicdump
===================================================================
--- branches/DBIx-Class-Schema-Loader/current/script/dbicdump (rev 0)
+++ branches/DBIx-Class-Schema-Loader/current/script/dbicdump 2008-05-24 01:18:27 UTC (rev 4395)
@@ -0,0 +1,68 @@
+#!/usr/bin/perl
+
+=head1 NAME
+
+dbicdump - Dump a schema using DBIx::Class::Schema::Loader
+
+=head1 SYNOPSIS
+
+ dbicdump [-o <loader_option>=<value> ] <schema_class> <connect_info>
+
+=head1 DESCRIPTION
+
+Dbicdump generates a L<DBIx::Class> schema using
+L<DBIx::Class::Schema::Loader/make_schema_at> and dumps it to disk.
+
+You can pass any L<DBIx::Class::Loader::Base> constructor option using
+C<< -o <option>=<value> >>. For convenience, option names will have C<->
+replaced with C<_> and values that look like references or quote-like
+operators will be C<eval>-ed before being passed to the constructor.
+
+The C<dump_directory> option defaults to the current directory if not
+specified.
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema::Loader>, L<DBIx::Class>.
+
+=head1 AUTHOR
+
+Dagfinn Ilmari Mannsåker C<< <ilmari at ilmari.org> >>
+
+=head1 LICENSE
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+use strict;
+use warnings;
+use Getopt::Long;
+use DBIx::Class::Schema::Loader qw/ make_schema_at /;
+require DBIx::Class::Schema::Loader::Base;
+
+my $loader_options;
+
+GetOptions( 'loader-option|o=s%' => \&handle_option );
+$loader_options->{dump_directory} ||= '.';
+
+my ($schema_class, @loader_connect_info) = @ARGV;
+
+sub handle_option {
+ my ($self, $key, $value) = @_;
+
+ $key =~ tr/-/_/;
+ die "Unknown option: $key\n"
+ unless DBIx::Class::Schema::Loader::Base->can($key);
+
+ $value = eval $value if $value =~ /^\s*(?:sub\s*\{|q\w?\s*[^\w\s]|[[{])/;
+
+ $loader_options->{$key} = $value;
+}
+
+make_schema_at(
+ $schema_class,
+ $loader_options,
+ \@loader_connect_info,
+);
Property changes on: branches/DBIx-Class-Schema-Loader/current/script/dbicdump
___________________________________________________________________
Name: svn:executable
+ *
Modified: branches/DBIx-Class-Schema-Loader/current/t/23dumpmore.t
===================================================================
--- branches/DBIx-Class-Schema-Loader/current/t/23dumpmore.t 2008-05-23 16:48:22 UTC (rev 4394)
+++ branches/DBIx-Class-Schema-Loader/current/t/23dumpmore.t 2008-05-24 01:18:27 UTC (rev 4395)
@@ -2,23 +2,24 @@
use Test::More;
use lib qw(t/lib);
use File::Path;
+use IPC::Open3;
use make_dbictest_db;
require DBIx::Class::Schema::Loader;
$^O eq 'MSWin32'
? plan(skip_all => "ActiveState perl produces additional warnings, and this test uses unix paths")
- : plan(tests => 82);
+ : plan(tests => 140);
my $DUMP_PATH = './t/_dump';
-sub do_dump_test {
+sub dump_directly {
my %tdata = @_;
my $schema_class = $tdata{classname};
no strict 'refs';
@{$schema_class . '::ISA'} = ('DBIx::Class::Schema::Loader');
- $schema_class->loader_options(dump_directory => $DUMP_PATH, %{$tdata{options}});
+ $schema_class->loader_options(%{$tdata{options}});
my @warns;
eval {
@@ -31,10 +32,49 @@
is($err, $tdata{error});
+ return @warns;
+}
+
+sub dump_dbicdump {
+ my %tdata = @_;
+
+ my @cmd = qw(./script/dbicdump);
+
+ while (my ($opt, $val) = each(%{ $tdata{options} })) {
+ push @cmd, '-o', "$opt=$val";
+ }
+
+ push @cmd, $tdata{classname}, $make_dbictest_db::dsn;
+
+ my ($in, $out, $err);
+ my $pid = open3($in, $out, $err, @cmd);
+
+ my @warns = <$out>;
+ waitpid($pid, 0);
+
+ return @warns;
+}
+
+sub do_dump_test {
+ my %tdata = @_;
+
+ $tdata{options}{dump_directory} = $DUMP_PATH;
+
+ for my $dumper (\&dump_directly, \&dump_dbicdump) {
+ test_dumps(\%tdata, $dumper->(%tdata));
+ }
+}
+
+sub test_dumps {
+ my ($tdata, @warns) = @_;
+
+ my %tdata = %{$tdata};
+
+ my $schema_class = $tdata{classname};
my $check_warns = $tdata{warnings};
- is(@warns, @$check_warns);
+ is(@warns, @$check_warns, "$schema_class warning count");
for(my $i = 0; $i <= $#$check_warns; $i++) {
- like($warns[$i], $check_warns->[$i]);
+ like($warns[$i], $check_warns->[$i], "$schema_class warning $i");
}
my $file_regexes = $tdata{regexes};
@@ -59,7 +99,8 @@
open(my $dumpfh, '<', $path) or die "Failed to open '$path': $!";
my $contents = do { local $/; <$dumpfh>; };
close($dumpfh);
- like($contents, $_) for @_;
+ my $num = 1;
+ like($contents, $_, "like $path " . $num++) for @_;
}
sub dump_file_not_like {
@@ -67,7 +108,8 @@
open(my $dumpfh, '<', $path) or die "Failed to open '$path': $!";
my $contents = do { local $/; <$dumpfh>; };
close($dumpfh);
- unlike($contents, $_) for @_;
+ my $num = 1;
+ unlike($contents, $_, "unlike $path ". $num++) for @_;
}
sub append_to_class {
More information about the Bast-commits
mailing list