DBIx-Class-Validation-Structure
view release on metacpan or search on metacpan
lib/DBIx/Class/Validation/Structure.pm view on Meta::CPAN
# and the primary columns haven't changed
next if $constraint eq 'primary' and $self->in_storage and not primary_cols_have_changed($self);
my $search = {
map {
next unless ( not keys %$check_columns ) or $check_columns->{$_};
($_ => $data->{$_}) } @{ $unique_constraints{$constraint} }
};
# Exclude this entries primary keys to the search for dupes
# to not detect itself when updating.
unless ( $constraint eq 'primary' ) {
for my $column ( $source->primary_columns ) {
$search->{$column} = {
'!=' => $data->{$column},
};
}
}
# If there is an entry with the combined value defined above...
if ( $source->resultset->count($search) ) {
foreach my $key ( @{ $unique_constraints{$constraint} } ) {
$errors{$key} = [] unless defined $errors{$key};
my @other_fields = @{ $unique_constraints{$constraint} };
# Remove the field so we get a list of other fields in the
# combination
my $index = 0;
$index++ until $other_fields[$index] eq $key;
splice(@other_fields, $index, 1);
# If there are no keys other than the key that isnt unique,
# then write the error as singular else explain the combination.
if ( $#other_fields >= 0 ) {
push @{$errors{$key}}, { $key => 'must be unique when combined with '.join(', ',@other_fields) };
} else {
push @{$errors{$key}}, { $key => 'must be unique' };
}
}
}
}
if ( %errors ) {
# Convert hash into the array of hashrefs like the validate returns
return map { { $_ => join( ' and ', map { values %$_ } @{ $errors{$_} } ) } } keys %errors;
} else {
return ();
}
}
sub insert {
my $self = shift;
my $result = $self->validate;
# If errors return the result
if ($result->{errors}) {
return $result;
} else {
# Else do the normal insert
$self->next::method(@_);
}
}
sub update {
my $self = shift;
my $columns = shift;
$self->set_inflated_columns($columns) if $columns;
my $result = $self->validate;
# If errors return the result
if ($result->{errors}) {
return $result;
} else {
# Else do the normal update
$self->next::method(@_);
}
}
# =============== Validatators ===============
sub _val_email {
my ($mand, $value) = @_;
if (not defined $value) { $value = ''; }
if ( !Email::Valid->address($value) && $mand ) {
return ( undef, { msg => 'address is blank or not valid' } );
} elsif ( !Email::Valid->address($value) && $value ) {
return ( undef, { msg => 'address is blank or not valid' } );
} else {
return $value;
}
}
sub _val_text {
my ($mand, $len, $value) = @_;
if ($mand && ( not( defined $value ) or $value eq '' )) {
return (undef, { msg => 'cannot be blank' });
} elsif ($len && length($value) && (length($value) > $len) ) {
return (undef, { msg => 'is limited to '.$len.' characters' });
} elsif (defined $value && $value !~ /^([\d \.\,\-\'\"\!\$\#\%\=\&\:\+\(\)\[\]\?\;\n\r\<\>\/\@\w]*)$/) {
return (undef, { msg => 'can only use letters, 0-9 and -.,\'\"!&#$?:()[]=%<>;/@ (do not cut and paste from a Word document, you must Save As text only)' });
} else {
# This is to ensure that $1 is from the last regex match
if (defined $value) {
return ($1);
} else {
return $value;
}
}
}
# _val_password is the same as _val_text but it also allows {}s
sub _val_password {
my ($mand, $len, $value) = @_;
if ($mand && (!$value || $value =~ /bogus="1"/)) { #tiny mce
return (undef, { msg => 'cannot be blank' });
} elsif ($len && length($value) && (length($value) > $len) ) {
return (undef, { msg => 'is limited to '.$len.' characters' });
} elsif ($value && $value !~ /^([\w \.\,\-\'\"\!\$\#\%\=\&\:\+\(\)\[\]\{\}\?\;\n\r\<\>\/\@\w]*)$/) {
return (undef, { msg => 'can only use letters, 0-9 and -.,\'\"!&#$?:()[]=%<>;/@ (do not cut and paste from a Word document, you must Save As text only)' });
} else {
my $tf = new HTML::TagFilter;
( run in 1.348 second using v1.01-cache-2.11-cpan-13bb782fe5a )