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 (18 years 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_5_msu,
version_2_11_5,
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: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>