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 -> µ
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
