• Files
• Commits
• Log
• Graph
• Stats

package LIMS::Validate::Roles::ConstraintMethods;

# contains constraint_method helper methods for LIMS::Validate

use Moose::Role;
use namespace::clean -except => 'meta';

use Data::Dumper;
use LIMS::Local::Utils;
use FormValidator::Simple qw(+LIMS::Validate::DatePlugin);
use Data::FormValidator::Constraints
	qw(:regexp_common FV_max_length FV_length_between valid_email);
use Data::FormValidator::Constraints::DateTime qw(:all); # using: ymd_before_today()
use Data::FormValidator::Constraints::MethodsFactory qw(:bool); # FV_and

#-------------------------------------------------------------------------------
sub check_nhsno_is_valid {
	my $self = shift; # warn 'here'; warn Dumper $self;
	
	return sub {
		my $dfv = shift; # warn 'here'; warn Dumper $dfv;
		my $nhs_number = shift || return 0; # warn 'NHSNo:'.$nhs_number;

		$dfv->name_this('is_valid');
		
		# check_nhsno() return true if valid:
		my $is_valid = LIMS::Local::Utils::check_nhsno( $nhs_number ); # warn $is_valid;
		return $is_valid;
	}
}

#-------------------------------------------------------------------------------
sub check_nhsno_is_unique {
	my $self = shift; 

	return sub {
		my $dfv = shift; # warn 'here'; warn Dumper $dfv;
		my $nhs_number = shift || return 0; # warn 'NHSNo:'.$nhs_number;

		$dfv->name_this('is_unique');

		my $validation_model = $self->models->{validate_nhs_number_unique};

		my $not_unique = $validation_model->($nhs_number);

		return $not_unique ? 0 : 1;
	}
}

#-------------------------------------------------------------------------------
sub check_email_is_valid {
	my $self = shift;
	
	return sub {
		my ($dfv, $email) = @_; # warn $email;
		return valid_email($email); # Data::FormValidator::Constraints method
	}	
}

#-------------------------------------------------------------------------------
sub check_emails_match {
	return sub {
		my $dfv = shift; # DEBUG($dfv);
		$dfv->name_this('email_mismatch'); 

		my $data = $dfv->get_filtered_data; # DEBUG($data);    	
		return ($data->{email} eq $data->{email2}); # returns truth
	};
}

#-------------------------------------------------------------------------------
sub check_post_code_is_valid {
	my $self = shift;
	
	return sub {
		my ($dfv, $zip) = @_; # warn $zip;
		return LIMS::Local::Utils::format_postcode($zip);
	}	
}

#-------------------------------------------------------------------------------
sub check_email_domain {
	my $self = shift;

	my $settings = $self->settings;
	my @valid_domains = split /\,\s?|\s+/, $settings->{valid_recipient_domains};

	return sub {
		my ($dfv, $email) = @_; # warn $email;
		return grep $email =~ /$_\Z/, @valid_domains;
	}	
}

#-------------------------------------------------------------------------------
sub check_no_spaces {
	my $self = shift; 

	return sub {
		my $dfv = shift; # warn 'here';		
		$dfv->name_this('no_spaces');
		
		my $val = $dfv->get_current_constraint_value(); # warn $val;
		
		my ($is_valid) = $val =~ /^[a-zA-Z0-9_]+$/; # warn $is_valid;

		return $is_valid;
	}	
}

#-------------------------------------------------------------------------------
# used by new_request() & Ajax::_validate_params()
sub get_request_number_constraints {
	my $self = shift;

	my $is_unique = sub {
		my $dfv = shift; # warn 'here';		
		$dfv->name_this('is_unique');
				
		my $val = $dfv->get_current_constraint_value(); # warn $val;
		my $uniqueness = $self->check_request_number($val);
				
		return $uniqueness;
	};
	
	return [ # TODO: join_these() doesn't work here
		$is_unique, # check it's unqiue
		FV_num_int, # must be integer; Regexp::Common, s/RE/FV/
		$self->check_param_length( [1,5] ), # don't expect >99_999/yr
#		FV_clamp(1, 1, 5), # MethodsFactory method - no configurable msgs output ?
	];
}

#-------------------------------------------------------------------------------
# used by new_request() & Ajax::_validate_params()
sub get_request_number_messages { 
	my $self = shift;

	return { # messages need to be set to constraint_names, not field_names:
		constraints => {
			is_unique      => $self->messages->{not_unique},
			FV_num_int     => $self->messages->{need_integer},
			length_between => $self->messages->{too_long},
		},
	};
}

#-------------------------------------------------------------------------------
# can have non-unique test_names, but not with same lab_section_id:
=begin ? not in use
sub check_lab_test_is_valid {
	my $self = shift;
	
	return sub {
		my $dfv = shift;		
		$dfv->name_this('is_unique');

		my $data = $dfv->get_filtered_data; # warn Dumper $data;

		my $validation_model = $self->models->{validate_lab_test};
		
		my $is_valid = $validation_model->($data);
		return $is_valid;
	}
}
=cut

#-------------------------------------------------------------------------------
# used by new_request() & Ajax::_validate_params()
sub get_specimen_constraints {
	my $self = shift; 

	return sub {
		my $dfv = shift; # warn 'here';		
		$dfv->name_this('check_specimen');
		
		my $val = $dfv->get_current_constraint_value(); # warn $val;
		
		my $is_valid = $self->check_specimen($val); # warn $is_valid;

		return $is_valid;
	}
}

#-------------------------------------------------------------------------------
# checks entry(s) in specimen field exists in specimens table:
# (not a DFV method so doesn't receive dfv object)
sub check_specimen { # warn 'HERE'; warn Dumper @_; warn 'HERE';
	my $self = shift;

	my $specimens = shift || return 0; # warn 'specimens:'.$specimens;

    # split input on comma and/or space(s):
    my @specimens = split /\,\s?|\s+/, $specimens; # $self->debug(\@specimens);

	my $validation_model = $self->models->{validate_specimen};

    foreach my $specimen (@specimens) {
        my $valid = $validation_model->($specimen);	# warn "$specimen:$valid";
        return 0 if ! $valid;
    }
	# OK, specimen(s) valid:
	return 1;
}

#-------------------------------------------------------------------------------
sub check_referrer_code {
	my $self = shift;

	return sub {
		my $dfv = shift; #  warn Dumper $dfv;		
		$dfv->name_this('referrer_code');
		
		my $val = $dfv->get_current_constraint_value(); # warn $val;

		# C, D, E or CS followed by 5-7 numbers:
		return ($val =~ /\A([CDE]|CS)\d{5,7}\Z/) ? 1 : 0;
	}
}

#-------------------------------------------------------------------------------
sub check_request_number {
	my $self = shift;

	my $request_number = shift || return 0; # warn 'request_number:'.$request_number;

	my $validation_model = $self->models->{validate_request_number};

	my $not_unique = $validation_model->($request_number);

    return $not_unique ? 0 : 1;
}

#-------------------------------------------------------------------------------
sub get_date_constraints {
	my $self   = shift;
    my $prefix = shift; # optional - to support forms with multiple dates eg dob, request date, etc
	
	my $constraint = FV_and(
		$self->check_four_digit_year($prefix),
		$self->check_date_is_valid($prefix),
		$self->check_date_not_future($prefix),
	);
	
	return $constraint;
}

#-------------------------------------------------------------------------------
sub get_change_password_profile {
	my $self = shift;
	    
	return [ # FormValidator::Simple method
        new_password         => [ 'NOT_BLANK', ['LENGTH', 5, 255 ] ],
        old_password         => [ 'NOT_BLANK', ['LENGTH', 4, 255 ] ], # HILIS3 min.
        new_password_confirm => [ 'NOT_BLANK', ['LENGTH', 5, 255 ] ],
        { pwds => ['new_password', 'new_password_confirm'] } => [ 'DUPLICATION' ],
    ];
}

#-------------------------------------------------------------------------------
# uses FV_and() to return constraint_method, which executes list in order &
# exits on 1st failure, instead of executing all and potentially generating errs
sub join_these {
	my $self = shift;

	return FV_and(@_);
}

#-------------------------------------------------------------------------------
sub check_four_digit_year {
	my $self   = shift;
	my $prefix = shift; # optional, used if form has >1 date type (eg request date, dob)
    
    my $year_field_name = $prefix
        ? $prefix.'_year' # eg request_year, dob_year
        : 'year';
        
	return sub {
		my $dfv = shift; # warn Dumper $dfv;		
		$dfv->name_this('yyyy_format');
		
		my $data = $dfv->get_filtered_data; # warn Dumper $data;		
		return ( length $data->{$year_field_name} == 4 );
	}
}

#-------------------------------------------------------------------------------
sub check_numeric {
	my $self = shift;
	
	return sub {
		my $dfv = shift; #  warn Dumper $dfv;		
		$dfv->name_this('numeric_format');
		
		my $val = $dfv->get_current_constraint_value(); # warn $val;
		
		# digits only:
		my ($is_valid) = $val =~ /^[0-9]+$/; # warn $is_valid;
		
		return $is_valid; 
	}
}

#-------------------------------------------------------------------------------
# override MethodsFactory method until can find out how to target msgs at it
sub _FV_clamp {
	my $self = shift;
    my ($result, $low, $high) = @_;
    return sub {
        my $dfv = shift;
		$dfv->name_this('FV_clamp');
        my $val = $dfv->get_current_constraint_value();
        return (($val < $low) or ($val > $high)) ? !$result : $result;
    }
}

#-------------------------------------------------------------------------------
# or could use 'day => ymd_before_today( qw/year month day/ )'
sub check_date_not_future {
	my $self   = shift;
	my $prefix = shift; # optional, used if form has >1 date type (eg request date, dob)
    
    my $param_names = $self->_get_date_param_names($prefix); #arrayref
    
	return sub {
		my $dfv = shift; #  warn Dumper $dfv;
		$dfv->name_this('future_date'); 

		my $data = $dfv->get_filtered_data; # warn Dumper $data;
		
		# returns error if date not less than DateTime->now:
		my @cmp = (	'DATE_LESS_THAN', DateTime->now );
		
		my $result = FormValidator::Simple->check(
            $data => [
                { grouped => $param_names } => [ \@cmp ],
            ]
        ); # warn Dumper $result->has_error;
		
		return $result->has_error ? 0 : 1;
	}
}
	
#-------------------------------------------------------------------------------
# if hidden flag '_diagnosis_id' passed, also need either 'revision' or
# 'final_diagnosis' param:
sub check_report_params { 
	my $self = shift;
	
	return sub {
		my $dfv = shift; # warn Dumper $dfv;
	
		$dfv->name_this('diagnosis_resubmission');
		my $data = $dfv->get_filtered_data; # warn Dumper $data;
		
		my $original_diagnosis_id = $dfv->get_current_constraint_value();
		# warn 'HERE'; warn $original_diagnosis_id;
		
		# eg authorisation, without change of diagnosis_id:
		return 1 if $original_diagnosis_id == $data->{diagnosis_id};
		
		# require either 'final_diagnosis' or 'revision' params:
		return grep $data->{$_}, qw(final_diagnosis revision);
	}
}

#-------------------------------------------------------------------------------
# # check end_date NOT before start_date - returns true (1) UNLESS $second_date
# BEFORE $first_date:
sub check_date_order {
	my $self = shift; 

	return sub {
		my $dfv = shift; # warn Dumper $dfv;
		$dfv->name_this('date_order'); 

		my $data = $dfv->get_filtered_data; # warn Dumper $data;
	
		# LIMS::Local::Utils::check_chronological_order() requires DateTime objects:
		my $start_date
			= LIMS::Local::Utils::to_datetime_using_datecalc($data->{start_date});
		my $end_date
			= LIMS::Local::Utils::to_datetime_using_datecalc($data->{end_date});
		
		my $expr # returns '-1' if dates in chronological order (0 if equal, otherwise 1):
			= LIMS::Local::Utils::check_chronological_order($end_date, $start_date);
			# warn Dumper $expr;
		return $expr == -1 ? 0 : 1; # return false if $expr eq -1 ie in date order
	}
}

#-------------------------------------------------------------------------------
sub check_date_is_valid {
	my $self   = shift; 
	my $prefix = shift; # optional, used if form has >1 date type (eg request date, dob)

    my $param_names = $self->_get_date_param_names($prefix); #arrayref

	return sub {
		my $dfv = shift; #  warn Dumper $dfv;
		$dfv->name_this('valid_date'); 

		my $data = $dfv->get_filtered_data; # warn Dumper $data;
		
        my $result = FormValidator::Simple->check(
            $data => [
                { date => $param_names } => [ 'DATE' ]
            ]
        ); # warn Dumper $result->has_error;
		
		return $result->has_error ? 0 : 1;
	};
}

#-------------------------------------------------------------------------------
sub check_EU_date_is_valid {
	my $self = shift; 

	return sub {
		my $dfv = shift; # warn Dumper $dfv;
		$dfv->name_this('valid_date'); 

		my $val = $dfv->get_current_constraint_value(); # warn $val;

        my $result = LIMS::Local::Utils::check_date($val); 
		return $result;
	};
}

#-------------------------------------------------------------------------------
sub check_param_length {
	my $self = shift;
	my $arg  = shift; # warn Dumper $arg;
	
	# if $arg is arrayref, assume length_between, otherwise max_length:
	return
		ref $arg eq 'ARRAY' ?
			FV_length_between(@$arg) :
				FV_max_length($arg);
}

#-------------------------------------------------------------------------------
# checks param is either unique, or belongs to submitted record id:
sub check_param_ownership {
	my $self = shift;
	my $tbl_info = shift; # arryref of 'col_name' & 'class'

	return sub {
		my $dfv = shift; # warn Dumper $dfv;
		my $data = $dfv->get_filtered_data; # warn Dumper $data;

		$dfv->name_this('ownership');

		my %args = (
			col   => $tbl_info->[0], # can be arrayref of col_names
			class => $tbl_info->[1],
			data  => $data,
		); # warn Dumper \%args;

		# returns 'true' if param unique, or already belongs to record id:
		my $unique_or_belongs_to_record
			= $self->models->{validate_param_ownership}->(\%args);

		# so just return value of expression:
		return $unique_or_belongs_to_record;	
	};		
}

#-------------------------------------------------------------------------------
# allows for form to submit several date params, eg request_year, dob_year, etc
sub _get_date_param_names {
    my $self   = shift;
    my $prefix = shift; # optional, used if form has >1 date type (eg request date, dob)
    
    my @param_names = qw(year month day);
    
    if ($prefix) { # eg validating request_year, request_day, etc
        map { $_ = $prefix . '_' . $_ } @param_names; # eg year => dob_year
    } # warn Dumper \@param_names;
    
    return \@param_names;
}

1;