loncom/debugging_tools/rebuild_db_from_hist.pl - view

File: [LON-CAPA] / loncom / debugging_tools / rebuild_db_from_hist.pl
Revision 1.6: download - view: text, annotated - select for diffs
Thu Aug 3 17:53:47 2006 UTC (17 years, 8 months ago) by albertel
Branches: MAIN
CVS tags: version_2_9_X, version_2_9_99_0, version_2_9_1, version_2_9_0, version_2_8_X, version_2_8_99_1, version_2_8_99_0, version_2_8_2, version_2_8_1, version_2_8_0, version_2_7_X, version_2_7_99_1, version_2_7_99_0, version_2_7_1, version_2_7_0, version_2_6_X, version_2_6_99_1, version_2_6_99_0, version_2_6_3, version_2_6_2, version_2_6_1, version_2_6_0, version_2_5_X, version_2_5_99_1, version_2_5_99_0, version_2_5_2, version_2_5_1, version_2_5_0, version_2_4_X, version_2_4_99_0, version_2_4_2, version_2_4_1, version_2_4_0, version_2_3_X, version_2_3_99_0, version_2_3_2, version_2_3_1, version_2_3_0, version_2_2_X, version_2_2_99_1, version_2_2_99_0, version_2_2_2, version_2_2_1, version_2_2_0, version_2_1_99_3, version_2_11_X, version_2_11_4_uiuc, version_2_11_4_msu, version_2_11_4, version_2_11_3_uiuc, version_2_11_3_msu, version_2_11_3, version_2_11_2_uiuc, version_2_11_2_msu, version_2_11_2_educog, version_2_11_2, version_2_11_1, version_2_11_0_RC3, version_2_11_0_RC2, version_2_11_0_RC1, version_2_11_0, version_2_10_X, version_2_10_1, version_2_10_0_RC2, version_2_10_0_RC1, version_2_10_0, loncapaMITrelate_1, language_hyphenation_merge, language_hyphenation, bz6209-base, bz6209, bz5969, bz2851, PRINT_INCOMPLETE_base, PRINT_INCOMPLETE, HEAD, GCI_3, GCI_2, GCI_1, BZ5971-printing-apage, BZ5434-fox, BZ4492-merge, BZ4492-feature_horizontal_radioresponse, BZ4492-feature_Support_horizontal_radioresponse, BZ4492-Support_horizontal_radioresponse

- teaching it about the 'M' command from lond's putstore
- making the test db creation an option

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.6 2006/08/03 17:53:47 albertel 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: my ($action,$time,$concatenated_data) = split(':',$command,3); 129: if ($fname eq 'roles.hist' && $concatenated_data =~ /^.*:.*:/) { 130: (undef,undef,$concatenated_data) = split(':',$concatenated_data,3); 131: } 132: next if (! defined($action)); 133: if ($action eq 'P' && $p_is_s) { $action = 'S'; } 134: my ($rid,@allkeys,$version); 135: if ($action eq 'S') { 136: ($rid,$concatenated_data) = split(':',$concatenated_data,2); 137: $version = ++$db_to_store{"version:$rid"}; 138: #print $version.$/; 139: } 140: if ($action eq 'M') { 141: ($rid,$version,$concatenated_data) = 142: split(':',$concatenated_data,3); 143: } 144: next if (! defined($concatenated_data)); 145: my $add_new_data = 1; 146: my @data = split('&',$concatenated_data); 147: foreach my $k_v_pair (@data) { 148: my ($key,$value) = split('=',$k_v_pair,2); 149: if (defined($action) && $action eq 'P') { 150: if (defined($value)) { 151: $db_to_store{$key}=$value; 152: } else { 153: $no_action_count++; 154: } 155: } elsif ($action eq 'S' || $action eq 'M') { 156: # Versioning of data, so we update the old ata 157: push(@allkeys,$key); 158: $db_to_store{"$version:$rid:$key"}=$value; 159: } elsif ($action eq 'N') { 160: if (exists($db_to_store{$key})) { 161: $add_new_data = 0; 162: print "exists $key\n"; 163: } 164: } elsif ($action eq 'D') { 165: delete($db_to_store{$key}); 166: } else { 167: $error = "Unable to understand action '".$action."'"; 168: } 169: } 170: 171: if ($action eq 'N' && $add_new_data) { 172: foreach my $k_v_pair (@data) { 173: my ($key,$value) = split('=',$k_v_pair,2); 174: $db_to_store{$key}=$value; 175: } 176: } 177: if ($action eq 'S') { 178: $db_to_store{"$version:$rid:timestamp"}=$time; 179: push(@allkeys,'timestamp'); 180: } 181: if ($action eq 'S' || $action eq 'M') { 182: $db_to_store{"$version:keys:$rid"}=join(':',@allkeys); 183: } 184: if (defined($error)) { 185: return ('Error:'.$error.$/,undef); 186: } 187: } 188: if ($no_action_count) { 189: print $no_action_count.' lines did not require action.'.$/; 190: } 191: close(HISTFILE); 192: return (undef,\%db_to_store); 193: } 194: 195: sub write_hash { 196: my ($db_filename,$db_to_store) = @_; 197: # 198: # Write the gdbm file 199: my %db; 200: if (! tie(%db,'GDBM_File',$db_filename,&GDBM_WRCREAT(),0640)) { 201: warn "Unable to tie to $db_filename"; 202: return "Unable to tie to $db_filename"; 203: } 204: # 205: while (my ($k,$v) = each(%$db_to_store)) { 206: $db{$k}=$v; 207: } 208: # 209: untie(%db); 210: return undef; 211: } 212: 213: sub test_hash { 214: my ($db_filename,$my_db) = @_; 215: # 216: my %db; 217: if (! tie(%db,'GDBM_File',$db_filename,&GDBM_READER(),0640)) { 218: return "Unable to tie to $db_filename";; 219: } 220: my (%key_errors,%value_errors); 221: while (my ($k,$v) = each(%db)) { 222: if (exists($my_db->{$k})) { 223: if ($my_db->{$k} eq $v) { 224: delete($my_db->{$k}); 225: } else { 226: $value_errors{$k}=$v; 227: } 228: } else { 229: $key_errors{$k}=$v; 230: } 231: } 232: untie(%db); 233: # 234: my $error; 235: my $extra_count = scalar(keys(%$my_db)); 236: if ($extra_count) { 237: $error.=$extra_count.' extra key/value pairs found in hist: '.$/; 238: while (my ($k,$v) = each(%$my_db)) { 239: $error .= ' "'.$k.'" => "'.$v.'"'.$/; 240: } 241: } 242: my $key_count = scalar(keys(%key_errors)); 243: if ($key_count) { 244: $error.=$key_count.' missing keys found in db but not in hist: '.$/; 245: while (my ($k,$v) = each(%key_errors)) { 246: $error .= ' "'.$k.'" => "'.$v.'"'.$/; 247: } 248: } 249: my $value_count = scalar(keys(%value_errors)); 250: if ($value_count) { 251: $error.=$value_count.' mismatched values found: '.$/; 252: while (my ($k,$v) = each(%value_errors)) { 253: $error .= ' "'.$k.'" => "'.$v.'"'.$/; 254: } 255: } 256: # 257: return $error; 258: } 259: 260: sub update_hash { 261: my ($db_filename,$my_db) = @_; 262: if ($db_filename=~ 263: m/(gradingqueue|reviewqueue|slots|slot_reservations).db$/) { 264: &update_grading_queue($db_filename,$my_db); 265: } 266: } 267: 268: sub update_grading_queue { 269: my ($db_filename,$my_db) = @_; 270: my ($name) = 271: ($db_filename=~m/(gradingqueue|reviewqueue|slots|slot_reservations).db$/); 272: my $type='queue'; 273: if ($name eq 'slots') { 274: $type = 'slots'; 275: } elsif ($name eq 'slot_reservations') { 276: $type = 'reservation'; 277: } 278: if ($type eq 'queue') { 279: foreach my $key (keys(%{$my_db})) { 280: my $real_key = &unescape($key); 281: my (@elements) = split("\0",$real_key); 282: if (exists($elements[2])) { 283: $elements[2] = &update_value($elements[2]); 284: } 285: $real_key = join("\0",@elements); 286: my $new_key = &escape($real_key); 287: if ($new_key ne $key) { 288: $my_db->{$new_key} = $my_db->{$key}; 289: delete($my_db->{$key}); 290: } 291: if ($new_key =~ /locked$/) { 292: my $value = $my_db->{$new_key}; 293: my $new_value = &unescape($value); 294: $new_value = &update_value($new_value); 295: $my_db->{$new_key} = &escape($new_value); 296: } 297: } 298: } elsif ($type eq 'slots') { 299: foreach my $key (keys(%{$my_db})) { 300: my $value = $my_db->{$key}; 301: $value = &Apache::lonnet::thaw_unescape($value); 302: if (exists($value->{'proctor'})) { 303: $value->{'proctor'} = &update_value($value->{'proctor'}); 304: } 305: if (exists($value->{'allowedusers'})) { 306: $value->{'allowedusers'} = 307: &update_value($value->{'allowedusers'}); 308: } 309: $my_db->{$key} = &Apache::lonnet::freeze_escape($value); 310: } 311: } elsif ($type eq 'reservation') { 312: foreach my $key (keys(%{$my_db})) { 313: my $value = $my_db->{$key}; 314: $value = &Apache::lonnet::thaw_unescape($value); 315: if (exists($value->{'name'})) { 316: $value->{'name'} = &update_value($value->{'name'}); 317: } 318: $my_db->{$key} = &Apache::lonnet::freeze_escape($value); 319: } 320: } 321: } 322: 323: sub update_value { 324: my ($value) = @_; 325: if ($value =~ /@/ && $value !~ /:/) { 326: $value =~ tr/@/:/; 327: } 328: return $value; 329: }