use strict;
+use warnings FATAL => 'all';
use Module::Build;
my %arguments = (
- create_makefile_pl => 'passthrough',
license => 'perl',
module_name => 'DBIx::Class',
+ build_requires => {
+ 'File::Spec' => '3.01',
+ 'Test::Exception' => '0.21',
+ 'Test::NoWarnings' => '0.08',
+ 'Test::Manifest' => '1.11',
+ 'Test::More' => '0.60',
+ },
requires => {
'Data::Page' => 0,
'DBI' => 0,
'UNIVERSAL::require' => 0,
'NEXT' => 0,
- 'Scalar::Util' => 0,
'SQL::Abstract' => 1.20,
'SQL::Abstract::Limit' => 0.101,
+ 'Scalar::Util' => 1.14,
'DBD::SQLite' => 1.08,
'Tie::IxHash' => 0,
'Storable' => 0,
+ 'Carp' => '1.03',
+ 'Class::Std' => '0.0.4',
+ 'List::MoreUtils' => '0.10',
+ 'base' => '2.060',
+ 'strict' => '1.030',
+ 'version' => '0.420',
+ 'warnings' => '1.03',
},
create_makefile_pl => 'passthrough',
create_readme => 1,
- test_files => [ glob('t/*.t'), glob('t/*/*.t') ]
+ add_to_cleanup => [ qw( MANIFEST.bak cover_db .DS_Store Makefile t/var ) ],
);
-Module::Build->new(%arguments)->create_build_script;
+my $build_class = test_manifest_subclass();
+my $build = $build_class->new(%arguments)->create_build_script();
+
+# use Test::Manifest to prioritize test cases
+# rather than a naming convention
+sub test_manifest_subclass {
+ return Module::Build->subclass(
+ class => 'Module::Build::Test::Manifest',
+ code => q{
+ sub ACTION_test {
+ my ($self, @args ) = @_;
+
+ if( exists $self->{properties}{test_files} ) {
+ return $self->SUPER::ACTION_test(@args);
+ }
+
+ local $^X = $self->{config}{perlpath};
+
+ require Test::Manifest;
+ require File::Spec;
+
+ Test::Manifest::run_t_manifest(
+ $self->{properties}{verbose} || 0,
+ File::Spec->catdir(qw(blib lib)),
+ File::Spec->catdir(qw(blib arch)),
+ );
+ return;
+ }
+ },
+ );
+}
lib/DBIx/Class/Cursor.pm
lib/DBIx/Class/DB.pm
lib/DBIx/Class/Exception.pm
+lib/DBIx/Class/Field.pm
+lib/DBIx/Class/Field/Singleton.pm
+lib/DBIx/Class/Field/Type/auto_increment.pm
+lib/DBIx/Class/Field/Type/column.pm
+lib/DBIx/Class/Field/Type/identifier.pm
+lib/DBIx/Class/Field/Type/number.pm
+lib/DBIx/Class/Field/Type/object.pm
+lib/DBIx/Class/Field/Type/string.pm
lib/DBIx/Class/InflateColumn.pm
lib/DBIx/Class/PK.pm
lib/DBIx/Class/PK/Auto.pm
lib/DBIx/Class/Storage/DBI/Cursor.pm
lib/DBIx/Class/Table.pm
lib/DBIx/Class/Test/SQLite.pm
+lib/DBIx/Class/Validation.pm
+lib/DBIx/Class/Validation/Type/column.pm
+lib/DBIx/Class/Validation/Type/number.pm
+lib/DBIx/Class/Validation/Type/object.pm
+lib/DBIx/Class/Validation/Type/string.pm
MANIFEST This list of files
+META.yml
script/nextalyzer.pl
t/01core.t
t/02pod.t
t/cdbi-t/21-iterator.t
t/cdbi-t/30-pager.t
t/cdbi-t/98-failure.t
+t/DBIx/Class/Field/basic.t
+t/DBIx/Class/Field/Singleton/basic.t
+t/DBIx/Class/Field/Type/auto_increment/basic.t
+t/DBIx/Class/Field/Type/column/basic.t
+t/DBIx/Class/Field/Type/identifier/basic.t
+t/DBIx/Class/Field/Type/number/basic.t
+t/DBIx/Class/Field/Type/number/validate.t
+t/DBIx/Class/Field/Type/object/basic.t
+t/DBIx/Class/Field/Type/object/validate.t
+t/DBIx/Class/Field/Type/string/basic.t
+t/DBIx/Class/Field/Type/string/validate.t
+t/DBIx/Class/Field/validate.t
+t/DBIx/Class/Validation/basic.t
+t/DBIx/Class/Validation/Type/column/basic.t
+t/DBIx/Class/Validation/Type/number/basic.t
+t/DBIx/Class/Validation/Type/object/basic.t
+t/DBIx/Class/Validation/Type/string/basic.t
t/lib/DBICTest.pm
t/lib/DBICTest/Schema.pm
t/lib/DBICTest/Schema/Artist.pm
t/lib/DBICTest/Schema/Tag.pm
t/lib/DBICTest/Schema/Track.pm
t/lib/DBICTest/Schema/TwoKeys.pm
+t/test_manifest
t/testlib/Actor.pm
t/testlib/Binary.pm
t/testlib/Blurb.pm
t/testlib/Order.pm
t/testlib/OtherFilm.pm
t/testlib/PgBase.pm
-META.yml
-Makefile.PL
-README
\.tmp$
\.old$
\.bak$
+\.swp$
\#$
\b\.#
+\bTEST$
+\.DS_Store$
# Don't ship the test db
^t/var
-
--- /dev/null
+package DBIx::Class::Field;
+
+# TODO: add a validate_is_read_only method that checks
+# the value with Scalar::Util::readonly OR
+# checks to see if it's tied into a Readonly class
+
+# TODO: add a routine that checks to see if the value can
+# be tainted or not. Default the taint attribute
+# to allow tainting in all values. is_taintable
+
+use version; our $VERSION = qv('0.2.0');
+
+use strict;
+use warnings FATAL => 'all';
+use Carp qw( croak );
+use List::MoreUtils qw( any none );
+use Class::Std;
+{
+ my %name_of : ATTR( :init_arg<name> :get<name> );
+ my %label_of : ATTR( :init_arg<label> :get<label> :set<label> :default<undef> );
+ my %description_of : ATTR( :init_arg<description> :get<description> :set<description> :default<undef> );
+ my %allowed_values_of : ATTR( :init_arg<allowed_values> :get<allowed_values> :set<allowed_values> :default<[]> );
+ my %disallowed_values_of : ATTR( :init_arg<disallowed_values> :get<disallowed_values> :set<disallowed_values> :default<[]> );
+ my %callbacks_of : ATTR( :init_arg<callbacks> :get<callbacks> :set<callbacks> :default<[]> );
+ my %is_read_only : ATTR( :init_arg<is_read_only> :get<is_read_only> :set<is_read_only> :default<0> );
+ my %is_required : ATTR( :init_arg<is_required> :get<is_required> :set<is_required> :default<0> );
+ my %default_of : ATTR( :init_arg<default> :get<default> :set<default> :default<undef> );
+
+ sub validate : CUMULATIVE method {
+ shift->_validate(
+ shift,
+ 'required',
+ qw(validate_callbacks allowed_values disallowed_values),
+ );
+ }
+
+ sub validate_is_required : CUMULATIVE method {
+ my ( $self, $value ) = @_;
+
+ # check if the value must be defined
+ return
+ if defined $value
+ || !$self->get_is_required;
+
+ return $self->validation_error( is_required => 'is required' );
+ }
+
+ sub validate_allowed_values : CUMULATIVE method {
+ my ( $self, $value ) = @_;
+
+ # check if the defined value is allowed
+ return if !defined $value;
+
+ my $allowed_values = $self->get_allowed_values;
+
+ return
+ if !@$allowed_values
+ || any { $value eq $_ } @$allowed_values;
+
+ return $self->validation_error(
+ allowed_values => 'is not an allowed value',
+ );
+ }
+
+ sub validate_disallowed_values : CUMULATIVE method {
+ my ( $self, $value ) = @_;
+
+ # check if the defined value is disallowed
+ return if !defined $value;
+
+ my $disallowed_values = $self->get_disallowed_values;
+
+ return
+ if !@$disallowed_values
+ || none { $value eq $_ } @$disallowed_values;
+
+ return $self->validation_error(
+ disallowed_values => 'is a disallowed value',
+ );
+ }
+
+ sub validate_callbacks : CUMULATIVE method {
+ my ( $self, $value ) = @_;
+
+ # check if the defined value passes the callbacks
+ return if !defined $value;
+
+ my $callbacks = $self->get_callbacks;
+ return if !@$callbacks;
+
+ return $self->validate_with( $value => @$callbacks );
+ }
+
+ sub validation_error : CUMULATIVE method {
+ my ( $self, $rule, $desc, $data ) = @_;
+
+ # return an error message with an identifier
+ my $label = defined $self->get_label() ? $self->get_label()
+ : $self->get_name()
+ ;
+
+ my %error = (
+ rule => $rule,
+ message => "$label $desc",
+ );
+
+ if ( defined $data ) {
+ $error{data} = $data;
+ }
+
+ return \%error;
+ }
+
+ sub validate_with : CUMULATIVE method {
+ my ( $self, $value, @rules ) = @_;
+
+ my @methods;
+
+ # rules can be either a code-reference, a named-method in
+ # the $self object, or a built-in validation method
+ RULE:
+ foreach my $rule (@rules) {
+ my $code_ref;
+ if ( ref $rule eq 'CODE' ) {
+ push @methods, $rule;
+ }
+ elsif ( $code_ref = $self->can($rule) ) {
+ push @methods, $code_ref;
+ }
+ elsif ( $code_ref = $self->can( 'get_' . $rule ) ) {
+ next RULE if !defined $self->$code_ref();
+ push @methods, $self->can( 'validate_' . $rule );
+ }
+ else {
+ croak "Unknown rule type $rule";
+ }
+ }
+
+ # execute all the rules
+ return map { $_->( $self, $value ) } @methods;
+ }
+
+ sub type_of : method {
+ my ( $self, $expected ) = @_;
+
+ foreach my $type ( $self->types ) {
+ return 1 if $type eq $expected;
+ }
+
+ return;
+ }
+
+ sub types : CUMULATIVE method { 'field' }
+
+ sub _validate : RESTRICTED method {
+ my ($self, $value, $type, @rules) = @_;
+
+ # perform a basic check of the value
+ my $base_check_ref = $self->can( 'validate_is_' . $type );
+
+ if ( my ($error) = $self->$base_check_ref($value) ) {
+ return $error;
+ }
+
+ # use each rule to validate the value
+ return $self->validate_with( $value => @rules );
+ }
+
+}
+
+1;
--- /dev/null
+package DBIx::Class::Field::Singleton;
+
+use version; our $VERSION = qv('0.2.0');
+
+use strict;
+use warnings FATAL => 'all';
+use base qw(DBIx::Class::Field);
+use Carp qw( croak );
+use Scalar::Util qw( blessed );
+{
+ my %singleton_of;
+
+ sub get_instance : method {
+ my ($class) = @_;
+
+ if ( !exists $singleton_of{$class} ) {
+ croak "No singleton defined for $class";
+ }
+
+ return $singleton_of{$class};
+ }
+
+ sub set_instance : method {
+ my ( $class, @args ) = @_;
+
+ if ( blessed $class ) {
+ croak "$class->instance is not an object method";
+ }
+
+ if ( $class eq __PACKAGE__ ) {
+ croak "Can only use $class->set_instance from a subclass";
+ }
+
+ $singleton_of{$class} = $class->new(@args);
+
+ return;
+ }
+
+ sub types : CUMULATIVE method { 'singleton' }
+
+}
+
+1;
--- /dev/null
+package DBIx::Class::Field::Type::auto_increment;
+
+use version; our $VERSION = qv('0.2.0');
+
+use strict;
+use warnings FATAL => 'all';
+use base qw(
+ DBIx::Class::Field::Type::number
+ DBIx::Class::Field::Type::column
+);
+
+sub types : CUMULATIVE method { 'auto_increment' }
+
+1;
--- /dev/null
+package DBIx::Class::Field::Type::column;
+
+use version; our $VERSION = qv('0.2.0');
+
+use strict;
+use warnings FATAL => 'all';
+use base qw(DBIx::Class::Field);
+use Class::Std;
+{
+ my %table_of : ATTR( :init_arg<table> :get<table> :set<table> );
+ my %column_name_of : ATTR( :init_arg<column_name> :get<column_name> :set<column_name> :default<undef> );
+ my %deflate_with : ATTR( :init_arg<deflate> :get<deflate> :set<deflate> :default<undef> );
+ my %inflate_with : ATTR( :init_arg<inflate> :get<inflate> :set<inflate> :default<undef> );
+
+ sub BUILD : method {
+ my ( $self, $ident, $arg_ref ) = @_;
+
+ # if the column name is not provided set it to the field name
+ $column_name_of{$ident}
+ = defined $arg_ref->{column_name} ? $arg_ref->{column_name}
+ : $self->get_name
+ ;
+
+ return;
+ }
+
+ sub types : CUMULATIVE method { 'column' }
+
+}
+
+1;
--- /dev/null
+package DBIx::Class::Field::Type::identifier;
+
+use version; our $VERSION = qv('0.2.0');
+
+use strict;
+use warnings FATAL => 'all';
+use base qw(DBIx::Class::Field);
+
+sub types : CUMULATIVE method { 'identifier' }
+
+1;
--- /dev/null
+package DBIx::Class::Field::Type::number;
+
+use version; our $VERSION = qv('0.2.0');
+
+use strict;
+use warnings FATAL => 'all';
+use base qw(DBIx::Class::Field);
+use Scalar::Util qw( looks_like_number );
+use Class::Std;
+{
+ my %min_range_of : ATTR( :init_arg<min_range> :get<min_range> :set<min_range> :default<-100**100**100> );
+ my %max_range_of : ATTR( :init_arg<max_range> :get<max_range> :set<max_range> :default< 100**100**100> );
+ my %min_precision_of : ATTR( :init_arg<min_precision> :get<min_precision> :set<min_precision> :default<-100**100**100> );
+ my %max_precision_of : ATTR( :init_arg<max_precision> :get<max_precision> :set<max_precision> :default< 100**100**100> );
+
+ sub validate : CUMULATIVE method {
+ shift->_validate(
+ shift,
+ number => qw( min_range max_range min_precision max_precision ),
+ );
+ }
+
+ sub validate_is_number : method {
+ my ( $self, $value ) = @_;
+
+ # validate that the value is a number
+ return
+ if !defined $value
+ || looks_like_number($value);
+
+ return $self->validation_error( is_number => 'is not a number' );
+ }
+
+ sub validate_min_range : CUMULATIVE method {
+ my ( $self, $value ) = @_;
+
+ # validate the minimum range of a defined number
+ return
+ if !defined $value
+ || $self->validate_is_number($value)
+ || $value >= $self->get_min_range;
+
+ return $self->validation_error( min_range => 'is too small' );
+ }
+
+ sub validate_max_range : CUMULATIVE method {
+ my ( $self, $value ) = @_;
+
+ # validate the maximum range of a defined number
+ return
+ if !defined $value
+ || $self->validate_is_number($value)
+ || $value <= $self->get_max_range;
+
+ return $self->validation_error( max_range => 'is too large' );
+ }
+
+ sub validate_min_precision : CUMULATIVE method {
+ my ( $self, $value ) = @_;
+
+ # validate the minimum precision of a defined number
+ return
+ if !defined $value
+ || $self->validate_is_number($value);
+
+ my $precision_length = __PACKAGE__->_precision_length($value);
+ return if $precision_length >= $self->get_min_precision;
+
+ return $self->validation_error(
+ min_precision => 'has too few digits after the decimal point',
+ );
+ }
+
+ sub validate_max_precision : CUMULATIVE method {
+ my ( $self, $value ) = @_;
+
+ # validate the maximum precision of a defined number
+ return
+ if !defined $value
+ || $self->validate_is_number($value);
+
+ my $precision_length = __PACKAGE__->_precision_length($value);
+ return if $precision_length <= $self->get_max_precision;
+
+ return $self->validation_error(
+ max_precision => 'has too many digits after the decimal point',
+ );
+ }
+
+ sub _precision_length : PRIVATE method {
+ my ( undef, $value ) = @_;
+
+ # get the precision length of a number
+ my $decimal_pos = index $value, '.';
+
+ return 0 if $decimal_pos < 0;
+
+ return length substr $value, $decimal_pos + 1;
+ }
+
+ sub types : CUMULATIVE method { 'number' }
+}
+
+1;
--- /dev/null
+package DBIx::Class::Field::Type::object;
+
+use version; our $VERSION = qv('0.2.0');
+
+use strict;
+use warnings FATAL => 'all';
+use base qw(DBIx::Class::Field);
+use Scalar::Util qw( blessed );
+use Class::Std;
+{
+ my %roles_of : ATTR( :init_arg<roles> :get<roles> :set<roles> :default<[]> );
+ my %classes_of : ATTR( :init_arg<classes> :get<classes> :set<classes> :default<[]> );
+
+ sub validate : CUMULATIVE method {
+ shift->_validate(
+ shift,
+ object => qw( roles classes ),
+ );
+ }
+
+ sub validate_is_object : method {
+ my ( $self, $value ) = @_;
+
+ # validate that the value is an object
+ return
+ if !defined $value
+ || blessed $value;
+
+ return $self->validation_error( is_object => 'is not an object' );
+ }
+
+ sub validate_roles : CUMULATIVE method {
+ my ( $self, $value ) = @_;
+
+ # validate the roles (supported methods) of a defined object
+ return
+ if !defined $value
+ || $self->validate_is_object($value);
+
+ my @need_roles = grep { !$value->can($_) } @{ $self->get_roles };
+ return if !@need_roles;
+
+ return $self->validation_error(
+ roles => 'does not handle the necessary roles',
+ \@need_roles,
+ );
+ }
+
+ sub validate_classes : CUMULATIVE method {
+ my ( $self, $value ) = @_;
+
+ # validate the classes a defined object inherits from
+ return
+ if !defined $value
+ || $self->validate_is_object($value);
+
+ my @need_classes = grep { !$value->isa($_) } @{ $self->get_classes };
+ return if !@need_classes;
+
+ return $self->validation_error(
+ classes => 'does not inherit from the necessary classes',
+ \@need_classes,
+ );
+ }
+
+ sub types : CUMULATIVE method { 'object' }
+
+}
+
+1;
--- /dev/null
+package DBIx::Class::Field::Type::string;
+
+use version; our $VERSION = qv('0.2.0');
+
+use strict;
+use warnings FATAL => 'all';
+use base qw(DBIx::Class::Field);
+use Scalar::Util qw( refaddr );
+use Class::Std;
+{
+ my %min_length_of : ATTR( :init_arg<min_length> :get<min_length> :set<min_length> :default<-100**100**100> );
+ my %max_length_of : ATTR( :init_arg<max_length> :get<max_length> :set<max_length> :default< 100**100**100> );
+ my %allowed_chars_of : ATTR( :init_arg<allowed_chars> :get<allowed_chars> :set<allowed_chars> :default<[]> );
+ my %disallowed_chars_of : ATTR( :init_arg<disallowed_chars> :get<disallowed_chars> :set<disallowed_chars> :default<[]> );
+ my %format_of : ATTR( :init_arg<format> :get<format> :set<format> :default<qr//> );
+
+ sub validate : CUMULATIVE method {
+ shift->_validate(
+ shift,
+ string => qw(
+ min_length max_length
+ allowed_chars disallowed_chars
+ format
+ ),
+ );
+ }
+
+ sub validate_is_string : method {
+ my ( $self, $value ) = @_;
+
+ # validate that the value is a string
+ return
+ if !defined $value
+ || !refaddr $value;
+
+ return $self->validation_error( is_string => 'is not a string' );
+ }
+
+ sub validate_min_length : CUMULATIVE method {
+ my ( $self, $value ) = @_;
+
+ # validate the minimum length of a defined string
+ return
+ if !defined $value
+ || $self->validate_is_string($value)
+ || length $value >= $self->get_min_length;
+
+ return $self->validation_error( min_length => 'is too short' );
+ }
+
+ sub validate_max_length : CUMULATIVE method {
+ my ( $self, $value ) = @_;
+
+ # validate the maximum length of a defined string
+ return
+ if !defined $value
+ || $self->validate_is_string($value)
+ || length $value <= $self->get_max_length;
+
+ return $self->validation_error( max_length => 'is too long' );
+ }
+
+ sub validate_allowed_chars : CUMULATIVE method {
+ my ( $self, $value ) = @_;
+
+ # validate the allowed characters of a defined string
+ return
+ if !defined $value
+ || $self->validate_is_string($value);
+
+ my $allowed_chars = $self->get_allowed_chars;
+ return if !@$allowed_chars;
+
+ # match any character that is not allowed
+ my $match = join '', map { quotemeta $_ } @$allowed_chars;
+ return if !(my @bad_chars = $value =~ m/([^$match])/g);
+
+ return $self->validation_error(
+ allowed_chars => 'contains characters that are not allowed',
+ \@bad_chars,
+ );
+ }
+
+ sub validate_disallowed_chars : CUMULATIVE method {
+ my ( $self, $value ) = @_;
+
+ # validate the disallowed characters of a defined string
+ return
+ if !defined $value
+ || $self->validate_is_string($value);
+
+ my $disallowed_chars = $self->get_disallowed_chars;
+ return if !@$disallowed_chars;
+
+ # match any character that is explicitly disallowed
+ my $match = join '', map { quotemeta $_ } @$disallowed_chars;
+ return if !(my @bad_chars = $value =~ m/([$match])/g);
+
+ return $self->validation_error(
+ disallowed_chars => 'contains characters that are disallowed',
+ \@bad_chars,
+ );
+ }
+
+ sub validate_format : CUMULATIVE method {
+ my ( $self, $value ) = @_;
+
+ # validate the format of a defined string
+ return
+ if !defined $value
+ || $self->validate_is_string($value)
+ || $value =~ $self->get_format;
+
+ return $self->validation_error(
+ format => 'does not match the expected format',
+ );
+ }
+
+ sub types : CUMULATIVE method { 'string' }
+
+}
+
+1;
--- /dev/null
+package DBIx::Class::Validation;
+
+use strict;
+use warnings FATAL => 'all';
+use Carp qw( croak );
+use DBIx::Class::Field::Singleton;
+use Class::Std;
+{
+
+ sub load_types : RESTRICTED method {
+ my ( $class, @types ) = @_;
+ no strict 'refs';
+
+ foreach my $type ( @types ) {
+ my $isa = __PACKAGE__ . '::Type::' . $type;
+ eval "require $isa";
+ croak $@ if $@;
+ push @{"${class}::ISA"}, $isa;
+ }
+
+ return;
+ }
+
+ sub get_field : RESTRICTED method {
+ my ( $class, $field_name ) = @_;
+
+ croak 'must supply a field name'
+ if !defined $field_name;
+
+ my $field_class = $class . '::Field::' . $field_name;
+
+ # if possible, load the field class
+ eval "require $field_class";
+
+ # get the instance if it is defined
+ my $field = eval { $field_class->get_instance };
+ return $field if defined $field;
+
+ # create the field class
+ no strict 'refs';
+ push @{"${field_class}::ISA"},
+ grep { !UNIVERSAL::isa( $field_class, $_ ) }
+ qw( DBIx::Class::Field::Singleton DBIx::Class::Field );
+
+ # set a new field instance
+ $field_class->set_instance( { name => $field_name } );
+ return $field_class->get_instance;
+ }
+
+ sub set_field_label : RESTRICTED method {
+ return shift->get_field(shift)->set_label(shift);
+ }
+
+ sub set_field_description : RESTRICTED method {
+ return shift->get_field(shift)->set_description(shift);
+ }
+
+ sub set_field_default : RESTRICTED method {
+ return shift->get_field(shift)->set_default(shift);
+ }
+
+ sub set_field_read_only : RESTRICTED method {
+ return shift->get_field(shift)->set_is_read_only(1);
+ }
+
+ sub set_field : RESTRICTED method {
+ my ( $class, $field_name, $attr ) = @_;
+
+ while ( my ( $attr, $value ) = each %{$attr} ) {
+ my $mutator = "set_field_$attr";
+ $class->$mutator( $field_name => $value );
+ }
+
+ return;
+ }
+
+ sub validates_presence_of : RESTRICTED method {
+ my ( $class, $field_name, $opt ) = @_;
+
+ $class->get_field($field_name)->set_is_required(1);
+
+ # TODO: set up trigger points based on the $opt passed in. Want
+ # to be able to validate during different DBIx::Class
+ # operations.
+
+ return;
+ }
+
+ sub validates_allowed_values_of : RESTRICTED method {
+ my ( $class, $field_name, $allowed_values, $opt ) = @_;
+
+ $class->get_field($field_name)
+ ->set_allowed_values($allowed_values);
+
+ # TODO: set up trigger points based on the $opt passed in. Want
+ # to be able to validate during different DBIx::Class
+ # operations.
+
+ return;
+ }
+
+ sub validates_disallowed_values_of : RESTRICTED method {
+ my ( $class, $field_name, $disallowed_values, $opt ) = @_;
+
+ $class->get_field($field_name)
+ ->set_disallowed_values($disallowed_values);
+
+ # TODO: set up trigger points based on the $opt passed in. Want
+ # to be able to validate during different DBIx::Class
+ # operations.
+
+ return;
+ }
+
+ sub validates_each_with : RESTRICTED method {
+ my ( $class, $field_name, $callbacks, $opt ) = @_;
+
+ $class->get_field($field_name)
+ ->set_callbacks($callbacks);
+
+ # TODO: set up trigger points based on the $opt passed in. Want
+ # to be able to validate during different DBIx::Class
+ # operations.
+
+ return;
+ }
+}
+
+1;
+
+__END__
+
+# Inspiration:
+# http://rails.rubyonrails.com/classes/ActiveRecord/Validations/ClassMethods.html
+
+use base qw(DBIx::Class::Validation);
+
+__PACKAGE__->load_classes(qw(string number object column));
+
+# DBIx::Class::Validation
+# ----------------------------
+
+$table->set_field_label($field => 'Field');
+$table->set_field_description($field => 'test')
+$table->set_field_default($field => 'a default value');
+$table->set_field_read_only($field);
+
+# same as above -- shorthand
+$table->set_field( $field => {
+ label => 'Field',
+ description => 'test',
+ default => 'a default value',
+ read_only => 1,
+});
+
+$table->validates_presence_of($field);
+
+$table->validates_allowed_values_of($field => \@allowed_values);
+$table->validates_disallowed_values_of($field => \@disallowed_values);
+
+$table->validates_each_with($field => \@callbacks);
+
+# DBIx::Class::Validation::number
+# -------------------------------
+
+$table->validates_numericality_of($field);
+
+$table->validates_range_of($field, { min => 1, max => 500 });
+
+$table->validates_precision_of($field, { min => 1, max => 3 });
+
+# DBIx::Class::Validation::string
+# -------------------------------
+
+$table->validates_length_of($field, { min => 1, max => 40 });
+
+$table->validates_allowed_chars_of($field => [ qw( a b c d ) ]);
+$table->validates_disallowed_chars_of($field => [ qw( a b c d ) ]);
+
+$table->validates_format_of($field => qr/.*/);
+
+# DBIx::Class::Validation::object
+# -------------------------------
+
+$table->validates_roles_of($field => \@roles);
+
+$table->validates_classes_of($field => \@classes);
+
+# DBIx::Class::Field::Validate::column
+# ------------------------------------
+
+$table->set_field_column($field => $column);
+
+$table->set_field_inflate_deflate(
+ $field,
+ inflate => \%inflate,
+ deflate => \%deflate,
+);
+
+# same as above -- shorthand
+$table->set_field( $field => {
+ column => $column,
+ inflate => \&inflate,
+ deflate => \&deflate,
+});
--- /dev/null
+package DBIx::Class::Validation::Type::column;
+
+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 {
+ 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 ) = @_;
+
+ my $field = $class->get_field($field_name);
+ my $field_class = ref $field;
+
+ no strict 'refs';
+ push @{"${field_class}::ISA"},
+ grep { !$field->isa($_) }
+ qw( DBIx::Class::Field::Type::column );
+
+ return;
+ }
+}
+
+1;
--- /dev/null
+package DBIx::Class::Validation::Type::number;
+
+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 {
+ my ( $class, $field_name, $opt ) = @_;
+
+ my $field = $class->get_field($field_name);
+ my $field_class = ref $field;
+
+ no strict 'refs';
+ push @{"${field_class}::ISA"},
+ grep { !$field->isa($_) }
+ qw( DBIx::Class::Field::Type::number );
+
+ # TODO: set up trigger points based on the $opt passed in. Want
+ # to be able to validate during different DBIx::Class
+ # operations.
+
+ return;
+ }
+
+ sub validates_range_of : RESTRICTED method {
+ my ( $class, $field_name, $opt ) = @_;
+
+ $class->validates_numericality_of($field_name);
+
+ my $field = $class->get_field($field_name);
+
+ foreach my $attr qw(min max) {
+ my $value = $opt->{$attr};
+ next if !defined $value;
+
+ my $mutator = "set_${attr}_range";
+ $field->$mutator($value);
+ }
+
+ # TODO: set up trigger points based on the $opt passed in. Want
+ # to be able to validate during different DBIx::Class
+ # operations.
+
+ return;
+ }
+
+ sub validates_precision_of : RESTRICTED method {
+ my ( $class, $field_name, $opt ) = @_;
+
+ $class->validates_numericality_of($field_name);
+
+ my $field = $class->get_field($field_name);
+
+ foreach my $attr qw(min max) {
+ my $value = $opt->{$attr};
+ next if !defined $value;
+
+ my $mutator = "set_${attr}_precision";
+ $field->$mutator($value);
+ }
+
+ # TODO: set up trigger points based on the $opt passed in. Want
+ # to be able to validate during different DBIx::Class
+ # operations.
+
+ return;
+ }
+}
+
+1;
--- /dev/null
+package DBIx::Class::Validation::Type::object;
+
+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 {
+ my ( $class, $field_name, $roles, $opt ) = @_;
+
+ $class->_add_object_type_to_field($field_name);
+
+ $class->get_field($field_name)->set_roles($roles);
+
+ # TODO: set up trigger points based on the $opt passed in. Want
+ # to be able to validate during different DBIx::Class
+ # operations.
+
+ return;
+ }
+
+ sub validates_classes_of : RESTRICTED method {
+ my ( $class, $field_name, $classes, $opt ) = @_;
+
+ $class->_add_object_type_to_field($field_name);
+
+ $class->get_field($field_name)->set_classes($classes);
+
+ # TODO: set up trigger points based on the $opt passed in. Want
+ # to be able to validate during different DBIx::Class
+ # operations.
+
+ return;
+ }
+
+ sub _add_object_type_to_field : PRIVATE method {
+ my ( $class, $field_name, $opt ) = @_;
+
+ my $field = $class->get_field($field_name);
+ my $field_class = ref $field;
+
+ no strict 'refs';
+ push @{"${field_class}::ISA"},
+ grep { !$field->isa($_) }
+ qw( DBIx::Class::Field::Type::object );
+
+ return;
+ }
+}
+
+1;
--- /dev/null
+package DBIx::Class::Validation::Type::string;
+
+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 {
+ my ( $class, $field_name, $opt ) = @_;
+
+ $class->_add_string_type_to_field($field_name);
+
+ my $field = $class->get_field($field_name);
+
+ foreach my $attr qw(min max) {
+ my $value = $opt->{$attr};
+ next if !defined $value;
+
+ my $mutator = "set_${attr}_length";
+ $field->$mutator($value);
+ }
+
+ # TODO: set up trigger points based on the $opt passed in. Want
+ # to be able to validate during different DBIx::Class
+ # operations.
+
+ return;
+ }
+
+ sub validates_allowed_chars_of : RESTRICTED method {
+ my ( $class, $field_name, $allowed_chars, $opt ) = @_;
+
+ $class->_add_string_type_to_field($field_name);
+
+ $class->get_field($field_name)
+ ->set_allowed_chars($allowed_chars);
+
+ # TODO: set up trigger points based on the $opt passed in. Want
+ # to be able to validate during different DBIx::Class
+ # operations.
+
+ return;
+ }
+
+ sub validates_disallowed_chars_of : RESTRICTED method {
+ my ( $class, $field_name, $disallowed_chars, $opt ) = @_;
+
+ $class->_add_string_type_to_field($field_name);
+
+ $class->get_field($field_name)
+ ->set_disallowed_chars($disallowed_chars);
+
+ # TODO: set up trigger points based on the $opt passed in. Want
+ # to be able to validate during different DBIx::Class
+ # operations.
+
+ return;
+ }
+
+ sub validates_format_of : RESTRICTED method {
+ my ( $class, $field_name, $format, $opt ) = @_;
+
+ $class->_add_string_type_to_field($field_name);
+
+ $class->get_field($field_name)
+ ->set_format($format);
+
+ # TODO: set up trigger points based on the $opt passed in. Want
+ # to be able to validate during different DBIx::Class
+ # operations.
+
+ return;
+ }
+
+ sub _add_string_type_to_field : PRIVATE method {
+ my ( $class, $field_name, $opt ) = @_;
+
+ my $field = $class->get_field($field_name);
+ my $field_class = ref $field;
+
+ no strict 'refs';
+ push @{"${field_class}::ISA"},
+ grep { !$field->isa($_) }
+ qw( DBIx::Class::Field::Type::string );
+
+ return;
+ }
+}
+
+1;
--- /dev/null
+#!perl -T
+
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 12;
+use Test::Exception;
+use Test::NoWarnings;
+
+BEGIN {
+
+ package My::Column;
+
+ use base qw(
+ DBIx::Class::Field::Singleton
+ DBIx::Class::Field
+ );
+
+ package My::Column::Premature;
+
+ use base qw(
+ DBIx::Class::Field::Singleton
+ DBIx::Class::Field
+ );
+}
+
+my $class = 'My::Column';
+
+SET_INSTANCE: {
+ my $method = 'set_instance';
+
+ can_ok $class, $method;
+
+ is $class->$method({ name => 'id' }), undef;
+}
+
+my $obj;
+
+GET_INSTANCE: {
+ my $method = 'get_instance';
+
+ can_ok $class, $method;
+ isa_ok $obj = $class->$method, $class;
+
+ is $class->$method, $class->$method, 'same object each time';
+}
+
+TYPE_OF: {
+ my $method = 'type_of';
+
+ can_ok $obj, $method;
+
+ foreach my $type qw(singleton field) {
+ my ($is_type) = $obj->$method($type);
+ ok $is_type, "object is a type of $type";
+ }
+}
+
+PREMATURE_GET_INSTANCE: {
+ dies_ok { My::Column::Premature->get_instance } 'must set_instance first';
+}
+
+CLASS_METHOD_ONLY: {
+ my $obj = bless {}, 'My::Column';
+ dies_ok { $obj->set_instance } 'class method only';
+}
+
+SUBCLASSES_ONLY: {
+ my $class = 'DBIx::Class::Field::Singleton';
+ dies_ok { $class->set_instance } 'subclass use only';
+}
--- /dev/null
+#!perl -T
+
+package My::Test;
+
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 8;
+use Test::NoWarnings;
+use base qw(DBIx::Class::Field::Type::auto_increment);
+
+my $class = __PACKAGE__;
+
+my $obj;
+
+NEW: {
+ my $method = 'new';
+
+ can_ok $class, $method;
+
+ my %attributes = (
+ name => 'id',
+ table => 'customer',
+ );
+
+ isa_ok $obj = $class->$method( \%attributes ), $class;
+}
+
+TYPE_OF: {
+ my $method = 'type_of';
+
+ can_ok $obj, $method;
+
+ foreach my $type qw(auto_increment number column field) {
+ my ($is_type) = $obj->$method($type);
+ ok $is_type, "object is a type of $type";
+ }
+}
--- /dev/null
+#!perl -T
+
+package My::Test;
+
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 166;
+use Test::NoWarnings;
+use base qw(DBIx::Class::Field::Type::column);
+
+my $class = __PACKAGE__;
+
+my %attributes = (
+ name => 'customer_id',
+ table => 'customer',
+);
+
+my $obj;
+
+NEW: {
+ my $method = 'new';
+
+ can_ok $class, $method;
+
+ isa_ok $obj = $class->$method( \%attributes ), $class;
+}
+
+ATTRIBUTE_DEFAULTS: {
+ my %attribute_defaults = (
+ name => $attributes{name},
+ table => $attributes{table},
+ column_name => $attributes{name},
+ inflate => undef,
+ deflate => undef,
+ );
+
+ while ( my ( $attr, $default ) = each %attribute_defaults ) {
+ my $accessor = "get_$attr"; # Class::Std naming convention
+ can_ok $obj, $accessor;
+ is_deeply $obj->$accessor, $default, "default for $class->$accessor";
+
+ next if $attr eq 'name';
+
+ my $mutator = "set_$attr"; # Class::Std naming convention
+ can_ok $obj, $mutator;
+
+ is_deeply(
+ $obj->$mutator(undef), # explicitly set to undef
+ $default, # returns the previous value
+ "previous value $class->$mutator",
+ );
+
+ is $obj->$accessor, undef, 'value is now undef';
+ }
+}
+
+my %with_inflate_deflate = (
+ %attributes,
+ inflate => sub { pop() },
+ deflate => sub { pop() },
+);
+
+isa_ok $obj = $class->new( \%with_inflate_deflate ), $class;
+
+DEFLATE: {
+ my $method = 'get_deflate';
+
+ can_ok $obj, $method;
+
+ is ref $obj->$method, 'CODE', 'is a subref';
+
+ foreach my $value ( 'A' .. 'Z', 'a' .. 'z', 0 .. 10 ) {
+ my $deflated = $obj->$method->($value);
+ is $deflated, $value, "should pass-through value $value";
+ }
+}
+
+INFLATE: {
+ my $method = 'get_inflate';
+
+ can_ok $obj, $method;
+
+ is ref $obj->$method, 'CODE', 'is a subref';
+
+ foreach my $value ( 'A' .. 'Z', 'a' .. 'z', 0 .. 10 ) {
+ my $inflated = $obj->$method->($value);
+ is $inflated, $value, "should pass-through value $value";
+ }
+}
+
+TYPE_OF: {
+ my $method = 'type_of';
+
+ can_ok $obj, $method;
+
+ foreach my $type qw(column field) {
+ my ($is_type) = $obj->$method($type);
+ ok $is_type, "object is a type of $type";
+ }
+}
+
+ATTRIBUTES: {
+ my %attributes = ( %attributes, column_name => 'id' );
+
+ isa_ok $obj = $class->new( \%attributes ), $class;
+
+ while ( my ( $attr, $default ) = each %attributes ) {
+ my $accessor = "get_$attr"; # Class::Std naming convention
+ can_ok $obj, $accessor;
+ is_deeply $obj->$accessor, $default, "default for $class->$accessor";
+ }
+}
--- /dev/null
+#!perl -T
+
+package My::Test;
+
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 6;
+use Test::NoWarnings;
+use base qw(DBIx::Class::Field::Type::identifier);
+
+my $class = __PACKAGE__;
+
+my $obj;
+
+NEW: {
+ my $method = 'new';
+
+ can_ok $class, $method;
+
+ my %attributes = (
+ name => 'id',
+ table => 'customer',
+ );
+
+ isa_ok $obj = $class->$method( \%attributes ), $class;
+}
+
+TYPE_OF: {
+ my $method = 'type_of';
+
+ can_ok $obj, $method;
+
+ foreach my $type qw(identifier field) {
+ my ($is_type) = $obj->$method($type);
+ ok $is_type, "object is a type of $type";
+ }
+}
--- /dev/null
+#!perl -T
+
+package My::Test;
+
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 44;
+use Test::NoWarnings;
+use base qw(DBIx::Class::Field::Type::number);
+
+my $class = __PACKAGE__;
+
+my %attributes = ( name => 'number' );
+
+my $obj;
+
+NEW: {
+ my $method = 'new';
+
+ can_ok $class, $method;
+
+ isa_ok $obj = $class->$method( \%attributes ), $class;
+}
+
+ATTRIBUTE_DEFAULTS: {
+ my %attribute_defaults = (
+ name => $attributes{name},
+ min_range => -100**100**100, # negative infinity
+ max_range => 100**100**100, # positive infinity
+ min_precision => -100**100**100, # negative infinity
+ max_precision => 100**100**100, # positive infinity
+ );
+
+ while ( my ( $attr, $default ) = each %attribute_defaults ) {
+ my $accessor = "get_$attr"; # Class::Std naming convention
+ can_ok $obj, $accessor;
+ is_deeply $obj->$accessor, $default, "default for $class->$accessor";
+ }
+}
+
+ATTRIBUTES: {
+ my %attributes = (
+ name => 'unit_price',
+ label => 'Unit Price',
+ min_range => 0,
+ max_range => 1000,
+ min_precision => 2,
+ max_precision => 2,
+ );
+
+ isa_ok $obj = $class->new( \%attributes ), $class;
+
+ while ( my ( $attr, $default ) = each %attributes ) {
+ my $accessor = "get_$attr"; # Class::Std naming convention
+ can_ok $obj, $accessor;
+ is_deeply $obj->$accessor, $default, "value for $class->$accessor";
+
+ next if $attr eq 'name';
+
+ my $mutator = "set_$attr"; # Class::Std naming convention
+ can_ok $obj, $mutator;
+
+ is_deeply(
+ $obj->$mutator(undef), # explicitly set to undef
+ $default, # returns the previous value
+ "previous value $class->$mutator",
+ );
+
+ is $obj->$accessor, undef, 'value is now undef';
+ }
+}
+
+TYPE_OF: {
+ my $method = 'type_of';
+
+ can_ok $obj, $method;
+
+ foreach my $type qw(number field) {
+ my ($is_type) = $obj->$method($type);
+ ok $is_type, "object is a type of $type";
+ }
+}
--- /dev/null
+#!perl -T
+
+package My::Test;
+
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 53;
+use Test::NoWarnings;
+use base qw(DBIx::Class::Field::Type::number);
+
+my $class = __PACKAGE__;
+
+my %attributes = (
+ name => 'unit_price',
+ label => 'Unit Price',
+ min_range => 0,
+ max_range => 1000,
+ min_precision => 2,
+ max_precision => 2,
+);
+
+my $obj;
+
+NEW: {
+ my $method = 'new';
+
+ can_ok $class, $method;
+
+ isa_ok $obj = $class->$method( \%attributes ), $class;
+}
+
+ATTRIBUTES: {
+ while ( my ( $attr, $value ) = each %attributes ) {
+ next if $attr eq 'callbacks';
+
+ my $accessor = "get_$attr"; # Class::Std naming convention
+ can_ok $obj, $accessor;
+ is_deeply $obj->$accessor, $value, "value for $class->$accessor";
+ }
+}
+
+VALIDATE: {
+ my $method = 'validate';
+
+ can_ok $obj, $method;
+
+ foreach my $unit_price qw(0.00 500.00 1000.00) {
+ my @results = $obj->$method($unit_price);
+ is_deeply \@results, [], "$unit_price is a valid " . $obj->get_label;
+ }
+}
+
+VALIDATE_IS_NUMBER: {
+ my $method = 'validate_is_number';
+
+ can_ok $obj, $method;
+
+ my ($error) = $obj->validation_error( is_number => 'is not a number' );
+
+ my $not_a_number = 'some text';
+
+ foreach my $method ( 'validate', $method ) {
+ is_deeply(
+ [ $obj->$method($not_a_number) ],
+ [ $error ],
+ "$not_a_number is invalid, "
+ . $obj->get_label
+ . ' must be a number',
+ );
+
+ is_deeply [ $obj->$method(undef) ], [], 'handles undef';
+ }
+}
+
+VALIDATE_MIN_RANGE: {
+ my $method = 'validate_min_range';
+
+ can_ok $obj, $method;
+
+ my ($error) = $obj->validation_error( min_range => 'is too small' );
+
+ my $unit_price = -0.01;
+
+ foreach my $method ( 'validate', $method ) {
+ is_deeply(
+ [ $obj->$method($unit_price) ],
+ [ $error ],
+ "$unit_price is too small of a value for " . $obj->get_label,
+ );
+ }
+
+ is_deeply [ $obj->$method(undef) ], [], 'handles undef';
+ is_deeply [ $obj->$method('A') ], [], 'handles non-number';
+}
+
+VALIDATE_MAX_RANGE: {
+ my $method = 'validate_max_range';
+
+ can_ok $obj, $method;
+
+ my ($error) = $obj->validation_error( max_range => 'is too large' );
+
+ my $unit_price = 1000.01;
+
+ foreach my $method ( 'validate', $method ) {
+ is_deeply(
+ [ $obj->$method($unit_price) ],
+ [ $error ],
+ "$unit_price is too large of a value for " . $obj->get_label,
+ );
+ }
+
+ is_deeply [ $obj->$method(undef) ], [], 'handles undef';
+ is_deeply [ $obj->$method('A') ], [], 'handles non-number';
+}
+
+VALIDATE_MIN_PRECISION: {
+ my $method = 'validate_min_precision';
+
+ can_ok $obj, $method;
+
+ my ($error) = $obj->validation_error(
+ min_precision => 'has too few digits after the decimal point',
+ );
+
+ foreach my $unit_price (0.1, 1) {
+ foreach my $method ( 'validate', $method ) {
+ is_deeply(
+ [ $obj->$method($unit_price) ],
+ [ $error ],
+ "$unit_price has too few precision places for "
+ . $obj->get_label,
+ );
+ }
+ }
+
+ is_deeply [ $obj->$method(undef) ], [], 'handles undef';
+ is_deeply [ $obj->$method('A') ], [], 'handles non-number';
+}
+
+VALIDATE_MAX_PRECISION: {
+ my $method = 'validate_max_precision';
+
+ can_ok $obj, $method;
+
+ my ($error) = $obj->validation_error(
+ max_precision => 'has too many digits after the decimal point',
+ );
+
+ my $unit_price = 0.001;
+
+ foreach my $method ( 'validate', $method ) {
+ is_deeply(
+ [ $obj->$method($unit_price) ],
+ [ $error ],
+ "$unit_price has too many precision places for "
+ . $obj->get_label,
+ );
+ }
+
+ is_deeply [ $obj->$method(undef) ], [], 'handles undef';
+ is_deeply [ $obj->$method('A') ], [], 'handles non-number';
+}
+
+NO_MIN_MAX_RANGE: {
+ my %attributes = (
+ %attributes,
+ min_range => undef,
+ max_range => undef,
+ );
+
+ isa_ok my $obj = $class->new( \%attributes ), $class;
+
+ foreach my $unit_price ( -0.01, 1000.01 ) {
+ my @results = $obj->validate($unit_price);
+ is_deeply \@results, [], "$unit_price is a valid " . $obj->get_label;
+ }
+}
+
+NO_MIN_MAX_RANGE: {
+ my %attributes = (
+ %attributes,
+ min_precision => undef,
+ max_precision => undef,
+ );
+
+ isa_ok my $obj = $class->new( \%attributes ), $class;
+
+ foreach my $unit_price ( 0.1, 1, 0.001 ) {
+ my @results = $obj->validate($unit_price);
+ is_deeply \@results, [], "$unit_price is a valid " . $obj->get_label;
+ }
+}
--- /dev/null
+#!perl -T
+
+package My::Test;
+
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 23;
+use Test::NoWarnings;
+use base qw(DBIx::Class::Field::Type::object);
+
+my $class = __PACKAGE__;
+
+my %attributes = ( name => 'vehicle' );
+
+my $obj;
+
+NEW: {
+ my $method = 'new';
+
+ can_ok $class, $method;
+
+ isa_ok $obj = $class->$method( \%attributes ), $class;
+}
+
+ATTRIBUTE_DEFAULTS: {
+ my %attribute_defaults = (
+ roles => [],
+ classes => [],
+ );
+
+ while ( my ( $attr, $default ) = each %attribute_defaults ) {
+ my $accessor = "get_$attr"; # Class::Std naming convention
+ can_ok $obj, $accessor;
+ is_deeply $obj->$accessor, $default, "default for $class->$accessor";
+
+ my $mutator = "set_$attr"; # Class::Std naming convention
+ can_ok $obj, $mutator;
+
+ is_deeply(
+ $obj->$mutator(undef), # explicitly set to undef
+ $default, # returns the previous value
+ "previous value $class->$mutator",
+ );
+
+ is $obj->$accessor, undef, 'value is now undef';
+ }
+}
+
+ATTRIBUTES: {
+ my %attributes = (
+ %attributes,
+ roles => [ qw( steer brake gas four_wheel_drive ) ],
+ classes => [ qw( Vehicle Jeep ) ],
+ );
+
+ isa_ok $obj = $class->new( \%attributes ), $class;
+
+ while ( my ( $attr, $default ) = each %attributes ) {
+ my $accessor = "get_$attr"; # Class::Std naming convention
+ can_ok $obj, $accessor;
+ is_deeply $obj->$accessor, $default, "default for $class->$accessor";
+ }
+}
+
+TYPE_OF: {
+ my $method = 'type_of';
+
+ can_ok $obj, $method;
+
+ foreach my $type qw(object field) {
+ my ($is_type) = $obj->$method($type);
+ ok $is_type, "object is a type of $type";
+ }
+}
--- /dev/null
+#!perl -T
+
+package My::Test;
+
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 28;
+use Test::NoWarnings;
+use base qw(DBIx::Class::Field::Type::object);
+
+BEGIN {
+
+ package Vehicle;
+
+ use overload '""' => sub { ref shift };
+
+ sub new { bless {}, shift }
+ sub steer { }
+ sub brake { }
+ sub gas { }
+
+ package Jeep;
+
+ use base qw(Vehicle);
+
+ sub four_wheel_drive { }
+ sub wave { } # Its a Jeep thing
+
+ package Sidekick;
+
+ use base qw(Vehicle);
+
+ sub four_wheel_drive { }
+ sub tip_over { }
+
+ package Pinto;
+
+ use base qw(Vehicle);
+
+ sub blow_up { }
+}
+
+my $class = __PACKAGE__;
+
+my %attributes = (
+ name => 'off_road_vechicle',
+ label => 'Off Road Vehicle',
+ roles => [ qw( steer brake gas four_wheel_drive ) ],
+ classes => [ qw( Vehicle Jeep ) ],
+);
+
+my $obj;
+
+NEW: {
+ my $method = 'new';
+
+ can_ok $class, $method;
+
+ isa_ok $obj = $class->$method( \%attributes ), $class;
+}
+
+ATTRIBUTES: {
+ while ( my ( $attr, $value ) = each %attributes ) {
+ next if $attr eq 'callbacks';
+
+ my $accessor = "get_$attr"; # Class::Std naming convention
+ can_ok $obj, $accessor;
+ is_deeply $obj->$accessor, $value, "value for $class->$accessor";
+ }
+}
+
+VALIDATE: {
+ my $method = 'validate';
+
+ can_ok $obj, $method;
+
+ my $jeep = Jeep->new;
+
+ my @results = $obj->$method($jeep);
+
+ is_deeply \@results, [], "$jeep is a good " . $obj->get_label;
+}
+
+VALIDATE_IS_OBJECT: {
+ my $method = 'validate_is_object';
+
+ can_ok $obj, $method;
+
+ my $car = 'A car';
+
+ my ($error) = $obj->$method( is_object => 'is not an object' );
+
+ foreach my $method ( 'validate', $method ) {
+ is_deeply(
+ [ $obj->$method($car) ],
+ [ $error ],
+ "$car is invalid, " . $obj->get_label . ' must be an object',
+ );
+
+ is_deeply [ $obj->$method(undef) ], [], 'handles undef';
+ }
+}
+
+VALIDATE_ROLES: {
+ my $method = 'validate_roles';
+
+ can_ok $obj, $method;
+
+ my ($error) = $obj->validation_error(
+ roles => 'does not handle the necessary roles',
+ [ qw( four_wheel_drive ) ],
+ );
+
+ my $pinto = Pinto->new;
+
+ is_deeply(
+ [ $obj->$method($pinto) ],
+ [ $error ],
+ "$pinto does not support the necessary roles for "
+ . $obj->get_label,
+ );
+
+ # returns error for the mismatch in classes too
+ my ($classes_error) = $obj->validation_error(
+ classes => 'does not inherit from the necessary classes',
+ [ qw( Jeep ) ],
+ );
+
+ is_deeply(
+ [ $obj->validate($pinto) ],
+ [ $error, $classes_error ],
+ "$pinto does not support the necessary roles for "
+ . $obj->get_label,
+ );
+
+ is_deeply [ $obj->$method(undef) ], [], 'handles undef';
+ is_deeply [ $obj->$method('A') ], [], 'handles non-object';
+}
+
+VALIDATE_CLASSES: {
+ my $method = 'validate_classes';
+
+ can_ok $obj, $method;
+
+ my ($error) = $obj->validation_error(
+ classes => 'does not inherit from the necessary classes',
+ [ qw( Jeep ) ],
+ );
+
+ my $sidekick = Sidekick->new;
+
+ foreach my $method ( 'validate', $method ) {
+ is_deeply(
+ [ $obj->$method($sidekick) ],
+ [ $error ],
+ "$sidekick does not inherit from the necessary classes for "
+ . $obj->get_label,
+ );
+ }
+
+ is_deeply [ $obj->$method(undef) ], [], 'handles undef';
+ is_deeply [ $obj->$method('A') ], [], 'handles non-object';
+}
--- /dev/null
+#!perl -T
+
+package My::Test;
+
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 48;
+use Test::NoWarnings;
+use base qw(DBIx::Class::Field::Type::string);
+
+my $class = __PACKAGE__;
+
+my %attributes = ( name => 'string' );
+
+my $obj;
+
+NEW: {
+ my $method = 'new';
+
+ can_ok $class, $method;
+
+ isa_ok $obj = $class->$method( \%attributes ), $class;
+}
+
+ATTRIBUTE_DEFAULTS: {
+ my %attribute_defaults = (
+ name => $attributes{name},
+ min_length => -100**100**100,
+ max_length => 100**100**100,
+ allowed_chars => [],
+ disallowed_chars => [],
+ format => qr//,
+ );
+
+ while ( my ( $attr, $default ) = each %attribute_defaults ) {
+ my $accessor = "get_$attr"; # Class::Std naming convention
+ can_ok $obj, $accessor;
+ is_deeply $obj->$accessor, $default, "default for $class->$accessor";
+
+ next if $attr eq 'name';
+
+ my $mutator = "set_$attr"; # Class::Std naming convention
+ can_ok $obj, $mutator;
+
+ is_deeply(
+ $obj->$mutator(undef), # explicitly set to undef
+ $default, # returns the previous value
+ "previous value $class->$mutator",
+ );
+
+ is $obj->$accessor, undef, 'value is now undef';
+ }
+}
+
+ATTRIBUTES: {
+ my %attributes = (
+ name => 'first_name',
+ label => 'First Name',
+ min_length => 1,
+ max_length => 40,
+ allowed_chars => [ 'A' .. 'Z', 'a' .. 'z' ],
+ disallowed_chars => [ 'q' ],
+ format => qr/\A[A-Z][a-z]+\z/, # its just a test!
+ );
+
+ isa_ok $obj = $class->new( \%attributes ), $class;
+
+ while ( my ( $attr, $default ) = each %attributes ) {
+ my $accessor = "get_$attr"; # Class::Std naming convention
+ can_ok $obj, $accessor;
+ is_deeply $obj->$accessor, $default, "value for $class->$accessor";
+ }
+}
+
+TYPE_OF: {
+ my $method = 'type_of';
+
+ can_ok $obj, $method;
+
+ foreach my $type qw(string field) {
+ my ($is_type) = $obj->$method($type);
+ ok $is_type, "object is a type of $type";
+ }
+}
--- /dev/null
+#!perl -T
+
+package My::Test;
+
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 54;
+use Test::NoWarnings;
+use base qw(DBIx::Class::Field::Type::string);
+
+my $class = __PACKAGE__;
+
+my %attributes = (
+ name => 'first_name',
+ label => 'First Name',
+ min_length => 1,
+ max_length => 40,
+ allowed_chars => [ 'A' .. 'Y', 'a' .. 'y' ],
+ disallowed_chars => [ 'q' ],
+ format => qr/\A(?:[A-Z][a-z]*)?\z/, # its just a test!
+);
+
+my $obj;
+
+NEW: {
+ my $method = 'new';
+
+ can_ok $class, $method;
+
+ isa_ok $obj = $class->$method( \%attributes ), $class;
+}
+
+ATTRIBUTES: {
+ while ( my ( $attr, $value ) = each %attributes ) {
+ next if $attr eq 'callbacks';
+
+ my $accessor = "get_$attr"; # Class::Std naming convention
+ can_ok $obj, $accessor;
+ is_deeply $obj->$accessor, $value, "value for $class->$accessor";
+ }
+}
+
+VALIDATE: {
+ my $method = 'validate';
+
+ can_ok $obj, $method;
+
+ my $first_name = 'Dan';
+
+ my @results = $obj->$method($first_name);
+ is_deeply \@results, [], "$first_name is a valid " . $obj->get_label;
+}
+
+VALIDATE_IS_STRING: {
+ my $method = 'validate_is_string';
+
+ can_ok $obj, $method;
+
+ my ($error) = $obj->validation_error( is_string => 'is not a string' );
+
+ my $hash_ref = {};
+
+ foreach my $method ( 'validate', $method ) {
+ is_deeply(
+ [ $obj->$method($hash_ref) ],
+ [ $error ],
+ "$hash_ref is invalid, " . $obj->get_label . ' must be a string',
+ );
+
+ is_deeply [ $obj->$method(undef) ], [], 'handles undef';
+ }
+}
+
+VALIDATE_MIN_LENGTH: {
+ my $method = 'validate_min_length';
+
+ can_ok $obj, $method;
+
+ my ($error) = $obj->validation_error( min_length => 'is too short' );
+
+ my $first_name = '';
+
+ foreach my $method ( 'validate', $method ) {
+ is_deeply(
+ [ $obj->$method($first_name) ],
+ [ $error ],
+ "$first_name is too short of a value for " . $obj->get_label,
+ );
+ }
+
+ is_deeply [ $obj->$method(undef) ], [], 'handles undef';
+ is_deeply [ $obj->$method( {} ) ], [], 'handles non-string';
+}
+
+VALIDATE_MAX_LENGTH: {
+ my $method = 'validate_max_length';
+
+ can_ok $obj, $method;
+
+ my ($error) = $obj->validation_error( max_length => 'is too long' );
+
+ my $first_name = 'A' . 'a' x 40;
+
+ foreach my $method ( 'validate', $method ) {
+ is_deeply(
+ [ $obj->$method($first_name) ],
+ [ $error ],
+ "$first_name is too long of a value for " . $obj->get_label,
+ );
+ }
+
+ is_deeply [ $obj->$method(undef) ], [], 'handles undef';
+ is_deeply [ $obj->$method( {} ) ], [], 'handles non-string';
+}
+
+VALIDATE_ALLOWED_CHARS: {
+ my $method = 'validate_allowed_chars';
+
+ can_ok $obj, $method;
+
+ my ($error) = $obj->validation_error(
+ allowed_chars => 'contains characters that are not allowed',
+ [ 'Z' ],
+ );
+
+ my $first_name = 'Zoltan';
+
+ foreach my $method ( 'validate', $method ) {
+ is_deeply(
+ [ $obj->$method($first_name) ],
+ [ $error ],
+ "$first_name constains invalid characters for " . $obj->get_label,
+ );
+ }
+
+ is_deeply [ $obj->$method(undef) ], [], 'handles undef';
+ is_deeply [ $obj->$method( {} ) ], [], 'handles non-string';
+}
+
+VALIDATE_DISALLOWED_CHARS: {
+ my $method = 'validate_disallowed_chars';
+
+ can_ok $obj, $method;
+
+ my ($error) = $obj->validation_error(
+ disallowed_chars => 'contains characters that are disallowed',
+ [ 'q' ],
+ );
+
+ my $first_name = 'Dq';
+
+ foreach my $method ( 'validate', $method ) {
+ is_deeply(
+ [ $obj->$method($first_name) ],
+ [ $error ],
+ "$first_name constains invalid characters for " . $obj->get_label,
+ );
+ }
+
+ is_deeply [ $obj->$method(undef) ], [], 'handles undef';
+ is_deeply [ $obj->$method( {} ) ], [], 'handles non-string';
+}
+
+VALIDATE_FORMAT: {
+ my $method = 'validate_format';
+
+ can_ok $obj, $method;
+
+ my ($error) = $obj->validation_error(
+ format => 'does not match the expected format',
+ );
+
+ my $first_name = 'DAN';
+
+ foreach my $method ( 'validate', $method ) {
+ is_deeply(
+ [ $obj->$method($first_name) ],
+ [ $error ],
+ "$first_name is an invalid format for " . $obj->get_label,
+ );
+ }
+
+ is_deeply [ $obj->$method(undef) ], [], 'handles undef';
+ is_deeply [ $obj->$method( {} ) ], [], 'handles non-string';
+}
+
+NO_ALLOWED_DISALLOWED_CHARS: {
+ my %attributes = (
+ %attributes,
+ allowed_chars => [],
+ disallowed_chars => [],
+ );
+
+ isa_ok my $obj = $class->new( \%attributes ), $class;
+
+ my $first_name = 'Dan';
+
+ my @results = $obj->validate($first_name);
+ is_deeply \@results, [], "$first_name is a valid " . $obj->get_label;
+}
+
+NO_MIN_MAX_LENGTH: {
+ my %attributes = (
+ %attributes,
+ min_length => undef,
+ max_length => undef,
+ );
+
+ isa_ok my $obj = $class->new( \%attributes ), $class;
+
+ foreach my $first_name ( 'A', 'A' . 'a' x 40 ) {
+ my @results = $obj->validate($first_name);
+ is_deeply \@results, [], "$first_name is a valid " . $obj->get_label;
+ }
+}
--- /dev/null
+#!perl -T
+
+package My::Test;
+
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 46;
+use Test::Exception;
+use Test::NoWarnings;
+use base qw(DBIx::Class::Field);
+
+my $class = __PACKAGE__;
+
+my $obj;
+
+NEW: {
+ my $method = 'new';
+
+ can_ok $class, $method;
+
+ isa_ok $obj = $class->$method( { name => 'id' } ), $class;
+}
+
+ATTRIBUTE_DEFAULTS: {
+ my %attribute_defaults = (
+ label => undef,
+ description => undef,
+ allowed_values => [],
+ callbacks => [],
+ disallowed_values => [],
+ is_read_only => 0,
+ is_required => 0,
+ default => undef,
+ );
+
+ while ( my ( $attr, $default ) = each %attribute_defaults ) {
+ my $accessor = "get_$attr"; # Class::Std naming convention
+
+ can_ok $obj, $accessor;
+ is_deeply $obj->$accessor, $default, "default for $class->$accessor";
+
+ my $mutator = "set_$attr"; # Class::Std naming convention
+ can_ok $obj, $mutator;
+
+ is_deeply(
+ $obj->$mutator(undef), # explicitly set to undef
+ $default, # returns the previous value
+ "previous value $class->$mutator",
+ );
+
+ is $obj->$accessor, undef, 'value is now undef';
+ }
+}
+
+TYPE_OF: {
+ my $method = 'type_of';
+
+ can_ok $obj, $method;
+
+ my ($is_field) = $obj->$method('field');
+ ok $is_field, 'object is a type of field';
+
+ my ($is_thingy) = $obj->$method('thingy');
+ ok !$is_thingy, 'object is not a type of thingy';
+}
--- /dev/null
+#!perl -T
+
+package My::Test;
+
+# TODO: handle cases where the underlying attribute value is
+# undef. With the introduction of the set_* methods this is
+# possible, although unlikely.
+
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 51;
+use Test::Exception;
+use Test::NoWarnings;
+use base qw(DBIx::Class::Field);
+
+my $class = __PACKAGE__;
+
+my %attributes = (
+ name => 'customer_id',
+ label => 'Customer ID',
+ description => 'A unique identifier for a customer',
+ allowed_values => [ 2 .. 10 ],
+ disallowed_values => [ 7 ],
+ callbacks => [ \&odd_numbers_only, 'odd_numbers_only' ],
+ is_read_only => 1,
+ is_required => 1,
+ default => 1,
+);
+
+my $obj;
+
+NEW: {
+ my $method = 'new';
+
+ can_ok $class, $method;
+
+ isa_ok $obj = $class->$method( \%attributes ), $class;
+}
+
+ATTRIBUTES: {
+ while ( my ( $attr, $value ) = each %attributes ) {
+ next if $attr eq 'callbacks';
+
+ my $accessor = "get_$attr"; # Class::Std naming convention
+ can_ok $obj, $accessor;
+ is_deeply $obj->$accessor, $value, "value for $class->$accessor";
+ }
+}
+
+VALIDATE: {
+ my $method = 'validate';
+
+ can_ok $obj, $method;
+
+ foreach my $id qw(3 5 9) {
+ my @results = $obj->$method($id);
+ is_deeply \@results, [], "$id is valid " . $obj->get_label;
+ }
+}
+
+VALIDATION_ERROR_WITH_LABEL: {
+ my $method = 'validation_error';
+
+ can_ok $obj, $method;
+
+ my %error = (
+ rule => 'rule_name',
+ message => 'Customer ID rule message',
+ );
+
+ my ($error) = $obj->validation_error( rule_name => 'rule message' );
+
+ is_deeply( $error, \%error, 'error message is correct' );
+}
+
+VALIDATION_ERROR_WITH_FIELD_NAME: {
+ my $obj = $class->new( { name => 'customer_id' } );
+
+ my %error = (
+ rule => 'rule_name',
+ message => 'customer_id rule message',
+ );
+
+ my ($error) = $obj->validation_error( rule_name => 'rule message' );
+
+ is_deeply( $error, \%error, 'error message is correct' );
+}
+
+VALIDATE_IS_REQUIRED: {
+ my $method = 'validate_is_required';
+
+ can_ok $obj, $method;
+
+ my ($error) = $obj->validation_error( is_required => 'is required' );
+
+ my $undef = undef;
+
+ foreach my $method ( 'validate', $method ) {
+ is_deeply(
+ [ $obj->$method($undef) ],
+ [ $error ],
+ "value cannot be undefined for " . $obj->get_label,
+ );
+ }
+}
+
+VALIDATE_ALLOWED_VALUES: {
+ my $method = 'validate_allowed_values';
+
+ can_ok $obj, $method;
+
+ my ($error) = $obj->validation_error(
+ allowed_values => 'is not an allowed value',
+ );
+
+ foreach my $not_allowed qw(1 11) {
+ foreach my $method ( 'validate', $method ) {
+ is_deeply(
+ [ $obj->$method($not_allowed) ],
+ [ $error ],
+ "$not_allowed is not an allowed value for " . $obj->get_label,
+ );
+ }
+ }
+
+ is_deeply [ $obj->$method(undef) ], [], 'handles undef';
+}
+
+VALIDATE_DISALLOWED_VALUES: {
+ my $method = 'validate_disallowed_values';
+
+ can_ok $obj, $method;
+
+ my ($error) = $obj->validation_error(
+ disallowed_values => 'is a disallowed value',
+ );
+
+ my $disallowed = 7;
+
+ foreach my $method ( 'validate', $method ) {
+ is_deeply(
+ [ $obj->$method($disallowed) ],
+ [ $error ],
+ "$disallowed is a disallowed value for " . $obj->get_label,
+ );
+ }
+
+ is_deeply [ $obj->$method(undef) ], [], 'handles undef';
+}
+
+VALIDATE_CALLBACKS: {
+ my $method = 'validate_callbacks';
+
+ can_ok $obj, $method;
+
+ my ($error) = $obj->validation_error(
+ odd_numbers_only => 'must be an odd number',
+ );
+
+ # testing both the subref and method-style of callbacks
+ # at the same time therefore two identical errors are
+ # expected.
+
+ foreach my $even qw(2 4 6 8) {
+ foreach my $method ( 'validate', $method ) {
+ is_deeply(
+ [ $obj->$method($even) ],
+ [ $error, $error ],
+ "$even is even, but " . $obj->get_label . ' must be odd',
+ );
+ }
+ }
+
+ is_deeply [ $obj->$method(undef) ], [], 'handles undef';
+}
+
+BAD_CALLBACK_RULE: {
+ my $obj = $class->new({
+ name => 'id',
+ callbacks => [ qr// ], # can only be a method or subref
+ });
+
+ dies_ok { $obj->validate(1) } 'callback rule invalid';
+ dies_ok { $obj->validate_callbacks(1) } 'callback rule invalid';
+}
+
+sub odd_numbers_only : method {
+ my ( $obj, $value ) = @_;
+
+ return if $value % 2;
+
+ return $obj->validation_error(
+ odd_numbers_only => 'must be an odd number',
+ );
+}
--- /dev/null
+#!perl -T
+
+package My::Test;
+
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 15;
+use Test::Exception;
+use Test::NoWarnings;
+use base qw(DBIx::Class::Validation);
+
+BEGIN {
+ __PACKAGE__->load_types('column');
+}
+
+my $class = __PACKAGE__;
+
+ISA: {
+ ok(
+ UNIVERSAL::isa( $class, 'DBIx::Class::Validation' ),
+ "$class is a DBIx::Class::Validation",
+ );
+}
+
+my $field = My::Test->get_field('id');
+my $field_name = $field->get_name;
+my $column_type = 'DBIx::Class::Field::Type::column';
+
+isa_ok $field, $class .'::Field::id';
+
+SET_FIELD_COMMON: {
+ my %attr = (
+ column_name => 'Test ID',
+ deflate => [],
+ inflate => [],
+ );
+
+ while ( my ( $attr, $value ) = each %attr ) {
+ my $mutator = "set_field_$attr";
+
+ can_ok $class, $mutator;
+ is(
+ $class->$mutator( $field_name => $value ),
+ undef,
+ "set field $attr",
+ );
+
+ my $accessor = "get_$attr";
+ is $field->$accessor, $value, "get field $attr";
+
+ # returns the previous value on-set
+ is(
+ $class->$mutator( $field_name => $value ),
+ $value,
+ "set field $attr",
+ );
+ }
+}
--- /dev/null
+#!perl -T
+
+package My::Test;
+
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 25;
+use Test::Exception;
+use Test::NoWarnings;
+use base qw(DBIx::Class::Validation);
+
+BEGIN {
+ __PACKAGE__->load_types('number');
+}
+
+my $class = __PACKAGE__;
+
+ISA: {
+ ok(
+ UNIVERSAL::isa( $class, 'DBIx::Class::Validation' ),
+ "$class is a DBIx::Class::Validation",
+ );
+}
+
+my $field = My::Test->get_field('id');
+my $field_name = $field->get_name;
+
+isa_ok $field, $class .'::Field::id';
+
+VALIDATES_NUMERICALITY_OF: {
+ my $method = 'validates_numericality_of';
+
+ can_ok $class, $method;
+
+ my $number_type = 'DBIx::Class::Field::Type::number';
+
+ ok(
+ !$field->isa($number_type),
+ "$field_name is not a type of number",
+ );
+
+ is(
+ $class->$method( $field_name ),
+ undef,
+ "$method should be called in void context",
+ );
+
+ isa_ok $field, $number_type;
+
+ is $field->type_of('number'), 1, "$field_name is a number type";
+ is $field->type_of('field'), 1, "$field_name is a field type";
+}
+
+VALIDATES_RANGE_OF: {
+ my $method = 'validates_range_of';
+
+ can_ok $class, $method;
+
+ my %opt = (
+ min => 1,
+ max => 40,
+ );
+
+ my %change = (
+ min => 10,
+ max => 20,
+ );
+
+ is(
+ $class->$method($field_name => \%opt),
+ undef,
+ "$method should be called in void context",
+ );
+
+ foreach my $key (keys %opt) {
+ my $accessor = "get_${key}_range";
+ is(
+ $field->$accessor,
+ $opt{$key},
+ "$field_name $key range is set",
+ );
+
+ is(
+ $class->$method($field_name => { $key => $change{$key} }),
+ undef,
+ "$method should be called in void context",
+ );
+
+ is(
+ $field->$accessor,
+ $change{$key},
+ "$field_name $key range is changed",
+ );
+ }
+}
+
+VALIDATES_PRECISION_OF: {
+ my $method = 'validates_precision_of';
+
+ can_ok $class, $method;
+
+ my %opt = (
+ min => 1,
+ max => 3,
+ );
+
+ my %change = (
+ min => 2,
+ max => 4,
+ );
+
+ is(
+ $class->$method($field_name => \%opt),
+ undef,
+ "$method should be called in void context",
+ );
+
+ foreach my $key (keys %opt) {
+ my $accessor = "get_${key}_precision";
+ is(
+ $field->$accessor,
+ $opt{$key},
+ "$field_name $key precision is set",
+ );
+
+ is(
+ $class->$method($field_name => { $key => $change{$key} }),
+ undef,
+ "$method should be called in void context",
+ );
+
+ is(
+ $field->$accessor,
+ $change{$key},
+ "$field_name $key precision is changed",
+ );
+ }
+}
--- /dev/null
+#!perl -T
+
+package My::Test;
+
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 14;
+use Test::Exception;
+use Test::NoWarnings;
+use base qw(DBIx::Class::Validation);
+
+BEGIN {
+ __PACKAGE__->load_types('object');
+}
+
+my $class = __PACKAGE__;
+
+ISA: {
+ ok(
+ UNIVERSAL::isa( $class, 'DBIx::Class::Validation' ),
+ "$class is a DBIx::Class::Validation",
+ );
+}
+
+my $field = My::Test->get_field('id');
+my $field_name = $field->get_name;
+my $object_type = 'DBIx::Class::Field::Type::object';
+
+isa_ok $field, $class .'::Field::id';
+
+VALIDATES: {
+ my %attr = (
+ roles => [ qw( foo bar baz ) ],
+ classes => [ qw( Foo Bar Baz ) ],
+ );
+
+ ok(
+ !$field->isa($object_type),
+ "$field_name is not a type of object",
+ );
+
+ while ( my($attr, $value) = each %attr) {
+ my $method = "validates_${attr}_of";
+
+ is(
+ $class->$method( $field_name => $value ),
+ undef,
+ "$method should be called in void context",
+ );
+
+ my $accessor = "get_${attr}";
+
+ is_deeply(
+ $field->$accessor,
+ $value,
+ "$field_name has a correct value for $attr",
+ );
+
+ # field type has now been changed to object
+ isa_ok $field, $object_type;
+ is $field->type_of('object'), 1, "$field_name is a object type";
+ is $field->type_of('field'), 1, "$field_name is a field type";
+ }
+}
--- /dev/null
+#!perl -T
+
+package My::Test;
+
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 21;
+use Test::Exception;
+use Test::NoWarnings;
+use base qw(DBIx::Class::Validation);
+
+BEGIN {
+ __PACKAGE__->load_types('string');
+}
+
+my $class = __PACKAGE__;
+
+ISA: {
+ ok(
+ UNIVERSAL::isa( $class, 'DBIx::Class::Validation' ),
+ "$class is a DBIx::Class::Validation",
+ );
+}
+
+my $field = My::Test->get_field('id');
+my $field_name = $field->get_name;
+my $string_type = 'DBIx::Class::Field::Type::string';
+
+isa_ok $field, $class .'::Field::id';
+
+VALIDATES_LENGTH_OF: {
+ my $method = 'validates_length_of';
+
+ can_ok $class, $method;
+
+ my %opt = (
+ min => 1,
+ max => 40,
+ );
+
+ my %change = (
+ min => 10,
+ max => 20,
+ );
+
+ ok(
+ !$field->isa($string_type),
+ "$field_name is not a type of string",
+ );
+
+ is(
+ $class->$method($field_name => \%opt),
+ undef,
+ "$method should be called in void context",
+ );
+
+ # field type has now been changed to string
+ isa_ok $field, $string_type;
+ is $field->type_of('string'), 1, "$field_name is a string type";
+ is $field->type_of('field'), 1, "$field_name is a field type";
+
+ foreach my $key (keys %opt) {
+ my $accessor = "get_${key}_length";
+ is(
+ $field->$accessor,
+ $opt{$key},
+ "$field_name $key length is set",
+ );
+
+ is(
+ $class->$method($field_name => { $key => $change{$key} }),
+ undef,
+ "$method should be called in void context",
+ );
+
+ is(
+ $field->$accessor,
+ $change{$key},
+ "$field_name $key length is changed",
+ );
+ }
+}
+
+VALIDATES: {
+ my %attr = (
+ allowed_chars => [ qw( a b c d e ) ],
+ disallowed_chars => [ qw( f g h i j ) ],
+ format => qr/.*/,
+ );
+
+ while ( my($attr, $value) = each %attr) {
+ my $method = "validates_${attr}_of";
+
+ is(
+ $class->$method( $field_name => $value ),
+ undef,
+ "$method should be called in void context",
+ );
+
+ my $accessor = "get_${attr}";
+
+ is_deeply(
+ $field->$accessor,
+ $value,
+ "$field_name has a correct value for $attr",
+ );
+ }
+}
--- /dev/null
+#!perl -T
+
+package My::Test;
+
+use strict;
+use warnings FATAL => 'all';
+use Test::More tests => 45;
+use Test::Exception;
+use Test::NoWarnings;
+use base qw(DBIx::Class::Validation);
+
+my $class = __PACKAGE__;
+
+ISA: {
+ ok( UNIVERSAL::isa( $class, 'DBIx::Class::Validation' ),
+ "$class is a DBIx::Class::Validation",
+ );
+}
+
+LOAD_TYPES: {
+ my $method = 'load_types';
+
+ can_ok $class, $method;
+
+ my $isa = \our @ISA;
+ my @expect = qw(DBIx::Class::Validation);
+
+ is_deeply( $isa, \@expect, 'ISA contains only validation' );
+
+ $class->$method(qw(number));
+
+ push @expect, qw(DBIx::Class::Validation::Type::number);
+
+ is_deeply( $isa, \@expect, 'ISA contains validation type classes' );
+
+ dies_ok { $class->$method('croak') } 'cannot load non-existent types';
+}
+
+my $field;
+
+GET_FIELD: {
+ my $method = 'get_field';
+
+ can_ok $class, $method;
+
+ isa_ok $field = $class->$method('id'), $class . '::Field::id';
+ is ref $field, $class . '::Field::id', 'correct object';
+ is $field, $class->$method('id'), 'unique instance';
+
+ dies_ok { $class->$method(undef) } 'must supply a field name';
+}
+
+my $field_name = $field->get_name;
+
+SET_FIELD_COMMON: {
+ my %attr = (
+ label => 'Test ID',
+ description => 'a test identifier',
+ default => 1,
+ );
+
+ while ( my ( $attr, $value ) = each %attr ) {
+ my $mutator = "set_field_$attr";
+
+ can_ok $class, $mutator;
+ is(
+ $class->$mutator( $field_name => $value ),
+ undef,
+ "set field $attr",
+ );
+
+ my $accessor = "get_$attr";
+ is $field->$accessor, $value, "get field $attr";
+
+ # returns the previous value on-set
+ is(
+ $class->$mutator( $field_name => $value ),
+ $value,
+ "set field $attr",
+ );
+ }
+}
+
+SET_FIELD_READ_ONLY: {
+ my $method = 'set_field_read_only';
+
+ can_ok $class, $method;
+
+ is $field->get_is_read_only, 0, "$field_name is not read only";
+ is $class->$method('id'), 0, "$field_name set to read only";
+ is $field->get_is_read_only, 1, "$field_name is now read only";
+}
+
+SET_FIELD: {
+ my $method = 'set_field';
+
+ can_ok $class, $method;
+
+ my %attr = (
+ label => 'Field',
+ description => 'test',
+ default => 'a default value',
+ read_only => 1,
+ );
+
+ is(
+ $class->$method( $field_name => \%attr ),
+ undef,
+ 'set all fields',
+ );
+
+ while ( my ( $attr, $value ) = each %attr ) {
+ my $accessor = $attr eq 'read_only' ? 'get_is_read_only'
+ : "get_$attr"
+ ;
+
+ is $field->$accessor, $value, "field $attr is set";
+ }
+}
+
+VALIDATES_PRESENCE_OF: {
+ my $method = 'validates_presence_of';
+
+ can_ok $class, $method;
+
+ is(
+ $class->$method( $field_name ),
+ undef,
+ "$method should be called in void context",
+ );
+
+ is $field->get_is_required, 1, "$field_name is now required";
+}
+
+VALIDATES_ALLOWED_VALUES_OF: {
+ my $method = 'validates_allowed_values_of';
+
+ can_ok $class, $method;
+
+ my @allowed_values = qw(foo bar baz);
+
+ is(
+ $class->$method( $field_name => \@allowed_values ),
+ undef,
+ "$method should be called in void context",
+ );
+
+ is_deeply(
+ $field->get_allowed_values,
+ \@allowed_values,
+ "$field_name has allowed values",
+ );
+}
+
+VALIDATES_DISALLOWED_VALUES_OF: {
+ my $method = 'validates_disallowed_values_of';
+
+ can_ok $class, $method;
+
+ my @disallowed_values = qw(fubar);
+
+ is(
+ $class->$method( $field_name => \@disallowed_values ),
+ undef,
+ "$method should be called in void context",
+ );
+
+ is_deeply(
+ $field->get_disallowed_values,
+ \@disallowed_values,
+ "$field_name has disallowed values",
+ );
+}
+
+VALIDATES_EACH_WITH: {
+ my $method = 'validates_each_with';
+
+ can_ok $class, $method;
+
+ my @callbacks = ( sub { } );
+
+ is(
+ $class->$method( $field_name => \@callbacks ),
+ undef,
+ "$method should be called in void context",
+ );
+
+ is_deeply(
+ $field->get_callbacks,
+ \@callbacks,
+ "$field_name has callbacks",
+ );
+}
--- /dev/null
+01core.t
+02pod.t
+03podcoverage.t
+04db.t
+05multipk.t
+06relationship.t
+08inflate.t
+08inflate_has_a.t
+09update.t
+10auto.t
+11mysql.t
+12pg.t
+13oracle.t
+14mssql.t
+15limit.t
+cdbi-t/01-columns.t
+cdbi-t/02-Film.t
+cdbi-t/03-subclassing.t
+cdbi-t/04-lazy.t
+cdbi-t/06-hasa.t
+cdbi-t/08-inheritcols.t
+cdbi-t/09-has_many.t
+cdbi-t/11-triggers.t
+cdbi-t/12-filter.t
+cdbi-t/13-constraint.t
+cdbi-t/14-might_have.t
+cdbi-t/15-accessor.t
+cdbi-t/16-reserved.t
+cdbi-t/18-has_a.t
+cdbi-t/19-set_sql.t
+cdbi-t/21-iterator.t
+cdbi-t/98-failure.t
+DBIx/Class/Field/basic.t
+DBIx/Class/Field/validate.t
+DBIx/Class/Field/Singleton/basic.t
+DBIx/Class/Field/Type/auto_increment/basic.t
+DBIx/Class/Field/Type/column/basic.t
+DBIx/Class/Field/Type/identifier/basic.t
+DBIx/Class/Field/Type/number/basic.t
+DBIx/Class/Field/Type/number/validate.t
+DBIx/Class/Field/Type/object/basic.t
+DBIx/Class/Field/Type/object/validate.t
+DBIx/Class/Field/Type/string/basic.t
+DBIx/Class/Field/Type/string/validate.t
+DBIx/Class/Validation/basic.t
+DBIx/Class/Validation/Type/column/basic.t
+DBIx/Class/Validation/Type/number/basic.t
+DBIx/Class/Validation/Type/object/basic.t
+DBIx/Class/Validation/Type/string/basic.t
projects / dbsrgits/DBIx-Class-Historic.git / commitdiff