[LON-CAPA-cvs] cvs: modules /raeburn neutrinoharvest.pl
raeburn
raeburn@source.lon-capa.org
Fri, 15 Oct 2010 20:18:25 -0000
This is a MIME encoded message
--raeburn1287173905
Content-Type: text/plain
raeburn Fri Oct 15 20:18:25 2010 EDT
Added files:
/modules/raeburn neutrinoharvest.pl
Log:
- Bug 5531. Investigations continue.
--raeburn1287173905
Content-Type: text/plain
Content-Disposition: attachment; filename="raeburn-20101015201825.txt"
Index: modules/raeburn/neutrinoharvest.pl
+++ modules/raeburn/neutrinoharvest.pl
#!/usr/bin/perl
# Stuart Raeburn 10/15/2010
#
# neutrinoharvest.pl
#
# Script run on LON-CAPA library server by user www
# - Detects cases where resubmission of previous answer for case sensitive
# stringresponse item resulted in award change to EXACT_ANS.
# See bug 5531.
use strict;
use lib '/home/httpd/lib/perl/';
use Apache::lonnet;
use Apache::loncommon;
use Apache::lonuserstate;
use Apache::loncoursedata;
use Apache::lonnavmaps;
use LONCAPA qw(:DEFAULT :match);
exit if ($Apache::lonnet::perlvar{'lonRole'} ne 'library');
# Make sure this process is running from user=www
my $wwwid=getpwnam('www');
if ($wwwid!=$<) {
my $emailto="$Apache::lonnet::perlvar{'lonAdmEMail'}";
my $subj="LON: $Apache::lonnet::perlvar{'lonHostID'} User ID mismatch";
system("echo 'User ID mismatch. neutrinoharvest.pl must be run as user www.' |\
mail -s '$subj' $emailto > /dev/null");
exit 1;
}
# Let people know we are running
open(my $fh,'>>'.$Apache::lonnet::perlvar{'lonDaemons'}.'/logs/neutrinocheck.log');
print $fh "==== neutrinoharvest.pl Run ".localtime()."====\n";
my @domains = sort(&Apache::lonnet::current_machine_domains());
my @ids=&Apache::lonnet::current_machine_ids();
my @okcourses;
my $delta;
$env{'allowed.bre'} = 'F';
my $hasdelta = 0;
my $now = time;
if (@ARGV > 0) {
if (@ARGV == 1) {
if ($ARGV[0] =~ /^\d+$/) {
if ($ARGV[0] < $now) {
$hasdelta = 1;
$delta = $ARGV[0];
}
}
}
if ($hasdelta) {
foreach my $dom (@domains) {
my %courseshash;
my %currhash = &Apache::lonnet::courseiddump($dom,'.',1,'.','.','.',1,\@ids,'.');
my %lastaccess = &Apache::lonnet::courselastaccess($dom,undef,\@ids);
my $dir = $Apache::lonnet::perlvar{lonUsersDir}.'/'.$dom;
&recurse_courses($dom,$dir,0,\%courseshash,\%currhash,\%lastaccess,$fh,\@okcourses,$delta);
}
} else {
foreach my $cid (@ARGV) {
my ($cdom,$cnum) = split(/_/,$cid);
if (grep(/^\Q$cdom\E/,@domains)) {
my $chome = &Apache::lonnet::homeserver($cnum,$cdom);
if (grep(/^\Q$chome\E/,@ids)) {
push(@okcourses,$cid);
}
}
}
}
} else {
print("Usage: neutrinoharvest.pl <Seconds since last access to filter courses|course_ids e.g., sfu_5H34111eaeeee4b95sful1 sfu_1J125875c1efa4b46sful1>\n");
delete($env{'allowed.bre'});
exit;
}
if (@okcourses) {
foreach my $cid (@okcourses) {
&log_neutrinos($cid,$fh);
}
} else {
print("No valid courses to check on this library server\n");
}
delete($env{'allowed.bre'});
## Finished!
print $fh "==== neutrinoharvest.pl completed ".localtime()." ====\n";
close($fh);
exit;
sub recurse_courses {
my ($cdom,$dir,$depth,$courseshash,$currhash,$lastaccess,$fh,$okcourses,$delta) = @_;
next unless (ref($currhash) eq 'HASH');
my $limit = time - $delta;
if (-d $dir) {
opendir(DIR,$dir);
my @contents = grep(!/^\./,readdir(DIR));
closedir(DIR);
$depth ++;
foreach my $item (@contents) {
if ($depth < 4) {
&recurse_courses($cdom,$dir.'/'.$item,$depth,$courseshash,
$currhash,$lastaccess,$fh,$okcourses,$delta);
} elsif ($item =~ /^$match_courseid$/) {
my $cnum = $item;
my $cid = $cdom.'_'.$cnum;
my $is_course = 0;
if (ref($currhash->{$cid}) eq 'HASH') {
$is_course = 1;
} else {
if (-e "$dir/$cnum/passwd") {
if (open(my $pwfh,"<$dir/$cnum/passwd")) {
while (<$pwfh>) {
if (/^none:/) {
$is_course = 1;
last;
}
}
}
}
}
if ($is_course) {
if ($lastaccess->{$cid} > $limit) {
if (ref($okcourses) eq 'ARRAY') {
push(@{$okcourses},$cid);
}
}
}
}
}
}
return;
}
sub log_neutrinos {
my ($cid,$fh) = @_;
my ($cdom,$cnum) = split(/_/,$cid);
return unless ($cdom && $cnum);
my $chome = &Apache::lonnet::homeserver($cnum,$cdom);
return if ($chome eq 'no_host');
my %courseinfo=&Apache::lonnet::coursedescription($cid,{'one_time' => '1'});
$env{'request.course.id'} = $cid;
$env{'request.role'} = 'cc./'.$cdom.'/'.$cnum;
&Apache::lonuserstate::readmap($cdom.'/'.$cnum);
# check course contents
my %strings = &coursecontent_constraints($cnum,$cdom);
my $classlist = &Apache::loncoursedata::get_classlist($cdom,$cnum);
foreach my $stu (sort(keys(%{$classlist}))) {
my ($stuname,$studom) = split(/:/,$stu);
my $firstcorrect;
foreach my $symb (sort(keys(%strings))) {
my %history= &Apache::lonnet::restore($symb,$cid,$studom,$stuname);
if (ref($strings{$symb}) eq 'ARRAY') {
foreach my $item (@{$strings{$symb}}) {
my ($prefix,$type) = split(/:/,$item);
if ($history{$prefix.'.awarddetail'} eq 'EXACT_ANS') {
my $correct = $history{$prefix.'.submission'};
my (@errors,$firstcorrect);
foreach my $key (sort(keys(%history))) {
if ($key =~ /^(\d+):\Q$prefix\E\.submission$/) {
my $hist = $1;
next if ($firstcorrect && $hist > $firstcorrect);
if ($history{$key} eq $correct) {
my $award = $history{"$hist:$prefix.awarddetail"};
if ($award eq 'INCORRECT') {
push(@errors,$hist);
} elsif ($award eq 'EXACT_ANS') {
if ($firstcorrect eq '') {
$firstcorrect = $hist;
} else {
if ($hist < $firstcorrect) {
$firstcorrect = $hist;
}
}
}
}
}
}
if (@errors > 0) {
@errors = sort {$a <=> $b} @errors;
print $fh "$cid $stu ".join(',',@errors)." vs $firstcorrect ||$correct|| $symb$prefix\n";
}
}
}
}
}
}
delete($env{'request.course.id'});
delete($env{'request.role'});
return;
}
sub coursecontent_constraints {
my ($cnum,$cdom) = @_;
my $navmap = Apache::lonnavmaps::navmap->new();
my %strings;
if (defined($navmap)) {
my $anonsurv_subm;
foreach my $res ($navmap->retrieveResources(undef,sub { $_[0]->is_problem() },1,0)) {
my %responses = $res->responseTypes();
next unless(grep(/^string$/,keys(%responses)));
my $symb = $res->symb();
foreach my $part (@{$res->parts()}) {
my @ids = $res->responseIds($part);
my @types = $res->responseType($part);
for (my $i=0; $i<@types; $i++) {
if ($types[$i] eq 'string') {
push(@{$strings{$symb}},"resource.$part.$ids[$i]");
}
}
}
}
}
return %strings;
}
--raeburn1287173905--