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:: ':app/:rm' => { }, # LIMS::Controller::Foo:: ':app/:rm/:id' => { }, # LIMS::Controller::Foo::; 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 $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; my $vnumber = 999 + `git rev-list HEAD --count`; # as 1st in git repo = svn #1000 $VERSION_INFO->{date} = DateTime->from_epoch(epoch => $epoch)->strftime('%d/%m/%Y %T'); $VERSION_INFO->{number} = $vnumber; say 'starting HILIS 4.' . $vnumber unless $ENV{HARNESS_ACTIVE}; } # warn $VERSION_INFO; return $VERSION_INFO; } 1;