;
close(TIPS);
}
$/ = "\n"; # <> now reads until newline
$tips =~ s/#.*?\n//mg; # remove comments
@tiplist = split(/%%/, $tips);
return @tiplist;
}
# begin Timing code
use Benchmark;
sub dateTime {
my @timeArray = localtime(time);
my $out = sprintf("%2.2d-%2.2d-%2.2d %2.2d:%2.2d:%2.2d",
$timeArray[5],$timeArray[4]+1,@timeArray[3,2,1,0]);
$out;
}
#the ps system calls do not work on all systems, and are usually not
#necessary anyway. If you wish that information to be logged, simply
#uncomment the relevant lines, but be warned that they might need to
#be modified for your system
sub logTimingInfo {
my ($beginTime,$endTime,$script,$course,$user,$remoteHost,$userAgent) = @_;
$remoteHost = ""unless defined($remoteHost);
$userAgent = "" unless defined($userAgent);
open(TIMELOG, ">>${webworkLogsDirectory}timing_log") ||
warn "*Unable to open timing log for writing:\n ${webworkLogsDirectory}timing_log. ";
my $mem_string = '';
# my $process_string = `ps -o vsz -p $$`;
# $process_string =~ s/^\s*//;
# $process_string =~ s/\s*$//;
# my @process_string = split(/\s+/,$process_string); # gets memory size
# my $mem_string = " mem: ${process_string[1]}K";
my $load_string = '';
# my @load = split(/\n/,`ps -U wwhttpd -o state`);
# my $load_string = " load: " . grep(/R/,@load);
print TIMELOG $script,"\t",$course,"\t",&dateTime,"\t",
timestr( timediff($endTime,$beginTime), 'all' ),"\t",
"pid: $$ DBtie_tries: $Global::DBtie_tries" . $mem_string . $load_string,"\t",$user,"\t",
$remoteHost,"\t",$userAgent,"\n";
close(TIMELOG);
}
# end Timing code
# handy routines for modules that wish to throw exceptions outside of the
# current package. (taken from Carp.pm)
#
# We'll want to remove this in final versions of WeBWorK.
sub log_error {
my ($comment, $data) = @_;
my $accessLog = convertPath("${webworkLogsDirectory}access_log");
my $errorLog = convertPath("${webworkLogsDirectory}error_log");
open(ACCESS, ">>$accessLog");
open(ERROR, ">>$errorLog");
print ACCESS "ERROR ($comment) ", scalar(localtime), ': ', &shortmess($data);
print ERROR "ERROR ($comment) ", scalar(localtime), ': ', &shortmess($data);
close(ACCESS);
close(ERROR);
}
sub log_info {
if( $Global::logAccessData == 1 ) {
my ($comment, $data) = @_;
my $accessLog = convertPath("${webworkLogsDirectory}access_log");
open(LOG, ">>$accessLog") or warn "Can't open accessLog $accessLog";
print LOG "INFO ($comment) ", scalar(localtime), ': ', &shortmess($data);
close(LOG);
}
}
## converts full path names to to use the $dirDelim instead of /
sub convertPath {
my ($path) = @_;
warn "convertPath has been asked to convert an empty path
|$path| at ", caller(),"
" unless $path;
$path =~ s|/|$dirDelim|g;
$path;
}
# -----
BEGIN {
sub PG_floating_point_exception_handler { # 1st argument is signal name
my($sig) = @_;
print "Content-type: text/html\n\nThere was a floating point arithmetic error (exception SIG$sig )
--perhaps
you divided by zero or took the square root of a negative number?
\n Use the back button to return to the previous page and recheck your entries.
\n";
exit(0);
}
$SIG{'FPE'} = \&PG_floating_point_exception_handler;
sub PG_warnings_handler {
my @input = @_;
my $msg_string = longmess(@_);
my @msg_array = split("\n",$msg_string);
my $out_string = '';
# Extra stack information is provided in this next block
# If the warning message does NOT end in \n then a line
# number is appended (see Perl manual about warn function)
# The presence of the line number is detected below and extra
# stack information is added.
# To suppress the line number and the extra stack information
# add \n to the end of a warn message (in .pl files. In .pg
# files add ~~n instead
if ($input[$#input]=~/line \d*\.\s*$/) {
$out_string .= "##More details:
\n----";
foreach my $line (@msg_array) {
chomp($line);
next unless $line =~/\w+\:\:/;
$out_string .= "----" .$line . "
\n";
}
}
$Global::WARNINGS .="* " . join("
",@input) . "
\n" . $out_string .
"
\n--------------------------------------
\n
\n";
$Global::background_plain_url = $Global::background_warn_url;
$Global::bg_color = '#FF99CC'; #for warnings -- this change may come too late
}
$SIG{__WARN__}=\&PG_warnings_handler;
$SIG{__DIE__} = sub {
my $message = longmess(@_);
$message =~ s/\n/
\n/;
my ($package, $filename, $line) = caller();
# use standard die for errors eminating from XML::Parser::Expat
# it uses a trapped eval which sometimes fails -- apparently on purpose
# and the error is handled by Expat itself. We don't want
# to interfer with that.
if ($package eq 'XML::Parser::Expat') {
die @_;
}
#print "$package $filename $line \n";
print
"Content-type: text/html\r\n\r\n Software error
\n\n$message\n
\n
Please inform the webwork meister.
\n
In addition to the error message above the following warnings were detected:
$Global::WARNINGS;
It's sometimes hard to tell exactly what has gone wrong since the
full error message may have been sent to
standard error instead of to standard out.
To debug you can
- guess what went wrong and try to fix it.
- call the offending script directly from the command line
of unix
- enable the debugging features by redefining
\$cgiURL in Global.pm and checking the redirection scripts in
system/cgi. This will force the standard error to be placed
in the standard out pipe as well.
- Run tail -f error_log
from the unix command line to see error messages from the webserver.
The standard error output is being placed in the error_log file for the apache
web server. To run this command you have to be in the directory containing the
error_log or enter the full path name of the error_log.
In a standard apache installation, this file is at /usr/local/apache/logs/error_log
In a RedHat Linux installation, this file is at /var/log/httpd/error_log
At Rochester this file is at /ww/logs/error_log.
Good luck.\n" ;
};
}
###############
## Error message routines
###############
BEGIN { #error message routines
my $CarpLevel = 0; # How many extra package levels to skip on carp.
my $MaxEvalLen = 0; # How much eval '...text...' to show. 0 = all.
sub longmess {
my $error = shift;
my $mess = "";
my $i = 1 + $CarpLevel;
my ($pack,$file,$line,$sub,$eval,$require);
while (($pack,$file,$line,$sub,undef,undef,$eval,$require) = caller($i++)) {
if ($error =~ m/\n$/) {
$mess .= $error;
}
else {
if (defined $eval) {
if ($require) {
$sub = "require $eval";
}
else {
$eval =~ s/[\\\']/\\$&/g;
if ($MaxEvalLen && length($eval) > $MaxEvalLen) {
substr($eval,$MaxEvalLen) = '...';
}
$sub = "eval '$eval'";
}
}
elsif ($sub eq '(eval)') {
$sub = 'eval {...}';
}
$mess .= "\t$sub " if $error eq "called";
$mess .= "$error at $file line $line\n";
}
$error = "called";
}
$mess || $error;
}
sub shortmess { # Short-circuit &longmess if called via multiple packages
my $error = $_[0]; # Instead of "shift"
my ($curpack) = caller(1);
my $extra = $CarpLevel;
my $i = 2;
my ($pack,$file,$line);
while (($pack,$file,$line) = caller($i++)) {
if ($pack ne $curpack) {
if ($extra-- > 0) {
$curpack = $pack;
}
else {
return "$error at $file line $line\n";
}
}
}
goto &longmess;
}
}
###############
## End Error message routines
###############
1; ## This line is required by perl