See the docs for CGI::Carp
Thank you very much.
I google CGI::Carp,
It seems that it originally contains the Carp.
Now, I paste the two *.pm
(
I add warn in Staff.pm, but the warn information does NOT appear in
the error_log.
I add warn in mason.pm, the warn info does appear in the error_log.
)
First file is lib/Clinic/Party/Staff.pm
package Clinic:
arty::Staff;
use strict;
use Carp;
use DBRX::Entity::Current '-isasubclass', (
type_id => 'S',
type_name => 'Staff',
type_description => 'The Staff entity tracks care providers and
support staff.',
);
Class::MakeMethods->make(
'Template::Hash:scalar --eiffel' => [
qw(
id fname lname login password
email title degree gender
ethnicity_id supervisor_id
admin clinician status clinic
),
],
);
# fields to display on list view
sub list_columns {
my $self = shift;
my $columns = [
{
header => 'Name',
field => sub {
my $staff = shift;
return "<a href='/S/" . $staff->id . "'>" . $staff->value
('lname')->text . ', ' . $staff->value('fname')->text . "</a>";
},
},
{
header => 'Email',
field => sub {
my $email = shift->value('email');
return $email->text if $email;
},
},
{
header => 'Active',
field => sub {
my $status = shift->value('status');
my $a = $status->text if $status;
if ( $a eq 'No' ) {
$a = qq|<font color="#000000">$a</font>|;
} elsif ( $a eq 'Yes' ) {
$a = qq|<font color="#CC0000">$a</font>|;
}
return $a;
},
},
{
header => 'Account Type',
field => sub {
my $staff = shift;
my $val = $staff->value('type');
return $val->text if $val;
},
},
{
header => 'Clinician',
field => sub {
my $clinician = shift->value('clinician');
return $clinician->text if $clinician;
},
},
{
header => 'Supervisor',
field => sub {
my $s = shift->value('supervisor');
return $s->text if $s;
},
},
];
return $columns;
}
sub detail_header {
my $self = shift;
my $path = shift;
my $detail_header = $self->value( 'fname' )->text . ' ' . $self-
value( 'lname' )->text . ', ' . $self->value( 'degree' )->text . '</
small>';
}
##
# Authentication
use Crypt::Simple passphrase => 'pass phrase';
sub authenticate {
my ( $self, $user, $pass ) = @_;
my $enc_pass = encrypt($pass);
my $staff = $self->fetch_one( { login => $user, password =>
$enc_pass } ) || '';
return unless $staff;
return if $staff->value('type')->raw_int == 663; # type:supervisor
return unless $staff->status; # active
return $staff->id;
}
sub decrypt_pass {
my $self = shift;
return decrypt( $self->password );
}
sub is_default_pass {
my $staff = shift;
my $enc_clinic = encrypt('abcdef');
return 1 if $staff->password eq $enc_clinic;
return 0;
}
sub is_password_expired {
my $staff = shift;
return 1 if $staff->days_since_last_password_change > 90; # CUTOFF
DAYS FOR PASS EXPIRATION
return 0;
}
sub days_since_last_password_change {
my $staff = shift;
my $changes = DBRX::Entity::History->fetch( {
entity_type_id => 'S',
entity_id => $staff->id,
} , [ 'id' ] );
my $most_recent_pass_change = Quantity::Timestamp->current->value;
foreach my $c ( @$changes ) {
my $change_values = $c->values;
foreach ( @$change_values ) {
#warn Quantity::Timestamp->new($c->timestamp)->readable if $_-
$_->{timestamp} = $c->timestamp;
$most_recent_pass_change = $c->timestamp if $_->attribute_id ==
32;
}
}
#warn Quantity::Timestamp->new($most_recent_pass_change)->readable;
return ((Quantity::Timestamp->current->value -
$most_recent_pass_change) /
( 60 * 60 * 24 ) );
}
sub needs_to_change_password {
my $staff = shift;
return 1 if $staff->is_default_pass || $staff->is_password_expired;
return 0;
}
##
sub last_session_time {
my $user = shift;
my $sql = 'select * from session where user_id = ' . $user->id . '
order by id desc limit 1';
my $session = @{$user->fetch_sql( $sql )}[0];
my $time = Quantity:
ate->current;
$time->set_udt( $session->{started} );
return $time->readable;
}
sub name_link {
my $staff = shift;
return q{ said:
}
1;
Second file is lib/Dixon/Mason.pm
package Dixon::Mason;
use strict;
use Carp;
use Apache::Constants qw( :response );
use HTML::Mason;
use Carp;
use Dixon::Session::Identifier;
########################################################################
use vars qw( $Interpreter $ApacheHandler $Session );
use Clinic::Site::Config;
my $server_root = Clinic::Site::Config->dir_path;
$Interpreter = HTML::Mason::Interp->new(
parser => HTML::Mason:
arser->new(),
comp_root => $server_root,
data_dir => "$server_root/var/mason",
out_mode => 'batch',
# use_data_cache => undef(),
code_cache_max_size => 0,
# verbose_compile_error => 1,
dhandler_name => 'dhandler',
);
use HTML::Mason::ApacheHandler (args_method=>'mod_perl');
$ApacheHandler = HTML::Mason::ApacheHandler->new(
interp => $Interpreter,
error_mode => 'fatal',
decline_dirs => 0,
# error_mode => 'html',
# output_mode => 'batch',
);
########################################################################
my @proxy_addrs = qw( 127.0.0.1 209.208.128.102 209.208.128.101 );
sub correct_proxy_address ($) {
my $r = shift;
# we'll only look at the X-Forwarded-For header if the requests
# comes from our proxy at localhost
my $remote = $r->connection->remote_ip;
my $forward = $r->header_in('X-Forwarded-For');
return Apache::Constants::OK
unless ( $forward and grep { $remote eq $_ } @proxy_addrs );
# Select last value in the chain -- original client's ip
if ( my($ip) = ($forward =~ /([^,\s]+)$/) ) {
$r->connection->remote_ip($ip);
}
return Apache::Constants::OK;
}
########################################################################
use HTTP:
ate qw(time2str str2time);
use Time::HiRes;
sub content_handler {
my $time = time();
my ($r) = @_;
my $uri = $r->uri();
my $pid = $$;
warn "Dixon::Mason content_handler for $uri\n";
warn "Query String: " . substr( $r->args(), 0, 125 ) . "\n" if $r-
$r->no_cache();
$r->header_out("Expires" => time2str($time - (60*60*3)));
# CATCH ANNOYING REQUESTS
# Added default.ida 2.15.2002
# Added favico 8.1.2005
# Added servlet/webacc 5.14.2006
if ( $uri =~ /scripts/ or $uri =~ /\.exe/
or $uri =~ /default.ida/ or $uri =~ /\.asp/
or $uri =~ /\.dll/ or $uri =~ /favico/
or $uri =~ /webacc/ or $uri =~ /vti/
) {
$r->get_remote_host;
#warn 'Inappropriate Request From: ' . $r->get_remote_host . ':' .
$r->get_remote_logname;
return 'FORBIDDEN';
}
### Session
my ( $Session, $status );
eval {
local $SIG{ALRM} = sub { die "Timeout waiting for session $@" };
alarm 45;
$Session = Dixon::Session::Identifier->establish( $r );
warn "Session: $Session->{public_id}\n";
alarm 0;
local $HTML::Mason::Commands::Session = $Session;
$status = $ApacheHandler->handle_request($r);
$time = time() - $time;
warn "Mason ApacheHandler returned $status\n";
warn "user_id:" . ( $Session->{user_id} || '(Not Logged In)' ) .
"
age:$uri:time:$time\n\n";
};
die $@ if $@;
return $status;
}
sub child_init_handler {
# Make sure each Apache process has its own random numbers.
srand();
warn "Mason.pm.......................01";
warn "Reconnecting to database...\n";
warn "Mason.pm.......................02";
DBRX::Framework->datasource->reconnect();
warn "Mason.pm.......after reconnect()";
}
sub fixup_handler {
my ($r) = @_;
my $uri = $r->uri();
warn "entering fixup handler for $uri";
return DECLINED;
}
########################################################################
# $component = Dixon::Mason->fetch_component( $component_path );
sub fetch_component {
my $class = shift;
my $component_name = shift;
$HTML::Mason::Commands::m->fetch_comp( $component_name )
or Carp::confess("No such component '$component_name'");
}
# $component = Dixon::Mason->build_component( $mason_text );
sub build_component {
my $class = shift;
my $expr = shift;
return $Interpreter->make_component( script => $expr );
}
# $result = Dixon::Mason->eval_component( $mason_text, @arguments );
sub eval_component {
my $class = shift;
my $expr = shift;
my $component = ref($expr) ? $expr :
$Interpreter->make_component( script => $expr )
or Carp::croak( "Can't interpret component '$expr'" );
my $result = $HTML::Mason::Commands::m->scomp( $component, @_ );
# warn "Eval '$expr' : '$result'\n";
$result;
}
package HTML::Mason::Commands;
use vars qw( $Session $SessionID $SessionData $SessionEvent );
use Carp;
use Dixon::HTMLWriter qw[
emit_uri emit_text emit_text_paras emit_tag
];
1;
Thank you very much.
