Annotation of loncom/debugging_tools/rebuild_db_from_hist.pl, revision 1.5
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.5 ! albertel 7: # $Id: rebuild_db_from_hist.pl,v 1.4 2004/12/09 22:25:47 matthew 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.4 matthew 41: my ($help,$debug,$test,$p_is_s);
1.1 matthew 42: GetOptions("help" => \$help,
43: "debug" => \$debug,
1.4 matthew 44: "test" => \$test,
45: "p_is_s" => \$p_is_s);
1.1 matthew 46:
47: if (! defined($debug)) { $debug = 0; }
48: if (! defined($test)) { $test = 0; }
49:
50: #
51: # Help them out if they ask for it
52: if ($help) {
53: print <<'END';
54: rebuild_db_from_hist.pl - recreate a db file from a hist file.
55: Options:
56: -help Display this help.
1.2 matthew 57: -debug Output debugging code (not much is output yet)
58: -test Verify the given *.hist file will reconstruct the current db file
59: Sends error messages to STDERR.
1.4 matthew 60: -p_is_s Treat 'P' lines as 'S' lines.
1.1 matthew 61: Examples:
1.2 matthew 62: rebuild_db_from_hist.pl -t $file.hist # Perform a test rebuild
63: rebuild_db_from_hist.pl $file.hist
1.1 matthew 64: END
65: exit;
66: }
67:
68: #
69: # Loop through ARGV getting files.
70: while (my $fname = shift) {
1.5 ! albertel 71: if ($fname !~ m/\.hist$/) {
! 72: print("error: $fname is not a hist file");
! 73: next;
! 74: }
! 75:
1.1 matthew 76: my $db_filename = $fname;
77: $db_filename =~ s/\.hist$/\.db/;
78: if (-e $db_filename && ! $test) {
1.5 ! albertel 79: print "Aborting: The target file $db_filename exists.".$/;
1.1 matthew 80: next;
81: }
1.3 matthew 82: my ($error,$constructed_hash) = &process_file($fname,$db_filename,$debug);
1.5 ! albertel 83: if (! defined($error) ) {
! 84: $error = &update_hash($db_filename,$constructed_hash);
! 85: }
1.1 matthew 86: if (! defined($error) || ! $test) {
87: $error = &write_hash($db_filename,$constructed_hash);
88: }
89: if ($test) {
1.5 ! albertel 90: $error = &write_hash($db_filename.'.test',$constructed_hash);
! 91: }
! 92: if ($test) {
1.1 matthew 93: my $error = &test_hash($db_filename,$constructed_hash);
94: if (defined($error)) {
95: print "Error processing ".$fname.$/;
1.5 ! albertel 96: print $error;
1.1 matthew 97: } else {
98: print "Everything looks good for ".$fname.$/;
99: }
100: }
101: if (defined($error)) {
102: print $error.$/;
103: }
104: }
105:
106: exit;
107:
108: ######################################################
109: ######################################################
110: sub process_file {
111: my ($fname,$db_filename,$debug) = @_;
112: #
113: open(HISTFILE,$fname);
114: my %db_to_store;
115: my $no_action_count = 0;
116: while (my $command = <HISTFILE>) {
117: chomp($command);
118: my $error = undef;
119: # Each line can begin with:
120: # P:put
1.5 ! albertel 121: # S:store
1.1 matthew 122: # D:delete
1.5 ! albertel 123: # N:new put (only adds tha values if they are all new values)
1.1 matthew 124: my ($action,$time,$concatenated_data) = split(':',$command,3);
1.3 matthew 125: if ($fname eq 'roles.hist' && $concatenated_data =~ /^.*:.*:/) {
126: (undef,undef,$concatenated_data) = split(':',$concatenated_data,3);
127: }
1.4 matthew 128: next if (! defined($action));
129: if ($action eq 'P' && $p_is_s) { $action = 'S'; }
130: my ($rid,$allkeys,$version);
131: if ($action eq 'S') {
132: ($rid,$concatenated_data) = split(':',$concatenated_data,2);
133: $version = ++$db_to_store{"version:$rid"};
1.5 ! albertel 134: #print $version.$/;
1.4 matthew 135: }
136: next if (! defined($concatenated_data));
1.5 ! albertel 137: my $add_new_data = 1;
1.1 matthew 138: my @data = split('&',$concatenated_data);
139: foreach my $k_v_pair (@data) {
140: my ($key,$value) = split('=',$k_v_pair,2);
141: if (defined($action) && $action eq 'P') {
142: if (defined($value)) {
143: $db_to_store{$key}=$value;
144: } else {
145: $no_action_count++;
146: }
1.4 matthew 147: } elsif ($action eq 'S') {
148: # Versioning of data, so we update the old ata
149: $allkeys.=$key.':';
150: $db_to_store{"$version:$rid:$key"}=$value;
1.5 ! albertel 151: } elsif ($action eq 'N') {
! 152: if (exists($db_to_store{$key})) {
! 153: $add_new_data = 0;
! 154: print "exists $key\n";
! 155: }
1.1 matthew 156: } elsif ($action eq 'D') {
157: delete($db_to_store{$key});
158: } else {
159: $error = "Unable to understand action '".$action."'";
160: }
161: }
1.5 ! albertel 162: if ($action eq 'N' && $add_new_data) {
! 163: foreach my $k_v_pair (@data) {
! 164: my ($key,$value) = split('=',$k_v_pair,2);
! 165: $db_to_store{$key}=$value;
! 166: }
! 167: }
1.4 matthew 168: if ($action eq 'S') {
169: $db_to_store{"$version:$rid:timestamp"}=$time;
170: $allkeys.='timestamp';
171: $db_to_store{"$version:keys:$rid"}=$allkeys;
172: }
1.1 matthew 173: if (defined($error)) {
174: return ('Error:'.$error.$/,undef);
175: }
176: }
177: if ($no_action_count) {
178: print $no_action_count.' lines did not require action.'.$/;
179: }
180: close(HISTFILE);
181: return (undef,\%db_to_store);
182: }
183:
184: sub write_hash {
185: my ($db_filename,$db_to_store) = @_;
186: #
187: # Write the gdbm file
188: my %db;
189: if (! tie(%db,'GDBM_File',$db_filename,&GDBM_WRCREAT(),0640)) {
190: warn "Unable to tie to $db_filename";
191: return "Unable to tie to $db_filename";
192: }
193: #
194: while (my ($k,$v) = each(%$db_to_store)) {
195: $db{$k}=$v;
196: }
197: #
198: untie(%db);
199: return undef;
200: }
201:
202: sub test_hash {
203: my ($db_filename,$my_db) = @_;
204: #
205: my %db;
206: if (! tie(%db,'GDBM_File',$db_filename,&GDBM_READER(),0640)) {
207: return "Unable to tie to $db_filename";;
208: }
209: my (%key_errors,%value_errors);
210: while (my ($k,$v) = each(%db)) {
211: if (exists($my_db->{$k})) {
212: if ($my_db->{$k} eq $v) {
213: delete($my_db->{$k});
214: } else {
215: $value_errors{$k}=$v;
216: }
217: } else {
218: $key_errors{$k}=$v;
219: }
220: }
221: untie(%db);
222: #
223: my $error;
224: my $extra_count = scalar(keys(%$my_db));
225: if ($extra_count) {
1.4 matthew 226: $error.=$extra_count.' extra key/value pairs found in hist: '.$/;
1.1 matthew 227: while (my ($k,$v) = each(%$my_db)) {
1.5 ! albertel 228: $error .= ' "'.$k.'" => "'.$v.'"'.$/;
1.1 matthew 229: }
230: }
231: my $key_count = scalar(keys(%key_errors));
232: if ($key_count) {
1.4 matthew 233: $error.=$key_count.' missing keys found in db but not in hist: '.$/;
1.1 matthew 234: while (my ($k,$v) = each(%key_errors)) {
235: $error .= ' "'.$k.'" => "'.$v.'"'.$/;
236: }
237: }
238: my $value_count = scalar(keys(%value_errors));
239: if ($value_count) {
1.4 matthew 240: $error.=$value_count.' mismatched values found: '.$/;
1.1 matthew 241: while (my ($k,$v) = each(%value_errors)) {
242: $error .= ' "'.$k.'" => "'.$v.'"'.$/;
243: }
244: }
245: #
246: return $error;
247: }
1.5 ! albertel 248:
! 249: sub update_hash {
! 250: my ($db_filename,$my_db) = @_;
! 251: if ($db_filename=~
! 252: m/(gradingqueue|reviewqueue|slots|slot_reservations).db$/) {
! 253: &update_grading_queue($db_filename,$my_db);
! 254: }
! 255: }
! 256:
! 257: sub update_grading_queue {
! 258: my ($db_filename,$my_db) = @_;
! 259: my ($name) =
! 260: ($db_filename=~m/(gradingqueue|reviewqueue|slots|slot_reservations).db$/);
! 261: my $type='queue';
! 262: if ($name eq 'slots') {
! 263: $type = 'slots';
! 264: } elsif ($name eq 'slot_reservations') {
! 265: $type = 'reservation';
! 266: }
! 267: if ($type eq 'queue') {
! 268: foreach my $key (keys(%{$my_db})) {
! 269: my $real_key = &unescape($key);
! 270: my (@elements) = split("\0",$real_key);
! 271: if (exists($elements[2])) {
! 272: $elements[2] = &update_value($elements[2]);
! 273: }
! 274: $real_key = join("\0",@elements);
! 275: my $new_key = &escape($real_key);
! 276: if ($new_key ne $key) {
! 277: $my_db->{$new_key} = $my_db->{$key};
! 278: delete($my_db->{$key});
! 279: }
! 280: if ($new_key =~ /locked$/) {
! 281: my $value = $my_db->{$new_key};
! 282: my $new_value = &unescape($value);
! 283: $new_value = &update_value($new_value);
! 284: $my_db->{$new_key} = &escape($new_value);
! 285: }
! 286: }
! 287: } elsif ($type eq 'slots') {
! 288: foreach my $key (keys(%{$my_db})) {
! 289: my $value = $my_db->{$key};
! 290: $value = &Apache::lonnet::thaw_unescape($value);
! 291: if (exists($value->{'proctor'})) {
! 292: $value->{'proctor'} = &update_value($value->{'proctor'});
! 293: }
! 294: if (exists($value->{'allowedusers'})) {
! 295: $value->{'allowedusers'} =
! 296: &update_value($value->{'allowedusers'});
! 297: }
! 298: $my_db->{$key} = &Apache::lonnet::freeze_escape($value);
! 299: }
! 300: } elsif ($type eq 'reservation') {
! 301: foreach my $key (keys(%{$my_db})) {
! 302: my $value = $my_db->{$key};
! 303: $value = &Apache::lonnet::thaw_unescape($value);
! 304: if (exists($value->{'name'})) {
! 305: $value->{'name'} = &update_value($value->{'name'});
! 306: }
! 307: $my_db->{$key} = &Apache::lonnet::freeze_escape($value);
! 308: }
! 309: }
! 310: }
! 311:
! 312: sub update_value {
! 313: my ($value) = @_;
! 314: if ($value =~ /@/ && $value !~ /:/) {
! 315: $value =~ tr/@/:/;
! 316: }
! 317: return $value;
! 318: }
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