package LIMS::Base;

use parent 'LIMS';

use strict;

use YAML::Tiny;
use Data::Dumper;
use Regexp::Common;
use Sort::Naturally;
use JavaScript::DataFormValidator;

#-------------------------------------------------------------------------------
# GLOBAL METHODS
#-------------------------------------------------------------------------------
sub model {
    my $self = shift;
    my $classname = shift
		|| $self->error( 'Required classname attribute missing' );
    # warn 'classname:'. $classname;

    # return stashed package object if it exists:
    if ( my $stashed = $self->stash->{"model::$classname"} ) {
           # $self->debug("model::$classname IS in stash");
        return $stashed;
    }

    my $package = "LIMS::Model::$classname";
    # $self->debug("model::$classname NOT in stash");

	# load package via require:
    unless (eval "require $package") {
        $self->error("Unable to load module [$package].");
    }

	my %args = (
		_lims_db  => $self->lims_db, # required by LIMS::Model::Base
		_session  => $self->session, # required by LIMS::Model::Roles::SessionData
	);
	
    # instantiate object
    my $model = $package->new(%args)
	|| $self->error("unable to instatiate [$package]."); # $self->debug("instatiated $package.");

    $self->stash->{"model::$classname"} = $model;

    return $model;
}

#-------------------------------------------------------------------------------
sub error { 
    my ($self, $msg) = @_;

    # map { $self->debug("CALLER: $_") } ($package, $filename, $line);
    my ($package, $filename, $line) = caller;

    $self->tt_params(
        package => $package,
        line    => $line,
        msg     => $msg,
        title   => 'Error',
    );

    return $self->tt_process('site/error.tt');
}

#-------------------------------------------------------------------------------
# alternative to CAP::Flash - accepts args in same format as CAP::Flash, but
# uses CAP::MessageStack instead:
sub flash { # warn 'here'; warn Dumper caller();
    my $self = shift;
    my ($type, $msg, $scope) = @_; # array of ( type => message )
        # warn Dumper [ $type, $msg, $scope ];
    $self->push_message(
        -message => $msg,
        -classification => $type,
        -scope => $scope,
    );
}

#-------------------------------------------------------------------------------
sub get_meta_data {
	my $self  = shift;
	my $class = shift;

	unless ( $self->stash->{meta_data}->{$class} ) {	
		my $meta_data = $self->model('Base')->get_meta($class);
		$self->stash->{meta_data}->{$class} = $meta_data;
	}
	return $self->stash->{meta_data}->{$class};
}

#-------------------------------------------------------------------------------
sub get_yaml_file {
	my ($self, $filename) = @_; # warn $filename;

	return $self->stash->{__yaml_file}->{$filename}
		if $self->stash->{__yaml_file}->{$filename}; # in case called in a loop

	my $src = $self->cfg('path_to_app_root') . "/config/.local/$filename.yml";
	return 0 unless (-e $src);  # eg function not configured
	
=begin # could use 'eval', but probably want to preserve & output any error:
	my $yaml;
	eval {
		$yaml = YAML::Tiny->read($src);
	}; die @$ if @$;
	
	return $yaml->[0];
=cut
	my $yaml = YAML::Tiny->read($src)->[0]; # $self->debug($yaml);
	
	# stash in case we're called in loop (eg print_run, get_blood_tube_type):
	$self->stash->{__yaml_file}->{$filename} = $yaml;
	return $yaml;
}

#-------------------------------------------------------------------------------
# uses CGI::Pager; accepts $args hashref (query_args and total_count);
# makes cgi_pager object available to template and adds limit & offset params
# to query_args; returns nothing
sub pager {
    my $self = shift;
    my $args = shift; # hashref of query_args and total count

    my $args_for_query = $args->{query};
    my $total_count    = $args->{total};

	my $entries_per_page = # config settings; can be overriden from form:
        $self->query->param('entries_per_page') ||
            $self->cfg('settings')->{entries_per_page} || 10;

    my $pager = CGI::Pager->new(
        page_len    => $entries_per_page, # default = 20
        total_count => $total_count,
    );

    $self->tt_params( cgi_pager => $pager ); # $self->debug($pager);

    # add limit & offset params to args_for_query hashref:
    $args_for_query->{limit}  = $entries_per_page;
    $args_for_query->{offset} = $self->query->param('offset') || 0;
}

#-------------------------------------------------------------------------------
# returns requested Data::FormValidator profile from LIMS::Validate
sub validate {
    my $self = shift;
    my $profile_name = shift || return; # warn $profile_name;

	my $profile = $self->_get_validation_profile($profile_name);
	
    # return $profile if not a hashref (eg arrayref for FV::Simple or coderef):
    return $profile unless ref $profile eq 'HASH';
    
	# remove 'ajax_methods' keys from hashref:
	my @keys = grep $_ ne 'ajax_methods', keys %$profile; # warn Dumper \@keys;
	my %dfv_profile = map {	$_ => $profile->{$_} } @keys; # warn Dumper \%dfv_profile;
    return \%dfv_profile;
}

#-------------------------------------------------------------------------------
# called from template with profile name to generate rules for jquery validation:
# if used, need to load jquery.validate.js and
# $(document).ready(function() { $("#id").validate({ rules: { } })
sub jquery_validation_profile {
    my $self    = shift;
    my $profile_name = shift || return; # name of DFV profile to retrieve from $self->validate

	my $profile = $self->_get_validation_profile($profile_name);
	
	my $ajax_methods = $profile->{ajax_methods};
	my $required = $profile->{required};
	
	my $app_url = $self->query->url;
	my @rules;
	
	push @rules, ( qq!$_: "required"! ) for @$required;
	push @rules, ( qq!$_: { remote: "$app_url/ajax/$ajax_methods->{$_}" }! )
		for keys %$ajax_methods; # warn Dumper \@rules;
    return \@rules;
}

#-------------------------------------------------------------------------------
sub validation_models {
	my $self = shift; # warn 'creating validation_models'; # should only be called once

    my $_self = $self; weaken $_self; # or get circular refs inside the callbacks
    
    # validation models all return 1 if param being validated should 'pass':
	my %validation_models = (
		validate_request_number => sub {
			my $request_number = shift;
			return $_self->model('Request')->get_requests_count($request_number);
		},
		validate_specimen => sub {
			my $specimen = shift;
			return $_self->model('Specimen')->validate_specimen($specimen);
		},
        # can have non-unique test_names, but not with same lab_section_id:
#        validate_lab_test => sub {
#            my $data = shift;
#            return $_self->model('LabTest')->check_lab_test_unique($data);
#        },
        # check form field param is unique, or belongs to current record under edit:
        validate_param_ownership => sub {
            my $args = shift; # warn Dumper $args;
            return $_self->model('Validation')->validate_param_ownership($args);
        },
        # just need to check nhs_number not already in use:
        validate_nhs_number_unique => sub {
            my $nhs_no = shift;
            return $_self->model('Patient')->check_patient_nhs_number_count($nhs_no);
        },
		# how many lab_tests:
		get_lab_tests_count => sub {
            return $_self->model('Base')->get_objects_count('LabTest');
        },
		# hmrn_treatment_types:
		hmrn_treatment_types => sub {
            return $_self->model('HMRN')->get_tx_type_map;
        },
	);

	return \%validation_models;
}

#-------------------------------------------------------------------------------
# sets tmpl vars & returns FormValidator::Simple::check result against supplied profile:
sub form_validator {
    my $self    = shift;
    my $profile = shift; # arrayref

    my $result = FormValidator::Simple->check( $self->query => $profile );

    $self->tt_params( form_validator => $result );

    return $result;
}

#-------------------------------------------------------------------------------
# put requested JavaScript::DataFormValidator profile into tt_params
# profile_name required - provides name for tmpl accessor and name of validation
# profile to load (if not supplied direct)
sub js_validation_profile {
    my $self = shift;
    my $profile_name = shift; # name of DFV profile to retrieve from $self->validate    
    my $dfv_profile  = shift; # optional; only C::Report::outreach() supplies it direct
    
    # get dfv validation profile from validate() if not supplied:
    if (! $dfv_profile) {
        $dfv_profile = $self->validate($profile_name)
            or die "cannot find validation profile for '$profile_name'";
    }

    # grep methods compatible with JS::DFV:
    my %js_compatible_profile = map {
        $_ => $dfv_profile->{$_},
    } grep $dfv_profile->{$_}, (
        # only include methods supported in FormValidator.js v0.06 (not contraint_methods,
        # or contrainsts: named closures, sub-routine references or compiled regex):
        'required',
        'optional',
        'dependencies',
        'dependency_groups',
        'constraints', 
        'msgs',
    );

    # create js_validation_profile for template:
     $self->tt_params(
        # Javascript snippet for <form> tag to call check_and_report()
        $profile_name . '_onsubmit' => js_dfv_onsubmit($profile_name),
        # js representation of Perl DFV validation profile:
        $profile_name . '_dfv_js' => js_dfv_profile($profile_name => \%js_compatible_profile),
    );
}

#-------------------------------------------------------------------------------
# returns the requested lims_messages.pl profile
sub messages {
    my $self  = shift;
    my $msg = shift || return;

    return $self->cfg('msg')->{$msg};
}

#-------------------------------------------------------------------------------
# authorisation method for runmodes; also used by CAP::Authorization for
# handling package-wide authorisation ie __PACKAGE__->authz->authz_runmodes()
sub user_can {
    my ($self, $action) = @_; 

    my $allowed_functions # retrieve from stash, or from session then stash it:
        = $self->stash->{allowed_functions} || $self->_get_allowed_functions();
    
    # returns true if $action exists in users 'functions' profile:
    return ( grep $action eq $_, @$allowed_functions );
}

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

    my $profile = $self->authen->store->fetch('yooza_profile'); # $self->debug($profile);
    my $user_location = $profile->{user_location}->{location_name};
    my $lab_name = $self->cfg('settings')->{lab_name_abbreviation};

    return ( $user_location eq $lab_name ); # returns truth
}

#-------------------------------------------------------------------------------
# returns 'forbidden action' page:
sub forbidden {
    my $self = shift;
    return $self->tt_process('site/forbidden_action.tt');
}

#-------------------------------------------------------------------------------
# CAP::Redirect functionality, without eval block which doesn't play nice with
# $SIG{__DIE__} handler in LIMS::Local::ErrorHandler (see README)
sub redirect {
    my $self     = shift;
    my $location = shift;
    my $status   = shift;

    if ($status) {
        $self->header_add( -location => $location, -status => $status );
    }
	else {
        $self->header_add( -location => $location );
    }
    $self->header_type('redirect');
}

#-------------------------------------------------------------------------------
# supplies some callback methods (eg join_hash_values, symbolise) to templates
# called as: $self->render_view('some/template.tt', { foo => $foo, etc });
sub render_view {
	my $self = shift;
	my $tmpl = shift
		|| return $self->error('no template name passed to render_view()');
	my $args = shift || {}; # optional args for template

    my $_self = $self; weaken $_self; # or get circular refs inside the callbacks
    
	# so tmpl can supply a hash + keys to join
	my $join_hash_values = sub {
		my ($separator, $hash) = @_;
		return join $separator, grep defined, @{ $hash }{ @_ };
	};

    # eg 10/9/L -> <sup>9</sup>, ul -> &micro;
    my $symbolised = sub {
        my $str = shift;
        return LIMS::Local::Utils::symbolise($str);
    };
    
	my $line_break = sub {
		my $str = shift;
		$str =~ s/(\r\n)+/\n\n/g; # insert 2 line-breaks for FILTER html_line_break
		return $str;
	};
	
	my $get_trial_number = sub {
		# my ($patient_id, trial_id) = @_; just hand @_ direct:		
		my $trial_no
			= $_self->model('ClinicalTrial')->get_trial_number(@_);
		return $trial_no;
	};
	
	my $start_date = sub {
		return $_self->model('Request')->get_first_request_date;
	};
    
	my $nsort = sub {
		my $list = shift; # warn Dumper $list;
		return Sort::Naturally::nsort(@$list);
	};
	
	my $has_mdt_contact = sub {
		my $id = shift; # parent_organisation_id
		return $_self->model('ReferralSource')->has_mdt_contact($id);
	};
	
	my $make_chart = sub {
		my ($chart_type, $request_id) = @_; # warn $chart_type; warn $request_id;
		
		my $chart = LIMS::Local::Chart->new(
			request_id => $request_id,
			model      => $_self->model,
		);
		do { $chart->$chart_type() }; 
		
		return 'bar';
	};
	
    my $is_numerical = sub {
        my $str = shift;
        return $str =~ /\A$RE{num}{real}\Z/; # only matches int & decimal numbers
    };

    my $sig_figs = sub {
        my $param = shift;
        return LIMS::Local::Utils::sig_figs($param);
    };
    
    my $format_first_name = sub {
        my $patient = shift;
        return $_self->_format_first_name($patient); # returns empty if no rule
    };
    
    # NB: these accessors MUST NOT clash with existing ones:
	$self->tt_params(
        format_firstname => $format_first_name,
        join_hash_values => $join_hash_values,
		get_trial_number => $get_trial_number,
		has_mdt_contact  => $has_mdt_contact,
		natural_sort	 => $nsort,
		start_date       => $start_date,
		line_break		 => $line_break,
        symbolise        => $symbolised,
		create_chart	 => $make_chart,
        is_numerical     => $is_numerical,
        sig_figs         => $sig_figs,
    );

	return $self->tt_process($tmpl, $args);
}

#-------------------------------------------------------------------------------
# accepts debug 'params' as 1st (scalar) arg, then optional log level
# (defaults to 0 - debug)
sub debug {
    my $self   = shift;
    my $params = shift; #  warn 'params:'. Dumper $params;
    my $level  = shift || 0; #  warn 'level:'. Dumper $level; # optional arg

    # don't want mod_perl, fast_cgi or t/*.t output unless specifically requested:
    return 0 if (
		( grep $ENV{$_}, qw/MOD_PERL FAST_CGI HARNESS_ACTIVE/ )
		&& ! $ENV{DEBUG_ON}
	);

    my $level_name # 0     1     2      3      4       5      6       7
            = [ qw(debug info notice warning error critical alert emergency) ];
    my $log_level = $level_name->[$level] || 'debug';

    my $message =
		ref $params           ?
            Dumper( $params ) :
            $params . "\n"    ; # Log::Dispatch doesn't observe append_new_line switch
            # warn Dumper [$log_level,$message];
    
    # $self->log->$log_level($message); # CAP::LogDispatch method
    $self->log_dispatch->$log_level($message); # LIMS::Local::LogDispatch method
}

#-------------------------------------------------------------------------------
# uses firstname_format.yml to apply special formatting to first_name:
sub _format_first_name {
    my ($self, $patient) = @_;
    
    my $rules = $self->get_yaml_file('firstname_format') || return 0;

    my $first_name = $patient->first_name; # warn $first_name;
    my $last_name  = $patient->last_name;  # warn $last_name;

    for (@$rules) {
        # regex, which attr (lname or fname) to apply regex to, format to apply:
        my ($regex, $apply_to, $format) = @$_;
            # warn Dumper [$regex, $apply_to, $format];
        if (
            ( $apply_to eq 'first_name' && $first_name =~ qr/\A($regex)\Z/ ) ||
            ( $apply_to eq 'last_name'  && $last_name  =~ qr/\A($regex)\Z/ )
        ) { # warn 'here';
            if ($format eq 'upper') { # warn 'here';
                return uc $first_name; # can't do: $format($first_name) - error
            }
        }
    }
    # no rule so return empty: 
    return 0;
}

#-------------------------------------------------------------------------------
sub _get_validation_profile {
	my $self = shift;
    my $profile_name = shift || return; # DEBUG $profile;

	unless ($self->stash->{validator}) {
		my $validator = LIMS::Validate->new(
			models   => $self->validation_models,
			messages => $self->cfg('msg')->{dfv_msgs},
			settings => $self->cfg('settings'),
		);
		$self->stash(validator => $validator);
	}
	
	return $self->stash->{validator}->$profile_name;
}

#-------------------------------------------------------------------------------
# if 1st call to user_can():
sub _get_allowed_functions { # warn 'here'; # should ony happen once per request
    my $self = shift;
    
	# $user_profile will be empty if method called after logout (so return):
	my $user_profile = $self->session->param('UserProfile') || return;
	
    $self->stash( allowed_functions => $user_profile->{functions} );
    
    return $user_profile->{functions};
}

1;

__END__

#-------------------------------------------------------------------------------
# UNUSED GLOBAL METHODS
#-------------------------------------------------------------------------------

=begin
# alternative to CAP::Flash
sub _flash {
    my $self   = shift; # $self->debug(@_);
    my $method = shift || 'set'; # warn 'METHOD:'.$method;

    # can only return stashed object for setting: no - see below:
    unless ($method eq 'get') {
        return $self->stash->{flash} if $self->stash->{flash}; # prevents message removal from session
    }

    # can't stash object or get "DESTROY created new reference to dead object 'CGI::Session::Flash'
    # during global destruction."
    my $flash = # $self->stash->{flash} =
        CGI::Session::Flash->new($self->session);

    return $flash;
}

# uses Data::Page:
sub _pager {
    my $self  = shift;
    my $total = shift; # total count

	my $entries_per_page = $self->cfg('settings')->{entries_per_page} || 10;
	my $current_page     = $self->query->param('page') || 1;

    my $page = Data::Page->new(); # constructor takes no args

    $page->entries_per_page( $entries_per_page );
    $page->current_page( $current_page );
    $page->total_entries( $total );

    return $page;
}

# uses LIMS::Local::LogDispatch
sub _dispatcher {
    my $self = shift; # return;
    my %args = @_; # warn Dumper \%args;

    my $dispatcher = $self->log_dispatch; # LIMS::Local::LogDispatch

    $dispatcher->log(%args);
}
=cut