Annotation of loncom/debugging_tools/rebuild_db_from_hist.pl, revision 1.7
1.1 matthew 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: #
1.7 ! raeburn 7: # $Id: rebuild_db_from_hist.pl,v 1.6 2006/08/03 17:53:47 albertel Exp $
1.1 matthew 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;
1.5 albertel 33: use lib '/home/httpd/lib/perl';
1.1 matthew 34: use Getopt::Long;
35: use GDBM_File;
1.5 albertel 36: use LONCAPA;
37: use Apache::lonnet;
1.1 matthew 38:
39: #
40: # Options
1.6 albertel 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);
1.1 matthew 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.
1.2 matthew 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.
1.6 albertel 61: -create_test_db
62: when testing also create a *.db.test db of the testing info
1.4 matthew 63: -p_is_s Treat 'P' lines as 'S' lines.
1.1 matthew 64: Examples:
1.2 matthew 65: rebuild_db_from_hist.pl -t $file.hist # Perform a test rebuild
66: rebuild_db_from_hist.pl $file.hist
1.1 matthew 67: END
68: exit;
69: }
70:
71: #
72: # Loop through ARGV getting files.
73: while (my $fname = shift) {
1.5 albertel 74: if ($fname !~ m/\.hist$/) {
75: print("error: $fname is not a hist file");
76: next;
77: }
78:
1.1 matthew 79: my $db_filename = $fname;
80: $db_filename =~ s/\.hist$/\.db/;
81: if (-e $db_filename && ! $test) {
1.6 albertel 82: print STDERR "Aborting: The target file $db_filename exists.".$/;
1.1 matthew 83: next;
84: }
1.3 matthew 85: my ($error,$constructed_hash) = &process_file($fname,$db_filename,$debug);
1.5 albertel 86: if (! defined($error) ) {
87: $error = &update_hash($db_filename,$constructed_hash);
88: }
1.1 matthew 89: if (! defined($error) || ! $test) {
90: $error = &write_hash($db_filename,$constructed_hash);
91: }
1.6 albertel 92: if ($test && $test_db) {
1.5 albertel 93: $error = &write_hash($db_filename.'.test',$constructed_hash);
94: }
95: if ($test) {
1.1 matthew 96: my $error = &test_hash($db_filename,$constructed_hash);
97: if (defined($error)) {
98: print "Error processing ".$fname.$/;
1.6 albertel 99: print STDERR $error;
1.1 matthew 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
1.5 albertel 124: # S:store
1.1 matthew 125: # D:delete
1.5 albertel 126: # N:new put (only adds tha values if they are all new values)
1.6 albertel 127: # M:modify the values for a previous S
1.7 ! raeburn 128: # U:update the values (action could be add or del).
1.1 matthew 129: my ($action,$time,$concatenated_data) = split(':',$command,3);
1.3 matthew 130: if ($fname eq 'roles.hist' && $concatenated_data =~ /^.*:.*:/) {
131: (undef,undef,$concatenated_data) = split(':',$concatenated_data,3);
132: }
1.4 matthew 133: next if (! defined($action));
134: if ($action eq 'P' && $p_is_s) { $action = 'S'; }
1.7 ! raeburn 135: my ($rid,@allkeys,$version,$updatetype);
1.4 matthew 136: if ($action eq 'S') {
137: ($rid,$concatenated_data) = split(':',$concatenated_data,2);
138: $version = ++$db_to_store{"version:$rid"};
1.5 albertel 139: #print $version.$/;
1.4 matthew 140: }
1.6 albertel 141: if ($action eq 'M') {
142: ($rid,$version,$concatenated_data) =
143: split(':',$concatenated_data,3);
144: }
1.7 ! raeburn 145: if ($action eq 'U') {
! 146: ($updatetype,$concatenated_data) =
! 147: split(':',$concatenated_data,2);
! 148: }
1.4 matthew 149: next if (! defined($concatenated_data));
1.5 albertel 150: my $add_new_data = 1;
1.1 matthew 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: }
1.6 albertel 160: } elsif ($action eq 'S' || $action eq 'M') {
1.4 matthew 161: # Versioning of data, so we update the old ata
1.6 albertel 162: push(@allkeys,$key);
1.4 matthew 163: $db_to_store{"$version:$rid:$key"}=$value;
1.5 albertel 164: } elsif ($action eq 'N') {
165: if (exists($db_to_store{$key})) {
166: $add_new_data = 0;
167: print "exists $key\n";
168: }
1.1 matthew 169: } elsif ($action eq 'D') {
170: delete($db_to_store{$key});
1.7 ! raeburn 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: }
1.1 matthew 193: } else {
194: $error = "Unable to understand action '".$action."'";
195: }
196: }
1.6 albertel 197:
1.5 albertel 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: }
1.6 albertel 204: if ($action eq 'S') {
1.4 matthew 205: $db_to_store{"$version:$rid:timestamp"}=$time;
1.6 albertel 206: push(@allkeys,'timestamp');
207: }
208: if ($action eq 'S' || $action eq 'M') {
209: $db_to_store{"$version:keys:$rid"}=join(':',@allkeys);
1.4 matthew 210: }
1.1 matthew 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) {
1.4 matthew 264: $error.=$extra_count.' extra key/value pairs found in hist: '.$/;
1.1 matthew 265: while (my ($k,$v) = each(%$my_db)) {
1.5 albertel 266: $error .= ' "'.$k.'" => "'.$v.'"'.$/;
1.1 matthew 267: }
268: }
269: my $key_count = scalar(keys(%key_errors));
270: if ($key_count) {
1.4 matthew 271: $error.=$key_count.' missing keys found in db but not in hist: '.$/;
1.1 matthew 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) {
1.4 matthew 278: $error.=$value_count.' mismatched values found: '.$/;
1.1 matthew 279: while (my ($k,$v) = each(%value_errors)) {
280: $error .= ' "'.$k.'" => "'.$v.'"'.$/;
281: }
282: }
283: #
284: return $error;
285: }
1.5 albertel 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: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to rebuild_db_from_hist.pl CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / debugging_tools