'Test::NoWarnings' => '0.08',
'Test::Manifest' => '1.11',
'Test::More' => '0.60',
+ 'Test::Warn' => '0.08',
},
requires => {
'Data::Page' => 0,
use base qw/DBIx::Class/;
-__PACKAGE__->load_components(qw/
- InflateColumn
- Relationship
- PK
- Row
- Table
- Exception
- AccessorGroup/);
+BEGIN {
+ __PACKAGE__->load_components(qw/
+ InflateColumn
+ Relationship
+ PK
+ Row
+ Validation
+ Table
+ Exception
+ AccessorGroup
+ /);
+
+ __PACKAGE__->load_types(qw/
+ column
+ number
+ object
+ string
+ /);
+}
1;
use strict;
use warnings;
+use Carp qw( croak );
sub inflate_column {
my ($self, $col, $attrs) = @_;
- die "No such column $col to inflate" unless exists $self->_columns->{$col};
- die "inflate_column needs attr hashref" unless ref $attrs eq 'HASH';
- $self->_columns->{$col}{_inflate_info} = $attrs;
- $self->mk_group_accessors('inflated_column' => $col);
+
+ $self->throw("inflate_column needs attr hashref")
+ unless ref $attrs eq 'HASH';
+
+ $self->throw("No such column $col to inflate")
+ unless exists $self->_columns->{$col}{field};
+
+ $self->_columns->{$col}{field}->set_inflate($attrs->{inflate});
+ $self->_columns->{$col}{field}->set_deflate($attrs->{deflate});
+
+ $self->mk_group_accessors(inflated_column => $col);
+
return 1;
}
sub _inflated_column {
my ($self, $col, $value) = @_;
return $value unless defined $value; # NULL is NULL is NULL
- return $value unless exists $self->_columns->{$col}{_inflate_info};
- return $value unless exists $self->_columns->{$col}{_inflate_info}{inflate};
- my $inflate = $self->_columns->{$col}{_inflate_info}{inflate};
+ return $value unless my $inflate = $self->_columns->{$col}{field}->get_inflate;
return $inflate->($value, $self);
}
sub _deflated_column {
my ($self, $col, $value) = @_;
return $value unless ref $value; # If it's not an object, don't touch it
- return $value unless exists $self->_columns->{$col}{_inflate_info};
- return $value unless exists $self->_columns->{$col}{_inflate_info}{deflate};
- my $deflate = $self->_columns->{$col}{_inflate_info}{deflate};
+ return $value unless my $deflate = $self->_columns->{$col}{field}->get_deflate;
return $deflate->($value, $self);
}
sub get_inflated_column {
my ($self, $col) = @_;
$self->throw("$col is not an inflated column") unless
- exists $self->_columns->{$col}{_inflate_info};
+ defined $self->_columns->{$col}{field}->get_inflate;
return $self->{_inflated_column}{$col}
if exists $self->{_inflated_column}{$col};
return $self->{_inflated_column}{$col} =
- $self->_inflated_column($col, $self->get_column($col));
+ $self->_inflated_column($col, $self->get_column($col));
}
sub set_inflated_column {
}
my $deflated = $self->_deflated_column($col, $obj);
- # Do this now so we don't store if it's invalid
+ # Do this now so we don't store if it's invalid
$self->{_inflated_column}{$col} = $obj;
#warn "Storing $obj: ".($obj->_ident_values)[0];
$attrs ||= {};
my %deflated;
foreach my $key (keys %$attrs) {
- if (exists $class->_columns->{$key}{_inflate_info}) {
- $deflated{$key} = $class->_deflated_column($key,
- delete $attrs->{$key});
- }
+ next unless defined $class->_columns->{$key}{field}
+ and defined $class->_columns->{$key}{field}->get_deflate;
+ $deflated{$key} = $class->_deflated_column($key, delete $attrs->{$key});
}
return $class->NEXT::ACTUAL::new({ %$attrs, %deflated }, @rest);
}
my ($class, @cols) = @_;
my $names = { %{$class->_columns} };
$names->{$_} ||= {} for @cols;
- $class->_columns($names);
+ $class->_columns($names);
+
+ foreach my $name (@cols) {
+ $class->set_field_column_name($name => $name);
+ $class->_columns->{$name}{field} = $class->get_field($name);
+ }
}
sub _mk_column_accessors {
}
sub _select_columns {
- return keys %{$_[0]->_columns};
+ return
+ map { $_->{field}->get_name }
+ values %{$_[0]->_columns};
}
=item table
return defined($exists) ? $exists : $class->create($hash);
}
-sub columns { return keys %{shift->_columns}; }
+sub columns {
+ return
+ map { $_->{field}->get_name }
+ values %{$_[0]->_columns};
+}
1;
return;
}
- sub get_field : RESTRICTED method {
+ sub get_field : method {
my ( $class, $field_name ) = @_;
croak 'must supply a field name'
return $field_class->get_instance;
}
- sub set_field_label : RESTRICTED method {
+ sub set_field_label : method {
return shift->get_field(shift)->set_label(shift);
}
- sub set_field_description : RESTRICTED method {
+ sub set_field_description : method {
return shift->get_field(shift)->set_description(shift);
}
- sub set_field_default : RESTRICTED method {
+ sub set_field_default : method {
return shift->get_field(shift)->set_default(shift);
}
- sub set_field_read_only : RESTRICTED method {
+ sub set_field_read_only : method {
return shift->get_field(shift)->set_is_read_only(1);
}
- sub set_field : RESTRICTED method {
+ sub set_field : method {
my ( $class, $field_name, $attr ) = @_;
while ( my ( $attr, $value ) = each %{$attr} ) {
return;
}
- sub validates_presence_of : RESTRICTED method {
+ sub validates_presence_of : method {
my ( $class, $field_name, $opt ) = @_;
$class->get_field($field_name)->set_is_required(1);
return;
}
- sub validates_allowed_values_of : RESTRICTED method {
+ sub validates_allowed_values_of : method {
my ( $class, $field_name, $allowed_values, $opt ) = @_;
$class->get_field($field_name)
return;
}
- sub validates_disallowed_values_of : RESTRICTED method {
+ sub validates_disallowed_values_of : method {
my ( $class, $field_name, $disallowed_values, $opt ) = @_;
$class->get_field($field_name)
return;
}
- sub validates_each_with : RESTRICTED method {
+ sub validates_each_with : method {
my ( $class, $field_name, $callbacks, $opt ) = @_;
$class->get_field($field_name)
use strict;
use warnings FATAL => 'all';
-use base qw( DBIx::Class::Validation );
use Carp qw( croak );
use DBIx::Class::Field::Type::column;
use Class::Std;
{
- sub set_field_column_name : RESTRICTED method {
+ sub set_field_column_name : method {
my ( $class, $field_name, $column_name ) = @_;
$class->_add_column_type_to_field($field_name);
return shift->get_field($field_name)->set_column_name($column_name);
}
- sub set_field_inflate : RESTRICTED method {
- my ( $class, $field_name, $column_name ) = @_;
-
- $class->_add_column_type_to_field($field_name);
-
- return shift->get_field($field_name)->set_inflate($column_name);
- }
-
- sub set_field_deflate : RESTRICTED method {
- my ( $class, $field_name, $column_name ) = @_;
-
- $class->_add_column_type_to_field($field_name);
-
- return shift->get_field($field_name)->set_deflate($column_name);
- }
-
sub _add_column_type_to_field : PRIVATE method {
my ( $class, $field_name, $opt ) = @_;
use strict;
use warnings FATAL => 'all';
-use base qw( DBIx::Class::Validation );
use Carp qw( croak );
use DBIx::Class::Field::Type::number;
use Class::Std;
{
- sub validates_numericality_of : RESTRICTED method {
+ sub validates_numericality_of : method {
my ( $class, $field_name, $opt ) = @_;
my $field = $class->get_field($field_name);
return;
}
- sub validates_range_of : RESTRICTED method {
+ sub validates_range_of : method {
my ( $class, $field_name, $opt ) = @_;
$class->validates_numericality_of($field_name);
return;
}
- sub validates_precision_of : RESTRICTED method {
+ sub validates_precision_of : method {
my ( $class, $field_name, $opt ) = @_;
$class->validates_numericality_of($field_name);
use strict;
use warnings FATAL => 'all';
-use base qw( DBIx::Class::Validation );
use Carp qw( croak );
use DBIx::Class::Field::Type::object;
use Class::Std;
{
- sub validates_roles_of : RESTRICTED method {
+ sub validates_roles_of : method {
my ( $class, $field_name, $roles, $opt ) = @_;
$class->_add_object_type_to_field($field_name);
return;
}
- sub validates_classes_of : RESTRICTED method {
+ sub validates_classes_of : method {
my ( $class, $field_name, $classes, $opt ) = @_;
$class->_add_object_type_to_field($field_name);
use strict;
use warnings FATAL => 'all';
-use base qw( DBIx::Class::Validation );
use Carp qw( croak );
use DBIx::Class::Field::Type::string;
use Class::Std;
{
- sub validates_length_of : RESTRICTED method {
+ sub validates_length_of : method {
my ( $class, $field_name, $opt ) = @_;
$class->_add_string_type_to_field($field_name);
return;
}
- sub validates_allowed_chars_of : RESTRICTED method {
+ sub validates_allowed_chars_of : method {
my ( $class, $field_name, $allowed_chars, $opt ) = @_;
$class->_add_string_type_to_field($field_name);
return;
}
- sub validates_disallowed_chars_of : RESTRICTED method {
+ sub validates_disallowed_chars_of : method {
my ( $class, $field_name, $disallowed_chars, $opt ) = @_;
$class->_add_string_type_to_field($field_name);
return;
}
- sub validates_format_of : RESTRICTED method {
+ sub validates_format_of : method {
my ( $class, $field_name, $format, $opt ) = @_;
$class->_add_string_type_to_field($field_name);
use Test::More;
-plan tests => 23;
+BEGIN {
+ plan tests => 23;
-use lib qw(t/lib);
+ use lib qw(t/lib);
-use_ok('DBICTest');
+ use_ok('DBICTest');
+}
my @art = DBICTest::Artist->search({ }, { order_by => 'name DESC'});
use Test::More;
-plan tests => 4;
+BEGIN {
+ plan tests => 4;
-use lib qw(t/lib);
+ use lib qw(t/lib);
-use_ok('DBICTest');
+ use_ok('DBICTest');
+}
# add some rows inside a transaction and commit it
# XXX: Is storage->dbh the only way to get a dbh?
use Test::More;
-plan tests => 3;
+BEGIN {
+ plan tests => 3;
-use lib qw(t/lib);
+ use lib qw(t/lib);
-use_ok('DBICTest');
+ use_ok('DBICTest');
+}
ok(DBICTest::FourKeys->find(1,2,3,4), "find multiple pks without hash");
ok(DBICTest::FourKeys->find(5,4,3,6), "find multiple pks without hash");
use Test::More;
-plan tests => 14;
+BEGIN {
+ plan tests => 14;
-use lib qw(t/lib);
+ use lib qw(t/lib);
-use_ok('DBICTest');
+ use_ok('DBICTest');
+}
# has_a test
my $cd = DBICTest::CD->find(4);
use Test::More;
-eval { require DateTime };
-plan skip_all => "Need DateTime for inflation tests" if $@;
+BEGIN {
+ eval { require DateTime };
+ plan skip_all => "Need DateTime for inflation tests" if $@;
-plan tests => 4;
+ plan tests => 4;
-use lib qw(t/lib);
+ use lib qw(t/lib);
-use_ok('DBICTest');
+ use_ok('DBICTest');
+}
DBICTest::CD->inflate_column( 'year',
{ inflate => sub { DateTime->new( year => shift ) },
use Test::More;
-eval { require DateTime };
-plan skip_all => "Need DateTime for inflation tests" if $@;
+BEGIN {
+ eval { require DateTime };
+ plan skip_all => "Need DateTime for inflation tests" if $@;
-plan tests => 7;
+ plan tests => 7;
-use lib qw(t/lib);
+ use lib qw(t/lib);
-use_ok('DBICTest');
+ use_ok('DBICTest');
+}
DBICTest::CD->load_components(qw/CDBICompat::HasA/);
use Test::More;
BEGIN {
- eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 4);
-}
+ eval "use DBD::SQLite";
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 4);
-use lib qw(t/lib);
+ use lib qw(t/lib);
-use_ok('DBICTest');
+ use_ok('DBICTest');
+}
my $art = DBICTest::Artist->find(1);
use Test::More;
-plan tests => 2;
+BEGIN {
+ plan tests => 2;
-use lib qw(t/lib);
+ use lib qw(t/lib);
-use_ok('DBICTest');
+ use_ok('DBICTest');
+}
DBICTest::Artist->load_components(qw/PK::Auto::SQLite/);
BEGIN {
eval "use DBD::SQLite";
plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 10);
-}
-use lib qw(t/lib);
+ use lib qw(t/lib);
-use_ok('DBICTest');
+ use_ok('DBICTest');
+}
# test LIMIT
my $it = DBICTest::CD->search( {},
use strict;
use warnings FATAL => 'all';
-use Test::More tests => 15;
+use Test::More tests => 7;
use Test::Exception;
use Test::NoWarnings;
use base qw(DBIx::Class::Validation);
SET_FIELD_COMMON: {
my %attr = (
column_name => 'Test ID',
- deflate => [],
- inflate => [],
);
while ( my ( $attr, $value ) = each %attr ) {
#-----------------------------------------------------------------------
# Make sure that we can set up columns properly
#-----------------------------------------------------------------------
-package State;
-
-use base 'DBIx::Class';
-State->load_components(qw/CDBICompat Core/);
-
-State->table('State');
-State->columns(Essential => qw/Abbreviation Name/);
-State->columns(Primary => 'Name');
-State->columns(Weather => qw/Rain Snowfall/);
-State->columns(Other => qw/Capital Population/);
-#State->has_many(cities => "City");
-
-sub accessor_name {
- my ($class, $column) = @_;
- my $return = $column eq "Rain" ? "Rainfall" : $column;
- return $return;
+BEGIN {
+ package State;
+
+ use base 'DBIx::Class';
+ State->load_components(qw/CDBICompat Core/);
+
+ State->table('State');
+ State->columns(Essential => qw/Abbreviation Name/);
+ State->columns(Primary => 'Name');
+ State->columns(Weather => qw/Rain Snowfall/);
+ State->columns(Other => qw/Capital Population/);
+ #State->has_many(cities => "City");
+
+ sub accessor_name {
+ my ($class, $column) = @_;
+ my $return = $column eq "Rain" ? "Rainfall" : $column;
+ return $return;
+ }
+
+ sub mutator_name {
+ my ($class, $column) = @_;
+ my $return = $column eq "Rain" ? "set_Rainfall" : "set_$column";
+ return $return;
+ }
+
+ sub Snowfall { 1 }
+
+
+ package City;
+
+ use base 'DBIx::Class';
+ City->load_components(qw/CDBICompat Core/);
+
+ City->table('City');
+ City->columns(All => qw/Name State Population/);
+ City->has_a(State => 'State');
+
+
+ #-------------------------------------------------------------------------
+ package CD;
+ use base 'DBIx::Class';
+ CD->load_components(qw/CDBICompat Core/);
+
+ CD->table('CD');
+ CD->columns('All' => qw/artist title length/);
+
+ #-------------------------------------------------------------------------
}
-sub mutator_name {
- my ($class, $column) = @_;
- my $return = $column eq "Rain" ? "set_Rainfall" : "set_$column";
- return $return;
-}
-
-sub Snowfall { 1 }
-
-
-package City;
-
-use base 'DBIx::Class';
-City->load_components(qw/CDBICompat Core/);
-
-City->table('City');
-City->columns(All => qw/Name State Population/);
-City->has_a(State => 'State');
-
-
-#-------------------------------------------------------------------------
-package CD;
-use base 'DBIx::Class';
-CD->load_components(qw/CDBICompat Core/);
-
-CD->table('CD');
-CD->columns('All' => qw/artist title length/);
-
-#-------------------------------------------------------------------------
-
package main;
is(State->table, 'State', 'State table()');
#-----------------------------------------------------------------------
# Make sure that columns inherit properly
#-----------------------------------------------------------------------
-package State;
-
-package A;
-@A::ISA = qw(DBIx::Class);
-__PACKAGE__->load_components(qw/CDBICompat Core/);
-__PACKAGE__->columns(Primary => 'id');
-
-package A::B;
-@A::B::ISA = 'A';
-__PACKAGE__->columns(All => qw(id b1));
-
-package A::C;
-@A::C::ISA = 'A';
-__PACKAGE__->columns(All => qw(id c1 c2 c3));
+BEGIN {
+ package State;
+
+ package A;
+ @A::ISA = qw(DBIx::Class);
+ __PACKAGE__->load_components(qw/CDBICompat Core/);
+ __PACKAGE__->columns(Primary => 'id');
+
+ package A::B;
+ @A::B::ISA = 'A';
+ __PACKAGE__->columns(All => qw(id b1));
+
+ package A::C;
+ @A::C::ISA = 'A';
+ __PACKAGE__->columns(All => qw(id c1 c2 c3));
+}
package main;
is join (' ', sort A->columns), 'id', "A columns";
use strict;
use Test::More;
+use Test::NoWarnings;
+use Test::Exception;
+use Test::Warn;
#----------------------------------------------------------------------
# Test lazy loading
BEGIN {
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 25);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 28);
}
INIT {
# Test contructor breaking.
-eval { # Need a hashref
- Lazy->create(this => 10, that => 20, oop => 30, opop => 40, eep => 50);
+eval {
+ Lazy->create(this => 10, that => 20, oop => 30, opop => 40, eep => 50)
};
ok($@, $@);
-eval { # False column
- Lazy->create({ this => 10, that => 20, theother => 30 });
-};
-ok($@, $@);
-eval { # Multiple false columns
- Lazy->create({ this => 10, that => 20, theother => 30, andanother => 40 });
-};
+warning_like {
+ eval { # False column
+ Lazy->create({ this => 10, that => 20, theother => 30 });
+ };
+} qr/table Lazy has no column named theother/;
ok($@, $@);
+warning_like {
+ eval { # Multiple false columns
+ Lazy->create({ this => 10, that => 20, theother => 30, andanother => 40 });
+ };
+} qr/table Lazy has no column named andanother/;
+ok($@, $@);
#!/usr/bin/perl -w
use strict;
-use Test::More tests => 3;
+use Test::More tests => 4;
+use Test::NoWarnings;
use DBIx::Class;
-package A;
-@A::ISA = qw(DBIx::Class);
-__PACKAGE__->load_components(qw/CDBICompat Core/);
-__PACKAGE__->columns(Primary => 'id');
-
-package A::B;
-@A::B::ISA = 'A';
-__PACKAGE__->columns(All => qw(id b1));
-
-package A::C;
-@A::C::ISA = 'A';
-__PACKAGE__->columns(All => qw(id c1 c2 c3));
+BEGIN {
+ package A;
+ @A::ISA = qw(DBIx::Class);
+ __PACKAGE__->load_components(qw/CDBICompat Core/);
+ __PACKAGE__->columns(Primary => 'id');
+
+ package A::B;
+ @A::B::ISA = 'A';
+ __PACKAGE__->columns(All => qw(id b1));
+
+ package A::C;
+ @A::C::ISA = 'A';
+ __PACKAGE__->columns(All => qw(id c1 c2 c3));
+}
package main;
is join (' ', sort A->columns), 'id', "A columns";
use strict;
use Test::More;
+use Test::NoWarnings;
+use Test::Warn;
BEGIN {
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 53);
-}
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 55);
-INIT {
#local $SIG{__WARN__} =
#sub { like $_[0], qr/clashes with built-in method/, $_[0] };
use lib 't/testlib';
require Actor;
Actor->has_a(film => 'Film');
sub Class::DBI::sheep { ok 0; }
-}
-
-sub Film::mutator_name {
- my ($class, $col) = @_;
- return "set_sheep" if lc $col eq "numexplodingsheep";
- return $col;
-}
-sub Film::accessor_name {
- my ($class, $col) = @_;
- return "sheep" if lc $col eq "numexplodingsheep";
- return $col;
-}
-
-sub Actor::accessor_name {
- my ($class, $col) = @_;
- return "movie" if lc $col eq "film";
- return $col;
+ sub Film::mutator_name {
+ my ($class, $col) = @_;
+ return "set_sheep" if lc $col eq "numexplodingsheep";
+ return $col;
+ }
+
+ sub Film::accessor_name {
+ my ($class, $col) = @_;
+ return "sheep" if lc $col eq "numexplodingsheep";
+ return $col;
+ }
+
+ sub Actor::accessor_name {
+ my ($class, $col) = @_;
+ return "movie" if lc $col eq "film";
+ return $col;
+ }
}
my $data = {
};
is $@, '', "No errors";
-eval {
- my @film = Film->search({ sheep => 1 });
- is @film, 2, "Can search with modified accessor";
-};
+warning_like {
+ eval {
+ my @film = Film->search({ sheep => 1 });
+ is @film, 2, "Can search with modified accessor";
+ };
+} qr/no such column: sheep/;
{
use strict;
use Test::More;
+use Test::NoWarnings;
BEGIN {
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 5);
-}
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 6);
-use lib 't/testlib';
-require Film;
-require Order;
+ use lib 't/testlib';
+ use Film;
+ use Order;
+}
Film->has_many(orders => 'Order');
Order->has_a(film => 'Film');
use strict;
use Test::More;
+use Test::NoWarnings;
#----------------------------------------------------------------------
# Test database failures
BEGIN {
eval "use DBD::SQLite";
- plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 7);
+ plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 8);
}
use lib 't/testlib';
local *DBIx::ContextualFetch::st::execute = sub { die "Database died" };
eval { $btaste->update };
::like $@, qr/Database died/s, "We failed";
- }
+ };
$btaste->discard_changes;
my $still = Film->retrieve('Bad Taste');
isa_ok $btaste, 'Film', "We still have Bad Taste";
my $sheep = eval { Film->maximum_value_of('numexplodingsheep') };
::like $@, qr/select.*Database died/s,
"Handle database death in single value select";
- }
+ };
}
+$SIG{__WARN__} = sub {
+ my $warning = shift;
+ die $warning
+ if $warning ne "closing dbh with active statement handles\n";
+};
\ No newline at end of file
projects / dbsrgits/DBIx-Class-Historic.git / commitdiff