package LIMS::Base;
use parent 'LIMS';
use strict;
use Data::Dumper;
use LIMS::Local::Utils;
use JavaScript::DataFormValidator;
#-------------------------------------------------------------------------------
# GLOBAL METHODS
#-------------------------------------------------------------------------------
# render_view(), get_yaml_file() & model() moved to LIMS::Role::Base
#-------------------------------------------------------------------------------
sub error {
my ($self, $msg) = @_;
# map { $self->debug("CALLER: $_") } ($package, $filename, $line);
my ($package, $filename, $line) = caller;
my $str = length $msg > 125 # width, array(ref) of args to wrap:
? LIMS::Local::Utils::text_wrap(120, [ "\n\t", "\t", $msg ])
: $msg;
my $time = LIMS::Local::Utils::time_now();
$self->tt_params(
package => $package,
time => $time,
line => $line,
msg => $str,
);
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; # warn $class;
unless ( $self->stash->{meta_data}->{$class} ) { # warn 'here'; # should only be once per class
my $meta_data = $self->model('Base')->get_meta_data($class);
$self->stash->{meta_data}->{$class} = $meta_data;
}
return $self->stash->{meta_data}->{$class};
}
#-------------------------------------------------------------------------------
# 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; # warn $specimen;
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;
},
# hmrn_param_constraints:
hmrn_param_constraints => sub {
return $_self->model('HMRN')->get_parameter_constraints;
},
# get meta data:
get_meta => sub { $_self->get_meta_data(@_) }
);
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) = @_; # $action can be scalar or array(ref)
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:
if ( ref $action eq 'ARRAY' ) {
foreach my $func(@$action) { # warn $func;
return 1 if ( grep $func eq $_, @$allowed_functions );
}
return 0;
}
else {
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
}
#-------------------------------------------------------------------------------
sub html_link {
my $self = shift;
my ($href, $title, $class) = @_; # $class is optional
my $q = $self->query;
return $q->a({ href => $href, class => $class || 'normal' } , $title);
}
#-------------------------------------------------------------------------------
# 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');
}
#-------------------------------------------------------------------------------
# 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
}
#-------------------------------------------------------------------------------
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
