package LIMS;
=begin # doesn't work under production env
use vars '$svk_revision';
BEGIN { # get svk equivalent of svnversion - hit only once during startup:
unless ($ENV{HARNESS_ACTIVE}) { # crashes it
$svk_revision = `svk info | grep 'Revision:' | awk '{print \$2}'`;
}
}
our $VERSION = $svk_revision;
=cut
use Moose;
extends 'LIMS::Titanium';
with (
# 'LIMS::Model::Roles::QueryLogger',
'LIMS::Role::Base', # render_view(), model()
'LIMS::Controller::Roles::DataMap',
'LIMS::Controller::Roles::Resource',
);
#use strict;
#use warnings;
#use base 'LIMS::Titanium'; # std CPAN Titanium with some additional modules loaded
use Data::Dumper;
use Time::HiRes qw(gettimeofday tv_interval);
use DateTime; DateTime->DefaultLocale('en_GB'); # set default locale for app
use Scalar::Util qw(weaken);
# use POSIX qw(strftime); # only required by CAP::LogDispatch callback
use LIMS::RDBO; # returns LIMS::DB->new_or_cached via init_db()
use LIMS::Validate; # returns validation profile
use LIMS::Local::Debug;
use LIMS::Local::Utils;
use LIMS::Local::Config;
use LIMS::Local::QueryLog qw( set_querylog_args );
use LIMS::Local::LogDispatch;
=begin # test don't work -
sub cgiapp_get_query {
my $self = shift;
require CGI::Simple; # note, uploads are disabled by default in CGI::Simple
return CGI::Simple->new();
}
=cut
#-------------------------------------------------------------------------------
# OVERRIDE METHODS
#-------------------------------------------------------------------------------
sub cgiapp_init {
my $self = shift; # DEBUG $self->query; # needs to be after Log::Dispatch setup
if ($self->{have_turned_dbi_trace_on}) { # eg in fcgi script - comment to enable
my $msg = sprintf 'PID: %s; TIMESTAMP: %s',
$$, DateTime->now( time_zone => 'local' )->datetime;
DBI->trace_msg($msg, 0); # warn $msg;
}
# set Time::HiRes base-line; needs to be before Log::Dispatch setup
$self->param( t0 => [gettimeofday] );
# CAP::DBI - load dbh into object - replaced with own dbh() method now
# my $dbi = $self->_dbh_config; $self->dbh_config( $dbi );
# configure plugins:
$self->_configure_plugins;
# configure CAP::Authentication protected_runmodes:
$self->_configure_protected_runmodes;
$self->debug($self->query); # needs to be done after plugin config
}
#-------------------------------------------------------------------------------
sub setup {
my $self = shift;
$self->run_modes(
login => 'login',
AUTOLOAD => \&_exception,
); # warn Dumper $self->run_modes;
}
#-------------------------------------------------------------------------------
sub cgiapp_prerun {
my $self = shift;
# load this if using non-external fastcgi (see comment in L::L::Q)
# LIMS::Local::QueryLog->ensure_warn_handler_capture;
=begin
$Data::Dumper::Deparse = 1; # warn Dumper $SIG{__WARN__};
use Sub::Identify ':all';
my $subname = sub_fullname( $SIG{__WARN__} ); warn $subname;
=cut
# check access route is permitted (ie direct or via portal):
return $self->redirect('/') unless $self->_check_portal_referral();
$self->tt_params( # KEEP THIS ABOVE BLOCK BELOW !!
app_url => $self->query->url,
url_with_path => $self->query->url(-path_info=>1), # also works in template c.query.url(path_info=1);
);
my $authen = $self->authen; # $self->_dump_authen_params;
# if new login, need to see if user profile exists (ie genuine new login), or
# re-login after idle timeout (need to check username matches session profile):
if ( $authen->is_new_login ) { # warn 'here';
# get user profile (if it exists):
my $profile = $authen->store->fetch('yooza_profile');
my $username = $authen->username;
if (! $profile) { # it's a new login
$self->_create_user_profile(); # warn 'here';
# redirect to 'hello' page:
return $self->redirect( $self->query->url . '/login/hello' );
}
# check form param username matches session profile or redirect to logout:
elsif ( $username ne $profile->{username} ) { # warn 'here';
# $self->flash(); # can't do it - lost on logout(); not needed as never get here
# warn Dumper [$self->authen->username, $profile->{username}];
$self->redirect( $self->query->url . '/logout' );
}
# check email address present (legacy conversion):
elsif (! $profile->{email} ) { # warn 'here';
$self->flash( warning => $self->messages('user')->{update_email} );
}
# check new messages:
elsif ( my $i = $self->model('User')->any_new_messages($username) ) {
# set flash msg:
my $msg = $self->tt_process('user/new_msg_alert.tt', {count => $i});
$self->flash( info => ${$msg} );
}
}
$self->_set_active_link(); # uses tt_params - won't work on redirect
# pass username to QueryLog for sql logging:
LIMS::Local::QueryLog::set_querylog_args({user => $self->authen->username});
# pass config args to errorhandler (needs admin email, smtp, etc):
LIMS::Local::ErrorHandler::set_errorhandler_args({
cfg => $self->cfg('settings'),
user => $self->authen->username,
});
# otherwise CAD-loaded classes can't find it for package-wide authorization:
$self->run_modes( authz_forbidden => 'forbidden' );
# alternative to $self->authen->protected_runmodes:
# $self->authen->username ?
# $self->authen->redirect_after_login :
# $self->authen->redirect_to_login;
}
#-------------------------------------------------------------------------------
sub cgiapp_postrun {
my ($self, $output) = @_;
my $run_time =
sprintf "%.2f sec", tv_interval $self->param('t0'), [gettimeofday];
$$output =~ s/%SCRIPTRUNTIMER%/$run_time/; # too late to use tt_params
}
#-------------------------------------------------------------------------------
sub teardown {
my $self = shift;
$self->session->flush; # recommended action
# README: need to update sessions table with userid on new login and also on
# re-authentication after a session timeout - CAP::Authen seems to delete
# session on timeout (see sql log), and a new one is created in final call
# to CGI::Session::flush (see last item in a DBI trace), which calls
# CGI::Session::Driver::mysql::store and creates a new session with same ID,
# and preserves a_session UserProfile vals (deletes all AUTH_* fields), but
# also ignores userid col. So need to update it again after flush():
if ( $self->authen->is_new_login ) { # warn 'new login/re-authentication';
my $args = {
session_id => $self->session->id,
userid => $self->authen->username,
};
$self->model('User')->update_session_userid($args); # warn Dumper $args;
}
unless ($ENV{FAST_CGI}) { # warn 'here'; # for devel/testing only:
require LIMS::Local::DevelCycle; # warn Devel::Cycle::find_cycle($self);
my $out = LIMS::Local::DevelCycle::find($self); die $out if $out;
}
}
#-------------------------------------------------------------------------------
# for model methods, return (or if 1st call then create & return) a db object:
sub lims_db { shift->{__lims_db} ||= LIMS::RDBO->init_db } # should be the *only* call in whole app
sub dbh { shift->lims_db->dbh } # for Controller methods requiring the dbh eg session_config()
#-------------------------------------------------------------------------------
# drop-in replacements for CAP::ConfigAuto (cfg & config) - using L::Local::Config now
sub config {
my $self = shift;
my $cfg = LIMS::Local::Config->instance;
if (@_) {
my $section = shift;
return $cfg->{$section};
}
else {
return $cfg;
}
}
# alias for config() used by CAP::ConfigAuto:
sub cfg { shift->config(@_) }
#-------------------------------------------------------------------------------
# RUNMODES
#-------------------------------------------------------------------------------
sub login {
my $self = shift;
# for destination in login.tt - query->self_url with query_string args removed:
$self->tt_params( destination_url => $self->query->url(-path_info=>1) );
$self->tt_params( env => \%ENV );
# for idle timeout re-authentication:
if ( my $profile = $self->authen->store->fetch('yooza_profile') ) {
$self->tt_params( user_profile => $profile );
}
$self->_limerick();
return $self->tt_process('login/default.tt');
}
#-------------------------------------------------------------------------------
# PRIVATE METHODS
#-------------------------------------------------------------------------------
sub _configure_plugins {
my $self = shift;
# load config from config file:
my $cfg = $self->cfg;
#-------------------------------------------------------------------------------
# override default template_name_generator method:
$cfg->{tt_config}->{TEMPLATE_NAME_GENERATOR} = _tmpl_name_generator(); # should be able to do this in config?
# $self->tt_config( $cfg->{tt_config} ); # now loading TT as class method
__PACKAGE__->tt_config( $cfg->{tt_config} ); # (singleton) instead of object method
#-------------------------------------------------------------------------------
# configure CAP::Session - uses CGI::Session; gets cookie or hidden field
# session id from $cgi; add CGI_SESSION_OPTIONS (cgi method, session driver,
# etc) to session_config():
$cfg->{session_config}->{CGI_SESSION_OPTIONS} = $self->_set_cgisession_options();
$self->session_config( %{ $cfg->{session_config} } );
#-------------------------------------------------------------------------------
# configure CAP::Authentication:
my $authen_cfg = $self->_authen_config(); # doesn't work in lims_config if using instance()
$self->authen->config($authen_cfg);
#-------------------------------------------------------------------------------
# ValidateRM/DFV config:
$self->param( dfv_defaults => $cfg->{dfv_defaults} );
#-------------------------------------------------------------------------------
# CAP::MessageStack config:
$self->capms_config(
-automatic_clearing => 1, # removed from session after display
-classification_param_name => 'class', # default = 'classification'
);
#-------------------------------------------------------------------------------
FormValidator::Simple->set_messages( $self->messages('form_validator') );
#-------------------------------------------------------------------------------
# configure CAP::Authorization:
# push @{ $cfg->{authz_cfg}->{DRIVER} }, ( DBH => $self->dbh );
# $self->authz->config( $cfg->{authz_cfg} );
my $_self = $self; weaken $_self; # or get circular ref inside authz config()
# only used for package-wide auth ie __PACKAGE__->authz->authz_runmodes()
$self->authz->config(
DRIVER => [ 'Generic', sub {
# Generic driver recieves username as 1st arg (don't need it here):
my ($username, $action) = @_; # warn $action;
return $_self->user_can($action); # using user_can() to validate
}
],
# FORBIDDEN_RUNMODE => 'forbidden', # doesn't work with CA::Dispatch for
# class-wide authz, so defining authz_forbidden rm in prerun() instead
);
#-------------------------------------------------------------------------------
# CAP::Flash config: using CAP::MessageStack & self->flash() as drop-in replacement
# my $flash_config = $cfg->{flash};
# $self->flash_config( @$flash_config ); # using CGI::Session::Flash & $self->flash
#-------------------------------------------------------------------------------
# CAP::LogDispatch config (needs to be after session & authen configs):
# $self->_cap_logdispatch_setup; # comment out if using LIMS::Local::LogDispatch instead
#-------------------------------------------------------------------------------
# experimental - to stop large build-up of 'form_state_cap_form_state_<32-digits>
# => 172800' in session table (but still in _SESSION_EXPIRE_LIST from CGI::Session)
# TODO: actually dangerous if params expire - all will be null so params updated as such
# $self->form_state->config( expires => '+30m'); # puts form_state into url
}
#-------------------------------------------------------------------------------
# add CGI_SESSION_OPTIONS (cgi method, session driver, etc) to session_config():
sub _set_cgisession_options {
my $self = shift;
my $cfg = $self->cfg;
# override $cfg->{settings}->{db_session_serializer} to a readable format
# if running test suite:
$cfg->{settings}->{db_session_serializer} = 'default' if $ENV{HARNESS_ACTIVE};
my %CGI_SESSION_OPTIONS = (
db => [
'driver:MySQL;serializer:'.$cfg->{settings}->{db_session_serializer},
$self->query,
{ Handle => $self->dbh },
],
# need IDFile, IDInit & IDIncr in session_options_file if using id:incr
file => [
'driver:File;serializer:'.$cfg->{settings}->{file_session_serializer},
$self->query,
$cfg->{session_options_file},
],
);
# select CGI_SESSION_OPTIONS driver method from settings.txt (db or file):
my $session_driver # sessions dir if lims_server.pl
= $ENV{SERVER_SOFTWARE} =~ /HTTP::Server::Simple/ && ! $ENV{DB_SESSIONS}
? $cfg->{settings}->{session_driver}
: 'db'; # sessions table for production or test harness
return $CGI_SESSION_OPTIONS{$session_driver};
}
#-------------------------------------------------------------------------------
sub _authen_config { # doesn't work in lims_config.pl using L::L::C::instance()
my $self = shift;
my $settings = $self->cfg('settings');
my $_self = $self; weaken($_self); # or get circular ref inside callback
my $authen_driver
= $ENV{ROSEDB_DEVINIT} =~ /devinit_devel/ && ! $ENV{DB_SESSIONS}
? 'Dummy' # ! $ENV{HARNESS_ACTIVE} # use 'Dummy' login for devel
: [ 'Generic', sub { $_self->model('User')->verify_credentials(@_) } ];
# custom method to fine-tune timeout based on user type:
my $authen_timeout = sub { # returns true if the session should be timed out
my $authen = shift;
# get user profile, set in LIMS::_create_user_profile():
my $user_profile = $authen->store->fetch('yooza_profile'); # warn Dumper $user_profile;
my $user_location = $user_profile->{user_location}->{location_name};
# how long to set idle timeout:
my $timeout = $user_location eq $settings->{lab_name_abbreviation}
? $settings->{internal_user_timeout} # ie lab user
: $settings->{external_user_timeout}; # ie external/guest user
# uncomment to elevate admin timeout (value set in 'EVERY' will still apply):
$timeout = $settings->{admin_timeout} if $user_profile->{designation} =~ /^admin/i;
# ps aux | grep perl && lsof -p <process pid> - ?? keeps multiple fh open:
# _debug_authen($authen->last_access, $timeout); # can't use $self here!!!
return ( time() - $authen->last_access > $timeout ); # returns truth
};
return {
DRIVER => $authen_driver,
LOGIN_SESSION_TIMEOUT => {
IDLE_FOR => '24h', # same as session default - overridden under CUSTOM:
EVERY => '1d',
CUSTOM => \&$authen_timeout, # true if the session should be timed out
},
LOGIN_RUNMODE => 'login', # redirect_after_login requires destination field in .tt if used
STORE => 'Session', # ie CAP::Store::Session
}; # warn Dumper $cfg->{authen_cfg};
}
#-------------------------------------------------------------------------------
sub _configure_protected_runmodes { # CAP::Authentication protected_runmodes:
my $self = shift;
# all rm's protected except forgotten password, logout & AJAX functions:
# (need 'logout' or will have to login an expired session 1st to logout!!)
my $unprotected_runmodes = join '|', qw( password_ logout );
my @unprotected_classes = qw(ajax chart); # whole classes # eg from cron script
my $loaded_class = lc $self->param('Class'); # set in LIMS::Dispatch
unless ( grep $loaded_class eq $_, @unprotected_classes ) { # exempt
$self->authen->protected_runmodes( qr/^(?!$unprotected_runmodes)/ );
} # warn Dumper [$loaded_class, $self->authen->protected_runmodes];
}
#-------------------------------------------------------------------------------
sub _debug_authen { # called from within closure so don't use $self
my ($last_access, $timeout) = @_;
my $msg = sprintf 'LOGIN_SESSION_TIMEOUT: idle=%s, timeout=%s',
time() - $last_access, $timeout;
LIMS::Local::Debug::DEBUG($msg); # can't use $self->debug() - see above
}
#-------------------------------------------------------------------------------
sub _check_portal_referral {
my $self = shift; # $self->stash( REMOTE_ADDR => $ENV{REMOTE_ADDR} ); # to check mod_rpaf is working
# if user not logged in, have neither profile nor authen->username; on 1st login
# have authen->username but no profile (it's created after return from here); if
# logged in but timed-out, have profile but not authen->username. So need to
# check for profile OR username OR valid 'access_token' form flag OR permitted
# direct-entry IP address. Also allow :8080 VPN access on non-approved IP addr
my $user_profile = $self->authen->store->fetch('yooza_profile');
my $portal_access_ok = 0; # '/' sends access token as SHA1 digest of today DT
if ( my $token = $self->query->param('access_token') ) {
my $str = LIMS::Local::Utils::today->datetime; # eg 2010-01-01T00:00:00
$portal_access_ok = ( $token eq LIMS::Local::Utils::sha1_digest($str) );
}
return 1 # return OK if already logged in or hidden form param supplied:
if $self->authen->username # ie logged in and not timed out (see above)
|| $user_profile # ie AFTER initial login, even if timed-out (see above)
|| $portal_access_ok # from login page originally via portal root '/'
|| $ENV{SERVER_PORT} == 8080; # for VPN access on non-approved IP addr
# get array(ref) of permitted direct-entry IP addresses:
my $permitted = $self->get_yaml_file('local_addr'); # $self->debug($cfg);
# will return true only if REMOTE_ADDR matches a permitted ip address:
return ( grep { $ENV{REMOTE_ADDR} =~ /^$_/ } @$permitted );
}
#-------------------------------------------------------------------------------
sub _set_active_link {
my $self = shift; # use Data::Dumper; # warn Dumper $self->query->path_info;
my $default = 'search'; # default link
# get 'class' arg (if exists) from url eg /foo/bar/1 - class = 'foo':
my $class = ( split '/', $self->query->path_info )[1] || return $default;
# for classes that don't correspond directly to nav links:
my $mapped = {
# class nav-link
patient => 'register',
# request => 'register', # TODO: matches also 'unlock' & 'email_record'
config => 'admin',
};
my $active_link = $mapped->{$class} || $class || $default;
$self->tt_params( active_link => $active_link ); # warn $active_link;
}
#-------------------------------------------------------------------------------
sub _dump_authen_params {
my $self = shift;
my $authen = $self->authen;
my $profile = $authen->store->fetch('yooza_profile');
no warnings 'uninitialized';
$self->debug([
'is_authenticated:' . $authen->is_authenticated || 0,
'is_login_timeout:' . $authen->is_login_timeout || 0,
'profile_username:' . $profile->{username} || '',
'is_new_login:' . $authen->is_new_login || 0,
'last_access:' . $authen->last_access || '',
'last_login:' . $authen->last_login || '',
'username:' . $authen->username || '',
]);
}
#-------------------------------------------------------------------------------
# called from cgiapp_prerun only if authen->username exists && profile doesn't:
sub _create_user_profile {
my $self = shift;
# get users' details from users table, or die (can't use error() as session
# doesn't exist yet, so user_can() call from tmpl fails):
my $username = $self->authen->username;
my $user_details = $self->model('User')->get_user_by_username($username)
|| die 'no user details found in _create_user_profile()';
# first look for custom permissions:
my $user_permissions = # arrayref
$self->model('User')->get_user_permissions($user_details->id);
# if no custom permissions, load default settings for this users' group:
if (! @$user_permissions) {
$user_permissions =
$self->model('User')->get_user_group_functions($user_details->group_id);
}
# user_profile object to hashref - don't force_load or dies on login table
my $profile = $user_details->as_tree; # $self->debug($profile);
{ # get list of function_names from user_permissions object:
my @functions = map { $_->function->function_name } @$user_permissions;
# stuff functions list into $profile:
$profile->{functions} = \@functions; # $self->debug($profile);
}
{ # does user belong to local network?
my $belongs_to_local_network
= $self->model('User')->in_local_network($profile->{user_location_id});
$profile->{is_local_network} = $belongs_to_local_network;
}
# set session & authen user profile:
$self->session->param( UserProfile => $profile ); # TODO (lot of work) can probably replace this with:
$self->authen->store->save(yooza_profile => $profile); # for CAP::Authen LOGIN_SESSION_TIMEOUT
# update last_login date on user table:
$self->model('User')->update_last_login($username);
unless ( $profile->{designation} eq 'administrator' ) { # || ! $ENV{MOD_PERL};
# register successful login (except db admin):
$self->model('User')->register_login($self->session);
}
}
# ?? only works if rm = requested, not forwarded (use LIMS::get_template_name for that)
sub _tmpl_name_generator {
return sub {
my $self = shift;
# my $self->tt_template_name(1); # causes infinate loop -> out-of-memory error
my $rm = $self->get_current_runmode; # warn $rm;
my $module = ref $self; # warn $module;
# remove LIMS & LIMS/Controller from $module:
my @segments = grep $_ !~ 'LIMS|Controller', split '::', $module;
my $catfile = File::Spec->catfile(@segments, $rm);
my $tmpl = lc $catfile . '.tt';
# $self->debug('auto-generated template: ' . $tmpl);
return $tmpl;
};
}
#-------------------------------------------------------------------------------
sub _limerick {
my $self = shift;
my $src_file = $self->cfg('path_to_app_root') . '/src/lib/lear.txt';
return 0 unless (-e $src_file);
require LIMS::Local::Stuff; # to avoid compile-time error if absent
my $data = LIMS::Local::Stuff::limerick($src_file);
$self->tt_params( limerick => $data );
}
#-------------------------------------------------------------------------------
sub _debug_path {
my ($self, $method) = @_;
if (! $method) {
my @caller = caller(1); # warn $caller[3];
($method) = $caller[3] =~ /.*::(.*)/; # greedy matching ensures last
}
# done in LOG_DISPATCH_OPTIONS callbacks sub now:
# my $timings =
# sprintf "%s, %.4f sec", $method, tv_interval $self->param('t0'), [gettimeofday];
$self->debug($method); # DEBUG( $timings );
}
#-------------------------------------------------------------------------------
# never gets called if using CA::Dispatch - CAD uses its own error handling for
# non-existent rms
sub _exception {
my ($self, $intended_runmode) = @_; # $obj->_dump_path('_exception');
# my $output = "Looking for '$intended_runmode', but found 'AUTOLOAD' instead";
$self->tt_params(
mode => 'Error', # title
msg => $intended_runmode,
title => 'Unknown Action',
);
return $self->tt_process('site/exception.tt');
}
sub _capture_weakself {
# use as: my $callback = $self->_capture_weakself(sub { my ($self, @args) = @_ });
my ($self, $code) = @_;
weaken(my $weak_self = $self);
return sub {
$code->($weak_self, @_)
}
}
1;
__END__
# uses CAP::TT tt_template_name method to return path to template
# alternative to TEMPLATE_NAME_GENERATOR in tt_config - should be able to handle
# forwarded rm's; requires tmpl name to match module path
# (eg Admin::Screen::default() => admin/screen/default.tt):
=begin
sub _get_template_name {
my $self = shift;
# eg LIMS/Admin/Screen/Test/default.tmpl
my @segments = grep $_ !~ 'LIMS|Controller', split '/', $self->tt_template_name(1);
my $tmpl = File::Spec->catfile(@segments);
$tmpl =~ s/tmpl/tt/; # using tt suffix
return lc $tmpl; # DEBUG 'auto-generated template: ' . $tmpl;
}
=cut
# returns dbh object (and sets authen_cfg driver - not any more):
=begin # replaced with own dbh() method now
sub _dbh_config {
my $self = shift;
# Rose::DB method:
# my $driver = 'dbi_driver'; # not using now, replaced with Generic & sub {}
return LIMS::DB->new_or_cached->retain_dbh; # need retain_dbh or get:
=begin
ERROR' for request '/hmds/admin/user_location': Error executing class callback
in init stage: Can't connect to data source
'LIMS::DB::__RoseDBPrivate__::Rose::DB::MySQL=HASH(0x9a810f4)' because I can't
work out what driver to use (it doesn't seem to contain a 'dbi:driver:' prefix
and the DBI_DRIVER env var is not set) at
/home/raj/perl5/lib/perl5/CGI/Application/Plugin/DBH.pm line 42
=cut
# $dbi->trace(1, './logs/trace.log'); # best switched on in LIMS::DB::dbi_connect
# switch on profiling:
#use DBI::Profile;
#$dbi->{Profile} = DBI::Profile->new();
#$dbi->{Profile} = 2;
=begin # DBIC method:
use lib '/home/raj/www/apps/LIMS/tags/legacy/lib';
use LIMS::Schema;
$self->dbh_config( $cfg->{'dbh_params'} );
# add schema to object - move to own class - load as needed:
$self->param( schema => LIMS::Schema->connect(@{ $cfg->{dbh_params} }) );
$cfg->{'dbic_driver'}->[2] = $self->param('schema'); # SCHEMA
my $driver = 'dbic_driver';
=cut
=begin # using DRIVER = "Generic, sub {}" now - set in _configure_plugins()
# override DBH => undef in $self->cfg->{dbi_driver}:
@{ $self->cfg->{dbi_driver} }[2] = $db;
$self->cfg->{authen_cfg}{DRIVER} = $self->cfg->{$driver};
=cut
# return $db; # moved to top
#}
=begin # doesn't work with LIMS::Local::Config->instance method
sub _cap_logdispatch_setup { # using LIMS::Local::LogDispatch instead
my $self = shift;
my $cfg = $self->cfg; # warn Dumper $cfg;
# can't have $self in a callback:
my $t0 = $self->param('t0');
my $user = $self->authen->username;
$cfg->{log_dispatch}{LOG_DISPATCH_OPTIONS} = {
callbacks => sub {
my %h = @_; chomp $h{message};
my $timestamp = strftime "[%d-%b-%Y %H:%M:%S]", localtime;
return sprintf "%s %s %s [%.4f sec]\n",
$timestamp,
uc $user,
$h{message},
tv_interval $t0, [gettimeofday];
},
}; # warn Dumper $cfg->{log_dispatch};
$self->log_config( $cfg->{log_dispatch} );
}
=cut
