package LIMS::Dispatch;
use base 'CGI::Application::Dispatch';
use IO::Dir;
use DateTime;
use Modern::Perl;
use Data::Printer;
use Time::HiRes qw(gettimeofday tv_interval);
use vars qw($VERSION_INFO); # hashref of date and number
BEGIN {
use LIMS::Local::ErrorHandler; # can't be used with CAP::Redirect or get
use FindBin qw($Bin);
# use CGI::Carp qw(fatalsToBrowser);
# "prerun_mode() can only be called within cgiapp_prerun()! Error at
# CAP::Redirect.pm line 24" - ($SIG{__DIE__} issue - see README)
}
# map for translate_module_name():
my %map = (
worklist => 'WorkList', # action_links in header.tt
printrun => 'PrintRun',
);
# CAPITALISE these (also for translate_module_name):
my @capitalised = qw(pas hmrn);
my $debug = ! grep $ENV{$_}, qw(HARNESS_ACTIVE FAST_CGI MOD_PERL); # saves *.t dumping data to console
=begin # not passing config files to LIMS constructor now - using LIMS::Local::Config->instance
use LIMS::Local::Utils;
my $path_to_app_root = LIMS::Local::Utils::find_home(); # warn 'path_to_app_root:'.$path_to_app_root;
my $d = IO::Dir->new($path_to_app_root . '/config')
|| die "undefined \$d in $0", $@;
my @config_files =
map { $path_to_app_root . '/config/' . $_ }
grep { $_ =~ /lims_(.*)\.pl$/ } # lims_*.pl
$d->read; # warn Dumper \@config_files;
=cut
my @dispatch_table = (
# if no path_info supplied:
'/' => { app => 'Search', rm => 'default' }, # should be handled by default arg ?
# specific rm's that don't match :app/:rm
logout => { app => 'Login', rm => 'logout' },
messages => { app => 'Resources', rm => 'user_messages' }, # from nav bar in header.tt
dashboard => { app => 'Resources', rm => 'dashboard' }, # from nav bar in header.tt
'admin/:app' => { prefix => 'LIMS::Controller::Admin' },
'admin/:app/:rm' => { prefix => 'LIMS::Controller::Admin' },
'admin/:app/:rm/:id'=> { prefix => 'LIMS::Controller::Admin' },
'config/:app' => { prefix => 'LIMS::Controller::Admin::Config' },
'config/:app/:rm' => { prefix => 'LIMS::Controller::Admin::Config' },
'config/:app/:rm/:id'=> { prefix => 'LIMS::Controller::Admin::Config' },
':app/=/' => { }, # broken url ??
':app/=/:id' => { rm => 'load' }, # make '=' alias for 'load'
# generic matches:
':app' => { }, # LIMS::Controller::Foo::<StartRunmode>
':app/:rm' => { }, # LIMS::Controller::Foo::<specified runmode>
':app/:rm/:id' => { }, # LIMS::Controller::Foo::<specified runmode>; token = param('id')
':app/:rm/:id/:Id' => { }, # as above; token = param('id') & param('Id')
);
my %local_args = (
# default => 'search', # fastcgi doesn't work unless '/' set in dispatch table
prefix => 'LIMS::Controller',
table => \@dispatch_table,
debug => $debug,
args_to_new => {
PARAMS => {
Class => undef, # class name - defined in dispatch_args()
app_version => _app_version(),
# config_files => \@config_files, # using LIMS::Local::Config->instance() now
# t0 => [gettimeofday], # moved to LIMS cgiapp_init()
},
},
error_document => "<$Bin/../static/%s.html",
);
sub dispatch_args {
my $self = shift;
my $dispatch_args = $self->SUPER::dispatch_args;
# override default dispatch_args with %local_args:
$dispatch_args->{$_} = $local_args{$_} for keys %local_args;
# warn Dumper $dispatch_args;
# add class_name var:
$dispatch_args->{args_to_new}->{PARAMS}->{Class} = $self->get_class_name;
return $dispatch_args;
}
sub modify_config { # used by .t to modify settings
my ($self, $ref) = @_; # p $ref; # aref
my $cfg = LIMS::Local::Config->instance; # p $cfg;
my ($key, $value) = @$ref;
$cfg->{settings}->{$key} = $value;
}
# override default method - can return module_name in different format to default:
sub translate_module_name {
my ($self, $input) = @_; # warn $input;
# return value from %map if defined:
return $map{$input} if defined $map{$input};
# force capitalisation if required:
$input =~ s/$_/uc($_)/e for @capitalised;
$input = join '::', map { ucfirst $_ } ( split '_', $input ); # foo_bar -> Foo::Bar
$input = join '', map { ucfirst $_ } ( split '-', $input ); # foo-bar -> FooBar
# warn $input;
return $input;
}
sub get_class_name {
my $self = shift; # warn Dumper $self->dispatch_path;
my $dispatch_path = $self->dispatch_path || return; # return nothing is OK
my $class_name = ( split '/', $dispatch_path )[1]; # warn $class_name;
return $class_name;
}
sub throw_bad_request { 1 } # just returns '1'
#-------------------------------------------------------------------------------
sub _app_version { # returns svn + git commit counts
=begin
Revision 1 Added Mon Sep 15 2008 15:04:33
initial git-svn commit on Tue, 10 Aug 2010 08:29:38 at svn version 1000:
git-svn-id: https://jti.org.uk/svn/hmds_lims/trunk@1000
HILIS4 commenced in production on Sun 09/10/2011 at svn version 1344:
git-svn-id: https://jti.org.uk/svn/hmds_lims/trunk@1344 [Sun, 9 Oct 2011 18:42:10 +0000]
penultimate commit to svn on Fri 25/04/2014 before moving to git on Mon 28/04/2014:
git-svn-id: https://jti.org.uk/svn/hmds_lims/trunk@1938 [Fri, 25 Apr 2014 12:53:48 +0000]
current version = 1000 + 'git rev-list HEAD --count'
or 1938 + commits after 25/4/2014, or 1344 + commits after 9/10/2011
# my $commitsSinceLastSVN = `git rev-list --after=2014-04-25 HEAD --count`;
# $VERSION = 1938 + $commitsSinceLastSVN;
=cut
if (! $VERSION_INFO) { # should only run system call once on start-up:
chomp( my $commit_hash = `git log -1 --no-merges --pretty=format:'%h'`); # warn $commit_hash;
$VERSION_INFO->{commit_hash} = $commit_hash;
# chomp( my $date = `git log -1 --format=%cd --date=relative` ); # eg 6hrs ago - persists until restart
chomp( my $raw_time = `git log -1 --format=%cd --date=raw` ); # warn $raw_time; # cmd appends new-line
# extract epoch seconds eg 1455628027 +0000 [GMT], 1460022637 +0100 [BST], etc:
my ($epoch) = $raw_time =~ /^(\d+)\s\+0[01]00/ or # don't use '||' here - gets truth
die "could'nt extract epoch time from `git log` output"; # warn $epoch;
$VERSION_INFO->{date}
= DateTime->from_epoch(epoch => $epoch)->strftime('%d/%m/%Y %T');
my $vnumber = 999 + `git rev-list HEAD --no-merges --count`; # as 1st in git repo = svn #1000
$VERSION_INFO->{number} = $vnumber;
say sprintf "starting HILIS 4.${vnumber} ($commit_hash)"
unless $ENV{HARNESS_ACTIVE};
} # warn $VERSION_INFO;
return $VERSION_INFO;
}
1;
