loncom/debugging_tools/rebuild_db_from_hist.pl - view

File: [LON-CAPA] / loncom / debugging_tools / rebuild_db_from_hist.pl
Revision 1.7: download - view: text, annotated - select for diffs
Sun Jan 31 21:26:01 2016 UTC (8 years, 3 months ago) by raeburn
Branches: MAIN
CVS tags: version_2_12_X, HEAD

- 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.

1: #!/usr/bin/perl -w 2: # 3: # The LearningOnline Network 4: # 5: # rebuild_db_from_hist.pl Rebuild a *.db file from a *.hist file 6: # 7: # $Id: rebuild_db_from_hist.pl,v 1.7 2016/01/31 21:26:01 raeburn Exp $ 8: # 9: # Copyright Michigan State University Board of Trustees 10: # 11: # This file is part of the LearningOnline Network with CAPA (LON-CAPA). 12: # 13: # LON-CAPA is free software; you can redistribute it and/or modify 14: # it under the terms of the GNU General Public License as published by 15: # the Free Software Foundation; either version 2 of the License, or 16: # (at your option) any later version. 17: # 18: # LON-CAPA is distributed in the hope that it will be useful, 19: # but WITHOUT ANY WARRANTY; without even the implied warranty of 20: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 21: # GNU General Public License for more details. 22: # 23: # You should have received a copy of the GNU General Public License 24: # along with LON-CAPA; if not, write to the Free Software 25: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 26: # 27: # /home/httpd/html/adm/gpl.txt 28: # 29: # http://www.lon-capa.org/ 30: # 31: ################################################# 32: use strict; 33: use lib '/home/httpd/lib/perl'; 34: use Getopt::Long; 35: use GDBM_File; 36: use LONCAPA; 37: use Apache::lonnet; 38: 39: # 40: # Options 41: my ($help,$debug,$test,$test_db,$p_is_s); 42: GetOptions("help" => \$help, 43: "debug" => \$debug, 44: "test" => \$test, 45: "create_test_db" => \$test_db, 46: "p_is_s" => \$p_is_s); 47: 48: if (! defined($debug)) { $debug = 0; } 49: if (! defined($test)) { $test = 0; } 50: 51: # 52: # Help them out if they ask for it 53: if ($help) { 54: print <<'END'; 55: rebuild_db_from_hist.pl - recreate a db file from a hist file. 56: Options: 57: -help Display this help. 58: -debug Output debugging code (not much is output yet) 59: -test Verify the given *.hist file will reconstruct the current db file 60: Sends error messages to STDERR. 61: -create_test_db 62: when testing also create a *.db.test db of the testing info 63: -p_is_s Treat 'P' lines as 'S' lines. 64: Examples: 65: rebuild_db_from_hist.pl -t $file.hist # Perform a test rebuild 66: rebuild_db_from_hist.pl $file.hist 67: END 68: exit; 69: } 70: 71: # 72: # Loop through ARGV getting files. 73: while (my $fname = shift) { 74: if ($fname !~ m/\.hist$/) { 75: print("error: $fname is not a hist file"); 76: next; 77: } 78: 79: my $db_filename = $fname; 80: $db_filename =~ s/\.hist$/\.db/; 81: if (-e $db_filename && ! $test) { 82: print STDERR "Aborting: The target file $db_filename exists.".$/; 83: next; 84: } 85: my ($error,$constructed_hash) = &process_file($fname,$db_filename,$debug); 86: if (! defined($error) ) { 87: $error = &update_hash($db_filename,$constructed_hash); 88: } 89: if (! defined($error) || ! $test) { 90: $error = &write_hash($db_filename,$constructed_hash); 91: } 92: if ($test && $test_db) { 93: $error = &write_hash($db_filename.'.test',$constructed_hash); 94: } 95: if ($test) { 96: my $error = &test_hash($db_filename,$constructed_hash); 97: if (defined($error)) { 98: print "Error processing ".$fname.$/; 99: print STDERR $error; 100: } else { 101: print "Everything looks good for ".$fname.$/; 102: } 103: } 104: if (defined($error)) { 105: print $error.$/; 106: } 107: } 108: 109: exit; 110: 111: ###################################################### 112: ###################################################### 113: sub process_file { 114: my ($fname,$db_filename,$debug) = @_; 115: # 116: open(HISTFILE,$fname); 117: my %db_to_store; 118: my $no_action_count = 0; 119: while (my $command = <HISTFILE>) { 120: chomp($command); 121: my $error = undef; 122: # Each line can begin with: 123: # P:put 124: # S:store 125: # D:delete 126: # N:new put (only adds tha values if they are all new values) 127: # M:modify the values for a previous S 128: # U:update the values (action could be add or del). 129: my ($action,$time,$concatenated_data) = split(':',$command,3); 130: if ($fname eq 'roles.hist' && $concatenated_data =~ /^.*:.*:/) { 131: (undef,undef,$concatenated_data) = split(':',$concatenated_data,3); 132: } 133: next if (! defined($action)); 134: if ($action eq 'P' && $p_is_s) { $action = 'S'; } 135: my ($rid,@allkeys,$version,$updatetype); 136: if ($action eq 'S') { 137: ($rid,$concatenated_data) = split(':',$concatenated_data,2); 138: $version = ++$db_to_store{"version:$rid"}; 139: #print $version.$/; 140: } 141: if ($action eq 'M') { 142: ($rid,$version,$concatenated_data) = 143: split(':',$concatenated_data,3); 144: } 145: if ($action eq 'U') { 146: ($updatetype,$concatenated_data) = 147: split(':',$concatenated_data,2); 148: } 149: next if (! defined($concatenated_data)); 150: my $add_new_data = 1; 151: my @data = split('&',$concatenated_data); 152: foreach my $k_v_pair (@data) { 153: my ($key,$value) = split('=',$k_v_pair,2); 154: if (defined($action) && $action eq 'P') { 155: if (defined($value)) { 156: $db_to_store{$key}=$value; 157: } else { 158: $no_action_count++; 159: } 160: } elsif ($action eq 'S' || $action eq 'M') { 161: # Versioning of data, so we update the old ata 162: push(@allkeys,$key); 163: $db_to_store{"$version:$rid:$key"}=$value; 164: } elsif ($action eq 'N') { 165: if (exists($db_to_store{$key})) { 166: $add_new_data = 0; 167: print "exists $key\n"; 168: } 169: } elsif ($action eq 'D') { 170: delete($db_to_store{$key}); 171: } elsif ($action eq 'U') { 172: if ($updatetype eq 'del') { 173: if (exists($db_to_store{$key})) { 174: my %current; 175: map { $current{$_} = 1; } split(/,/,&unescape($db_to_store{$key})); 176: map { delete($current{$_}); } split(/,/,&unescape($value)); 177: if (keys(%current)) { 178: $db_to_store{$key}=&escape(join(',',sort(keys(%current)))); 179: } else { 180: delete($db_to_store{$key}); 181: } 182: } 183: } elsif ($updatetype eq 'add') { 184: if (exists($db_to_store{$key})) { 185: my @newvals = split(/,/,&unescape($value)); 186: my @currvals = split(/,/,&unescape($db_to_store{$key})); 187: my @merged = sort(keys(%{{map { $_ => 1 } (@newvals,@currvals)}})); 188: $db_to_store{$key}=&escape(join(',',@merged)); 189: } else { 190: $db_to_store{$key}=$value; 191: } 192: } 193: } else { 194: $error = "Unable to understand action '".$action."'"; 195: } 196: } 197: 198: if ($action eq 'N' && $add_new_data) { 199: foreach my $k_v_pair (@data) { 200: my ($key,$value) = split('=',$k_v_pair,2); 201: $db_to_store{$key}=$value; 202: } 203: } 204: if ($action eq 'S') { 205: $db_to_store{"$version:$rid:timestamp"}=$time; 206: push(@allkeys,'timestamp'); 207: } 208: if ($action eq 'S' || $action eq 'M') { 209: $db_to_store{"$version:keys:$rid"}=join(':',@allkeys); 210: } 211: if (defined($error)) { 212: return ('Error:'.$error.$/,undef); 213: } 214: } 215: if ($no_action_count) { 216: print $no_action_count.' lines did not require action.'.$/; 217: } 218: close(HISTFILE); 219: return (undef,\%db_to_store); 220: } 221: 222: sub write_hash { 223: my ($db_filename,$db_to_store) = @_; 224: # 225: # Write the gdbm file 226: my %db; 227: if (! tie(%db,'GDBM_File',$db_filename,&GDBM_WRCREAT(),0640)) { 228: warn "Unable to tie to $db_filename"; 229: return "Unable to tie to $db_filename"; 230: } 231: # 232: while (my ($k,$v) = each(%$db_to_store)) { 233: $db{$k}=$v; 234: } 235: # 236: untie(%db); 237: return undef; 238: } 239: 240: sub test_hash { 241: my ($db_filename,$my_db) = @_; 242: # 243: my %db; 244: if (! tie(%db,'GDBM_File',$db_filename,&GDBM_READER(),0640)) { 245: return "Unable to tie to $db_filename";; 246: } 247: my (%key_errors,%value_errors); 248: while (my ($k,$v) = each(%db)) { 249: if (exists($my_db->{$k})) { 250: if ($my_db->{$k} eq $v) { 251: delete($my_db->{$k}); 252: } else { 253: $value_errors{$k}=$v; 254: } 255: } else { 256: $key_errors{$k}=$v; 257: } 258: } 259: untie(%db); 260: # 261: my $error; 262: my $extra_count = scalar(keys(%$my_db)); 263: if ($extra_count) { 264: $error.=$extra_count.' extra key/value pairs found in hist: '.$/; 265: while (my ($k,$v) = each(%$my_db)) { 266: $error .= ' "'.$k.'" => "'.$v.'"'.$/; 267: } 268: } 269: my $key_count = scalar(keys(%key_errors)); 270: if ($key_count) { 271: $error.=$key_count.' missing keys found in db but not in hist: '.$/; 272: while (my ($k,$v) = each(%key_errors)) { 273: $error .= ' "'.$k.'" => "'.$v.'"'.$/; 274: } 275: } 276: my $value_count = scalar(keys(%value_errors)); 277: if ($value_count) { 278: $error.=$value_count.' mismatched values found: '.$/; 279: while (my ($k,$v) = each(%value_errors)) { 280: $error .= ' "'.$k.'" => "'.$v.'"'.$/; 281: } 282: } 283: # 284: return $error; 285: } 286: 287: sub update_hash { 288: my ($db_filename,$my_db) = @_; 289: if ($db_filename=~ 290: m/(gradingqueue|reviewqueue|slots|slot_reservations).db$/) { 291: &update_grading_queue($db_filename,$my_db); 292: } 293: } 294: 295: sub update_grading_queue { 296: my ($db_filename,$my_db) = @_; 297: my ($name) = 298: ($db_filename=~m/(gradingqueue|reviewqueue|slots|slot_reservations).db$/); 299: my $type='queue'; 300: if ($name eq 'slots') { 301: $type = 'slots'; 302: } elsif ($name eq 'slot_reservations') { 303: $type = 'reservation'; 304: } 305: if ($type eq 'queue') { 306: foreach my $key (keys(%{$my_db})) { 307: my $real_key = &unescape($key); 308: my (@elements) = split("\0",$real_key); 309: if (exists($elements[2])) { 310: $elements[2] = &update_value($elements[2]); 311: } 312: $real_key = join("\0",@elements); 313: my $new_key = &escape($real_key); 314: if ($new_key ne $key) { 315: $my_db->{$new_key} = $my_db->{$key}; 316: delete($my_db->{$key}); 317: } 318: if ($new_key =~ /locked$/) { 319: my $value = $my_db->{$new_key}; 320: my $new_value = &unescape($value); 321: $new_value = &update_value($new_value); 322: $my_db->{$new_key} = &escape($new_value); 323: } 324: } 325: } elsif ($type eq 'slots') { 326: foreach my $key (keys(%{$my_db})) { 327: my $value = $my_db->{$key}; 328: $value = &Apache::lonnet::thaw_unescape($value); 329: if (exists($value->{'proctor'})) { 330: $value->{'proctor'} = &update_value($value->{'proctor'}); 331: } 332: if (exists($value->{'allowedusers'})) { 333: $value->{'allowedusers'} = 334: &update_value($value->{'allowedusers'}); 335: } 336: $my_db->{$key} = &Apache::lonnet::freeze_escape($value); 337: } 338: } elsif ($type eq 'reservation') { 339: foreach my $key (keys(%{$my_db})) { 340: my $value = $my_db->{$key}; 341: $value = &Apache::lonnet::thaw_unescape($value); 342: if (exists($value->{'name'})) { 343: $value->{'name'} = &update_value($value->{'name'}); 344: } 345: $my_db->{$key} = &Apache::lonnet::freeze_escape($value); 346: } 347: } 348: } 349: 350: sub update_value { 351: my ($value) = @_; 352: if ($value =~ /@/ && $value !~ /:/) { 353: $value =~ tr/@/:/; 354: } 355: return $value; 356: }