Return to rebuild_db_from_hist.pl CVS log

Up to [LON-CAPA] / loncom / debugging_tools

Added handling of 'S' storage.
Made error messages a little more specific.

    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.4 2004/12/09 22:25:47 matthew 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 Getopt::Long;
   34: use GDBM_File;
   35: 
   36: #
   37: # Options
   38: my ($help,$debug,$test,$p_is_s);
   39: GetOptions("help"    => \$help,
   40:            "debug"   => \$debug,
   41:            "test"    => \$test,
   42:            "p_is_s"  => \$p_is_s);
   43: 
   44: if (! defined($debug))   { $debug   = 0; }
   45: if (! defined($test))    { $test    = 0; }
   46: 
   47: #
   48: # Help them out if they ask for it
   49: if ($help) {
   50:     print <<'END';
   51: rebuild_db_from_hist.pl - recreate a db file from a hist file.
   52: Options:
   53:    -help     Display this help.
   54:    -debug    Output debugging code (not much is output yet)
   55:    -test     Verify the given *.hist file will reconstruct the current db file
   56:              Sends error messages to STDERR.
   57:    -p_is_s   Treat 'P' lines as 'S' lines.
   58: Examples: 
   59:     rebuild_db_from_hist.pl -t $file.hist  # Perform a test rebuild
   60:     rebuild_db_from_hist.pl $file.hist       
   61: END
   62:     exit;
   63: }
   64: 
   65: #
   66: # Loop through ARGV getting files.
   67: while (my $fname = shift) {
   68:     my $db_filename = $fname;
   69:     $db_filename =~ s/\.hist$/\.db/;
   70:     if (-e $db_filename && ! $test) {
   71:         print STDERR "Aborting: The target file $db_filename exists.".$/;
   72:         next;
   73:     }
   74:     my ($error,$constructed_hash) = &process_file($fname,$db_filename,$debug);
   75:     if (! defined($error) || ! $test) {
   76:         $error = &write_hash($db_filename,$constructed_hash);
   77:     }
   78:     if ($test) {
   79:         my $error = &test_hash($db_filename,$constructed_hash);
   80:         if (defined($error)) {
   81:             print "Error processing ".$fname.$/;
   82:             print STDERR $error;
   83:         } else {
   84:             print "Everything looks good for ".$fname.$/;
   85:         }
   86:     }
   87:     if (defined($error)) {
   88:         print $error.$/;
   89:     }
   90: }
   91: 
   92: exit;
   93: 
   94: ######################################################
   95: ######################################################
   96: sub process_file {
   97:     my ($fname,$db_filename,$debug) = @_;
   98:     #
   99:     open(HISTFILE,$fname);
  100:     my %db_to_store;
  101:     my $no_action_count = 0;
  102:     while (my $command = <HISTFILE>) {
  103:         chomp($command);
  104:         my $error = undef;
  105:         # Each line can begin with:
  106:         #  P:put
  107:         #  D:delete
  108:         my ($action,$time,$concatenated_data) = split(':',$command,3);
  109:         if ($fname eq 'roles.hist' && $concatenated_data =~ /^.*:.*:/) {
  110:             (undef,undef,$concatenated_data) = split(':',$concatenated_data,3);
  111:         }
  112:         next if (! defined($action));
  113:         if ($action eq 'P' && $p_is_s) { $action = 'S'; }
  114:         my ($rid,$allkeys,$version);
  115:         if ($action eq 'S') {
  116:             ($rid,$concatenated_data) = split(':',$concatenated_data,2);
  117:             $version = ++$db_to_store{"version:$rid"};
  118:             # print $version.$/;
  119:         }
  120:         next if (! defined($concatenated_data));
  121:         my @data = split('&',$concatenated_data);
  122:         foreach my $k_v_pair (@data) {
  123:             my ($key,$value) = split('=',$k_v_pair,2);
  124:             if (defined($action) && $action eq 'P') {
  125:                 if (defined($value)) {
  126:                     $db_to_store{$key}=$value;
  127:                 } else {
  128:                     $no_action_count++;
  129:                 }
  130:             } elsif ($action eq 'S') {
  131:                 # Versioning of data, so we update the old ata
  132:                 $allkeys.=$key.':';
  133:                 $db_to_store{"$version:$rid:$key"}=$value;
  134:             } elsif ($action eq 'D') {
  135:                 delete($db_to_store{$key});
  136:             } else {
  137:                 $error = "Unable to understand action '".$action."'";
  138:             }
  139:         }
  140:         if ($action eq 'S') {
  141: 	    $db_to_store{"$version:$rid:timestamp"}=$time;
  142: 	    $allkeys.='timestamp';
  143: 	    $db_to_store{"$version:keys:$rid"}=$allkeys;
  144:         }
  145:         if (defined($error)) {
  146:             return ('Error:'.$error.$/,undef);
  147:         }
  148:     }
  149:     if ($no_action_count) {
  150:         print $no_action_count.' lines did not require action.'.$/;
  151:     }
  152:     close(HISTFILE);
  153:     return (undef,\%db_to_store);
  154: }
  155: 
  156: sub write_hash {
  157:     my ($db_filename,$db_to_store) = @_;
  158:     #
  159:     # Write the gdbm file
  160:     my %db;
  161:     if (! tie(%db,'GDBM_File',$db_filename,&GDBM_WRCREAT(),0640)) {
  162:         warn "Unable to tie to $db_filename";
  163:         return "Unable to tie to $db_filename";
  164:     }
  165:     #
  166:     while (my ($k,$v) = each(%$db_to_store)) {
  167:         $db{$k}=$v;
  168:     }
  169:     #
  170:     untie(%db);
  171:     return undef;
  172: }
  173: 
  174: sub test_hash {
  175:     my ($db_filename,$my_db) = @_;
  176:     #
  177:     my %db;
  178:     if (! tie(%db,'GDBM_File',$db_filename,&GDBM_READER(),0640)) {
  179:         return "Unable to tie to $db_filename";;
  180:     }
  181:     my (%key_errors,%value_errors);
  182:     while (my ($k,$v) = each(%db)) {
  183:         if (exists($my_db->{$k})) {
  184:             if ($my_db->{$k} eq $v) {
  185:                 delete($my_db->{$k});
  186:             } else {
  187:                 $value_errors{$k}=$v;
  188:             }
  189:         } else {
  190:             $key_errors{$k}=$v;
  191:         }
  192:     }
  193:     untie(%db);
  194:     #
  195:     my $error;
  196:     my $extra_count = scalar(keys(%$my_db));
  197:     if ($extra_count) {
  198:         $error.=$extra_count.' extra key/value pairs found in hist: '.$/;
  199:         while (my ($k,$v) = each(%$my_db)) {
  200:             $error .= '  "'.$k.'" => "'.$v.'"'.$/;
  201:         }
  202:     }
  203:     my $key_count = scalar(keys(%key_errors));
  204:     if ($key_count) {
  205:         $error.=$key_count.' missing keys found in db but not in hist: '.$/;
  206:         while (my ($k,$v) = each(%key_errors)) {
  207:             $error .= '  "'.$k.'" => "'.$v.'"'.$/;
  208:         }
  209:     }
  210:     my $value_count = scalar(keys(%value_errors));
  211:     if ($value_count) {
  212:         $error.=$value_count.' mismatched values found: '.$/;
  213:         while (my ($k,$v) = each(%value_errors)) {
  214:             $error .= '  "'.$k.'" => "'.$v.'"'.$/;
  215:         }
  216:     }
  217:     #
  218:     return $error;
  219: }