package LIMS::Dispatch; use base 'CGI::Application::Dispatch'; use IO::Dir; use Modern::Perl; use Data::Printer; use Time::HiRes qw(gettimeofday tv_interval); use vars qw($VERSION); 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 = ( # specific rm's that don't match :app/:rm '/' => { app => 'Search', rm => 'default' }, # if no path_info supplied - should be handled by default arg ? logout => { app => 'Login', rm => 'logout' }, '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/=/: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; } # 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' # HILIS4 commenced 10/10/2011 sub _app_version { if (! $VERSION ) { # should only run system call once on start-up: $VERSION = `git rev-list --after=2011-10-10 HEAD --count`; say printf 'starting HILIS v4.%04d', $VERSION unless $ENV{HARNESS_ACTIVE}; } return $VERSION; } 1;