#!/usr/bin/perl -w
#
# wwclearAnonymous:
# clear all versioned sets from practice users in @courses for which
# the practice users are not currently logged in
#
# by Gavin LaRose, <glarose@umich.edu>
my $version = '1.21';
my $lastmod = '9 Aug 2010';
#
# changelog: 1.21: update copyright
# 1.2: correct for new database API
# 1.1: add logging capability
#
# (c)2010 Regents of the University of Michigan
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
#
#------------------------------------------------------------------------------
# configuration
#
use strict;
$ENV{PATH} = '/bin:/usr/bin';
# to get data from databases
my $wwHome = '/var/www/webwork/webwork2';
use lib '/var/www/webwork/webwork2/lib';
use WeBWorK::CourseEnvironment;
use WeBWorK::DB;
use WeBWorK::Utils;
# my @courses = ( qw( ma105-demo ) );
my @courses = ( qw( mathprep ) );
# should we log data about the number of tests taken?
my $keepLog = 1;
# the format of the log file is
# year mo da : course (#tests; #users), ..
# where #tests is the total number of tests deleted and #users the (maximum)
# number of guest logins that had tests to delete when the script was run.
# thus an entry will be like
# 2006 10 18 : ma105-demo (3; 1), ma115-demo (5; 2), ma116-demo (0; 0)
# if the script is run more than one time on a given day it will update the
# totals in the file. this means that the number of tests is incremented
# and if the maximum number of users is greater than that in the file the
# maximum is also updated; if there are no tests in any of the courses, no
# log entry is written
# my $logFile = '/var/www/data/gateways/demo_tests.txt';
my $logFile = '/var/www/data/webwork/demo_tests.txt';
#------------------------------------------------------------------------------
# main
main();
# suppress residual errors (why is this necessary?)
open( DN, ">/dev/null" );
*STDERR = *DN;
sub main {
# data logging: logData{course} = { user => numtests }
my %logData = () if ( $keepLog );
foreach my $crs ( @courses ) {
$logData{$crs} = { } if ( $keepLog );
# bring up a course environment and database object
my $ce = WeBWorK::CourseEnvironment->new({webwork_dir => $wwHome,
courseName => $crs});
my $db = WeBWorK::DB->new($ce->{dbLayout});
# get a list of all practice users
my @prUsers = grep {/^practice/} ( $db->listUsers() );
# check to see which users are logged in
my @prKeys = $db->getKeys( @prUsers );
my @loggedIn = ();
foreach my $key ( @prKeys ) {
if ( defined($key) &&
time() <= $key->timestamp() + $ce->{sessionKeyTimeout} ) {
push( @loggedIn, $key->user_id() );
}
}
my @delUsers = ();
# don't delete sets for those users
foreach my $user ( @prUsers ) {
my $skip = 0;
foreach my $in ( @loggedIn ) {
if ( $user eq $in ) {
$skip = 1;
last;
}
}
push( @delUsers, $user ) if ( ! $skip );
}
# get and delete versioned sets for remaining practice users
# we have to get a list of all sets assigned, and then figure
# out which of those are versioned
my @versionedSets = ();
if ( @delUsers ) {
my $user = $delUsers[0];
my @usIDs = map {[$user, $_]} ($db->listUserSets( $user ));
my @userSets = $db->getMergedSets( @usIDs );
@versionedSets = grep {$_->assignment_type =~ /gateway/} @userSets;
# and condense this down to just the assignment names
@versionedSets = map { $_->set_id } @versionedSets;
}
foreach my $user ( @delUsers ) {
my @setVersions = ();
foreach my $setID ( @versionedSets ) {
push(@setVersions, (map {[$setID,$_]}
($db->listSetVersions($user,$setID))));
}
$logData{$crs}->{$user} = scalar( @setVersions ) if ( $keepLog );
foreach my $setvID ( @setVersions ) {
$db->deleteSetVersion( $user, $setvID->[0], $setvID->[1] );
}
}
}
writeLogData( \%logData ) if ( $keepLog );
}
#
#------------------------------------------------------------------------------
# subroutines
sub writeLogData {
my $dataRef = shift();
my %logData = %$dataRef;
# build a new logData array logNums{crs} = [ numTests, numUsers ]
my %logNums = ();
my $totNumTests = 0;
foreach my $crs ( keys ( %logData ) ) {
my $numTests = 0;
my $numUsers = 0;
foreach my $user ( keys ( %{$logData{$crs}} ) ) {
$numTests += $logData{$crs}->{$user};
$numUsers++ if ( $logData{$crs}->{$user} );
}
$totNumTests += $numTests;
$logNums{$crs} = [ $numTests, $numUsers ];
}
if ( $totNumTests ) {
my @timeVars = localtime();
my $year = $timeVars[5] + 1900;
my $month = sprintf("%02d", $timeVars[4] + 1);
my $day = sprintf("%02d", $timeVars[3]);
my $lineFmt = '\d{4} \d{2} \d{2} : ';
foreach my $crs ( @courses ) { $lineFmt .= $crs . ' \(\d+; \d+\), '; }
$lineFmt =~ s/, $//;
my @logLines = ();
@logLines = `/bin/cat $logFile` if ( -f $logFile );
open( LF, ">$logFile" ) or die("wwclearAnonymous: Cannot open log " .
"file $logFile for writing.\n");
my $addedLogData = 0;
foreach my $line ( @logLines ) {
if ( $line =~ /^($lineFmt)/ ) {
if ( $line =~ /^$year $month $day/ ) {
my $newLine = "$year $month $day : ";
foreach my $crs ( @courses ) {
my ( $numTests, $numUsers ) =
( $line =~ /$crs \((\d+); (\d+)\)/ );
if ( defined( $numTests ) && defined( $numUsers ) &&
defined( $logData{$crs} ) ) {
$numTests += $logNums{$crs}->[0];
$numUsers =
$logNums{$crs}->[1] if ( $numUsers <
$logNums{$crs}->[1] );
}
$newLine .= "$crs ($numTests; $numUsers), ";
}
$newLine =~ s/, $//;
print LF $newLine, "\n";
$addedLogData = 1;
} else {
print LF $line;
}
} else {
# bad line format; skip line
next;
}
}
if ( ! $addedLogData ) {
my $newLine = "$year $month $day : ";
foreach my $crs ( @courses ) {
if ( defined( $logNums{$crs} ) ) {
$newLine .= "$crs (" . $logNums{$crs}->[0] . "; " .
$logNums{$crs}->[1] . "), ";
} else {
$newLine .= "$crs (0; 0), ";
}
}
$newLine =~ s/, $//;
print LF $newLine, "\n";
}
close(LF);
return 1;
} else {
return 1; # don't log anything if there are no tests taken
}
}
#
#------------------------------------------------------------------------------