Return to rebuild_db_from_hist.pl CVS log

Up to [LON-CAPA] / loncom / debugging_tools

- Score upload form supports identification of a user based on clicker ID,
  for Course Coordinators who prefer not to use LON-CAPA's in-built
  "Process Clicker" utility.
- clickers.db file on a library server contains key = value pairs, where key
  is (escaped) clicker ID, and value is (escaped) comma-separated list of
  usernames who registered that particular clicker ID.
- bi-nightly run of searchcat.pl will update clickers.db file.

#!/usr/bin/perl -w
#
# The LearningOnline Network
#
# rebuild_db_from_hist.pl Rebuild a *.db file from a *.hist file
#
# $Id: rebuild_db_from_hist.pl,v 1.7 2016/01/31 21:26:01 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
# This file is part of the LearningOnline Network with CAPA (LON-CAPA).
#
# LON-CAPA 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 2 of the License, or
# (at your option) any later version.
#
# LON-CAPA 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 LON-CAPA; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
# /home/httpd/html/adm/gpl.txt
#
# http://www.lon-capa.org/
#
#################################################
use strict;
use lib '/home/httpd/lib/perl';
use Getopt::Long;
use GDBM_File;
use LONCAPA;
use Apache::lonnet;

#
# Options
my ($help,$debug,$test,$test_db,$p_is_s);
GetOptions("help"           => \$help,
           "debug"          => \$debug,
           "test"           => \$test,
           "create_test_db" => \$test_db,
           "p_is_s"         => \$p_is_s);

if (! defined($debug))   { $debug   = 0; }
if (! defined($test))    { $test    = 0; }

#
# Help them out if they ask for it
if ($help) {
    print <<'END';
rebuild_db_from_hist.pl - recreate a db file from a hist file.
Options:
   -help     Display this help.
   -debug    Output debugging code (not much is output yet)
   -test     Verify the given *.hist file will reconstruct the current db file
             Sends error messages to STDERR.
   -create_test_db
             when testing also create a *.db.test db of the testing info
   -p_is_s   Treat 'P' lines as 'S' lines.
Examples: 
    rebuild_db_from_hist.pl -t $file.hist  # Perform a test rebuild
    rebuild_db_from_hist.pl $file.hist       
END
    exit;
}

#
# Loop through ARGV getting files.
while (my $fname = shift) {
    if ($fname !~ m/\.hist$/) {
	print("error: $fname is not a hist file");
	next;
    }

    my $db_filename = $fname;
    $db_filename =~ s/\.hist$/\.db/;
    if (-e $db_filename && ! $test) {
        print STDERR "Aborting: The target file $db_filename exists.".$/;
        next;
    }
    my ($error,$constructed_hash) = &process_file($fname,$db_filename,$debug);
    if (! defined($error) ) {
	$error = &update_hash($db_filename,$constructed_hash);
    }
    if (! defined($error) || ! $test) {
        $error = &write_hash($db_filename,$constructed_hash);
    }
    if ($test && $test_db) {
        $error = &write_hash($db_filename.'.test',$constructed_hash);
    }
    if ($test) {
        my $error = &test_hash($db_filename,$constructed_hash);
        if (defined($error)) {
            print "Error processing ".$fname.$/;
            print STDERR $error;
        } else {
            print "Everything looks good for ".$fname.$/;
        }
    }
    if (defined($error)) {
        print $error.$/;
    }
}

exit;

######################################################
######################################################
sub process_file {
    my ($fname,$db_filename,$debug) = @_;
    #
    open(HISTFILE,$fname);
    my %db_to_store;
    my $no_action_count = 0;
    while (my $command = <HISTFILE>) {
        chomp($command);
        my $error = undef;
        # Each line can begin with:
        #  P:put
        #  S:store
        #  D:delete
        #  N:new put (only adds tha values if they are all new values)
	#  M:modify the values for a previous S
        #  U:update the values (action could be add or del).
        my ($action,$time,$concatenated_data) = split(':',$command,3);
        if ($fname eq 'roles.hist' && $concatenated_data =~ /^.*:.*:/) {
            (undef,undef,$concatenated_data) = split(':',$concatenated_data,3);
        }
        next if (! defined($action));
        if ($action eq 'P' && $p_is_s) { $action = 'S'; }
        my ($rid,@allkeys,$version,$updatetype);
        if ($action eq 'S') {
            ($rid,$concatenated_data) = split(':',$concatenated_data,2);
            $version = ++$db_to_store{"version:$rid"};
             #print $version.$/;
        }
	if ($action eq 'M') {
            ($rid,$version,$concatenated_data) = 
		split(':',$concatenated_data,3);
	}
        if ($action eq 'U') {
            ($updatetype,$concatenated_data) =
                split(':',$concatenated_data,2); 
        }
        next if (! defined($concatenated_data));
	my $add_new_data = 1;
        my @data = split('&',$concatenated_data);
        foreach my $k_v_pair (@data) {
            my ($key,$value) = split('=',$k_v_pair,2);
            if (defined($action) && $action eq 'P') {
                if (defined($value)) {
                    $db_to_store{$key}=$value;
                } else {
                    $no_action_count++;
                }
            } elsif ($action eq 'S' || $action eq 'M') {
                # Versioning of data, so we update the old ata
                push(@allkeys,$key);
                $db_to_store{"$version:$rid:$key"}=$value;
            } elsif ($action eq 'N') {
                if (exists($db_to_store{$key})) {
		    $add_new_data = 0;
		    print "exists $key\n";
		}
            } elsif ($action eq 'D') {
                delete($db_to_store{$key});
            } elsif ($action eq 'U') {
                if ($updatetype eq 'del') {
                    if (exists($db_to_store{$key})) {
                        my %current;
                        map { $current{$_} = 1; } split(/,/,&unescape($db_to_store{$key}));
                        map { delete($current{$_}); } split(/,/,&unescape($value));
                        if (keys(%current)) {
                            $db_to_store{$key}=&escape(join(',',sort(keys(%current))));
                        } else {
                            delete($db_to_store{$key});
                        }
                    }
                } elsif ($updatetype eq 'add') {
                    if (exists($db_to_store{$key})) {
                        my @newvals = split(/,/,&unescape($value));
                        my @currvals = split(/,/,&unescape($db_to_store{$key}));
                        my @merged = sort(keys(%{{map { $_ => 1 } (@newvals,@currvals)}}));
                        $db_to_store{$key}=&escape(join(',',@merged));
                    } else {
                        $db_to_store{$key}=$value;
                    }
                }
            } else {
                $error = "Unable to understand action '".$action."'";
            }
        }

	if ($action eq 'N' && $add_new_data) {
	    foreach my $k_v_pair (@data) {
		my ($key,$value) = split('=',$k_v_pair,2);
		$db_to_store{$key}=$value;
	    }
	}
	if ($action eq 'S') {
	    $db_to_store{"$version:$rid:timestamp"}=$time;
	    push(@allkeys,'timestamp');
	}
        if ($action eq 'S' || $action eq 'M') {
	    $db_to_store{"$version:keys:$rid"}=join(':',@allkeys);
        }
        if (defined($error)) {
            return ('Error:'.$error.$/,undef);
        }
    }
    if ($no_action_count) {
        print $no_action_count.' lines did not require action.'.$/;
    }
    close(HISTFILE);
    return (undef,\%db_to_store);
}

sub write_hash {
    my ($db_filename,$db_to_store) = @_;
    #
    # Write the gdbm file
    my %db;
    if (! tie(%db,'GDBM_File',$db_filename,&GDBM_WRCREAT(),0640)) {
        warn "Unable to tie to $db_filename";
        return "Unable to tie to $db_filename";
    }
    #
    while (my ($k,$v) = each(%$db_to_store)) {
        $db{$k}=$v;
    }
    #
    untie(%db);
    return undef;
}

sub test_hash {
    my ($db_filename,$my_db) = @_;
    #
    my %db;
    if (! tie(%db,'GDBM_File',$db_filename,&GDBM_READER(),0640)) {
        return "Unable to tie to $db_filename";;
    }
    my (%key_errors,%value_errors);
    while (my ($k,$v) = each(%db)) {
        if (exists($my_db->{$k})) {
            if ($my_db->{$k} eq $v) {
                delete($my_db->{$k});
            } else {
                $value_errors{$k}=$v;
            }
        } else {
            $key_errors{$k}=$v;
        }
    }
    untie(%db);
    #
    my $error;
    my $extra_count = scalar(keys(%$my_db));
    if ($extra_count) {
        $error.=$extra_count.' extra key/value pairs found in hist: '.$/;
        while (my ($k,$v) = each(%$my_db)) {
	    $error .= '  "'.$k.'" => "'.$v.'"'.$/;
        }
    }
    my $key_count = scalar(keys(%key_errors));
    if ($key_count) {
        $error.=$key_count.' missing keys found in db but not in hist: '.$/;
        while (my ($k,$v) = each(%key_errors)) {
            $error .= '  "'.$k.'" => "'.$v.'"'.$/;
        }
    }
    my $value_count = scalar(keys(%value_errors));
    if ($value_count) {
        $error.=$value_count.' mismatched values found: '.$/;
        while (my ($k,$v) = each(%value_errors)) {
            $error .= '  "'.$k.'" => "'.$v.'"'.$/;
        }
    }
    #
    return $error;
}

sub update_hash {
    my ($db_filename,$my_db) = @_;
    if ($db_filename=~
	m/(gradingqueue|reviewqueue|slots|slot_reservations).db$/) {
	&update_grading_queue($db_filename,$my_db);
    }
}

sub update_grading_queue {
    my ($db_filename,$my_db) = @_;
    my ($name) = 
	($db_filename=~m/(gradingqueue|reviewqueue|slots|slot_reservations).db$/);
    my $type='queue';
    if ($name eq 'slots') {
	$type = 'slots';
    } elsif ($name eq 'slot_reservations') {
	$type = 'reservation';
    }
    if ($type eq 'queue') {
	foreach my $key (keys(%{$my_db})) {
	    my $real_key = &unescape($key);
	    my (@elements) = split("\0",$real_key);
	    if (exists($elements[2])) {
		$elements[2] = &update_value($elements[2]);
	    }
	    $real_key = join("\0",@elements);
	    my $new_key = &escape($real_key);
	    if ($new_key ne $key) {
		$my_db->{$new_key} = $my_db->{$key};
		delete($my_db->{$key});
	    }
	    if ($new_key =~ /locked$/) {
		my $value = $my_db->{$new_key};
		my $new_value = &unescape($value);
		$new_value = &update_value($new_value);
		$my_db->{$new_key} = &escape($new_value);
	    }
	}
    } elsif ($type eq 'slots') {
	foreach my $key (keys(%{$my_db})) {
	    my $value = $my_db->{$key};
	    $value = &Apache::lonnet::thaw_unescape($value);
	    if (exists($value->{'proctor'})) {
		$value->{'proctor'} = &update_value($value->{'proctor'});
	    }
	    if (exists($value->{'allowedusers'})) {
		$value->{'allowedusers'} = 
		    &update_value($value->{'allowedusers'});
	    }
	    $my_db->{$key} = &Apache::lonnet::freeze_escape($value);
	}
    } elsif ($type eq 'reservation') {
	foreach my $key (keys(%{$my_db})) {
	    my $value = $my_db->{$key};
	    $value = &Apache::lonnet::thaw_unescape($value);
	    if (exists($value->{'name'})) {
		$value->{'name'} = &update_value($value->{'name'});
	    }
	    $my_db->{$key} = &Apache::lonnet::freeze_escape($value);
	}
    }
}

sub update_value {
    my ($value) = @_;
    if ($value =~ /@/ && $value !~ /:/) {
	$value =~ tr/@/:/;
    }
    return $value;
}