package LIMS::Base;
use parent 'LIMS';
use strict;
use YAML::Tiny;
use Data::Dumper;
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_cfg => $self->config('settings'), # required by LIMS::Model::Base
_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):
$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; # DEBUG $profile;
my $profile = $self->_get_validation_profile($profile_name);
# return all keys except 'ajax_methods':
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
# 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:
sub js_validation_profile {
my $self = shift;
my $profile = shift; # name of DFV profile to retrieve from $self->validate
# get dfv validation profile from validate():
my $dfv_profile = $self->validate($profile)
or die "cannot find validation profile for '$profile'";
# 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:
my %js_validation_profile = (
# Javascript snippet for <form> tag to call check_and_report()
# JavaScript validation function:
$profile . '_onsubmit' => js_dfv_onsubmit($profile),
# return js representation of Perl DFV validation profile :
$profile . '_dfv_js' => js_dfv_profile($profile => \%js_compatible_profile),
);
map $self->tt_params($_ => $js_validation_profile{$_}), keys %js_validation_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 );
}
#-------------------------------------------------------------------------------
# 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
# 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';
};
# NB: these accessors MUST NOT clash with existing ones:
$self->tt_params(
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,
);
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 || ''; # 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}
);
# level: 0 1 2 3 4 5 6 7
my @named_level = qw(debug info notice warning error critical alert emergency);
my $log_level = $named_level[$level] || 'debug';
# $log_level ||= 'debug'; log() doesn't accept numbers !!
my $message =
ref $params ?
Dumper( $params ) :
$params . "\n" ; # Log::Dispatch doesn't observe append_new_line switch
# if using CAP::LogDispatch:
$self->log->$log_level($message);
# if using LIMS::Local::LogDispatch:
# my $dispatcher = $self->log_dispatch; # LIMS::Local::LogDispatch
# $dispatcher->log(level => $log_level, message => $message);
# warn Dumper($log_level,$message);
}
#-------------------------------------------------------------------------------
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
