[BACK]Return to seed_accesscount.pl CVS log [TXT] [DIR] Up to [LON-CAPA] / loncom / debugging_tools

Diff for /loncom/debugging_tools/seed_accesscount.pl between versions 1.4 and 1.5

version 1.4, 2004/01/13 18:13:34 version 1.5, 2006/06/27 15:21:46
Line 30 Line 30
 use strict;  use strict;
 use Getopt::Long;  use Getopt::Long;
 use GDBM_File;  use GDBM_File;
   use lib '/home/httpd/lib/perl/';
   use LONCAPA;
   
 #  #
 # Options  # Options
Line 52  $|=1; Line 54  $|=1;
 while (my $resDBname = shift()) {  while (my $resDBname = shift()) {
     my ($path) = ($resDBname =~ /^(.*)nohist_resevaldata.db$/);      my ($path) = ($resDBname =~ /^(.*)nohist_resevaldata.db$/);
     print STDERR $path.$/;      print STDERR $path.$/;
     my %resevalDB;      my $resevalDB = &LONCAPA::locking_hash_tie($resDBname,&GDBM_READER());
     if (! tie(%resevalDB,'GDBM_File',$resDBname,&GDBM_READER,0640)) {      if (! $resevalDB) {
         warn "Unable to tie to $resDBname";          warn "Unable to tie to $resDBname";
         next;          next;
     }      }
       &LONCAPA::push_locking_hash_tie();
     #      #
     my $accessDBname = $path.'nohist_accesscount.db';      my $accessDBname = $path.'nohist_accesscount.db';
     my %accessDB;      my $accessDB = &LONCAPA::locking_hash_tie($accessDBname,&GDBM_WRCREAT());
     if (! tie(%accessDB,'GDBM_File',$accessDBname,&GDBM_WRCREAT,0640)) {      if (! $accessDB) {
         warn "Unable to tie to $accessDBname";          warn "Unable to tie to $accessDBname";
         next;          next;
     }      }
Line 69  while (my $resDBname = shift()) { Line 72  while (my $resDBname = shift()) {
     my ($basekey,$value);      my ($basekey,$value);
     #      #
     $! = 0;      $! = 0;
     while (eval('($basekey,$value) = each(%resevalDB);')) {      while (eval('($basekey,$value) = each(%{$resevalDB});')) {
         if ($!) {          if ($!) {
             print STDERR $1.$/;              print STDERR $1.$/;
             $!=0;              $!=0;
Line 79  while (my $resDBname = shift()) { Line 82  while (my $resDBname = shift()) {
         next if (! ((undef,$src) = ($key =~ /^(.*)___(.*)___count/)));          next if (! ((undef,$src) = ($key =~ /^(.*)___(.*)___count/)));
         my $value = &unescape($value);          my $value = &unescape($value);
         $src = &escape($src);          $src = &escape($src);
         if (exists($accessDB{$src})) {          if (exists($accessDB->{$src})) {
             $accessDB{$src}+=$value;              $accessDB->{$src}+=$value;
         } else {          } else {
             $accessDB{$src}=$value;              $accessDB->{$src}=$value;
         }          }
         push (@Keys,$basekey);          push (@Keys,$basekey);
     }      }
     #      #
     untie %accessDB;          &LONCAPA::locking_hash_untie($accessDB);
     untie %resevalDB;      &LONCAPA::pop_locking_hash_tie();
       &LONCAPA::locking_hash_untie($resevalDB);
     system("chown www:www $accessDBname");      system("chown www:www $accessDBname");
     # remove the keys we saved.      # remove the keys we saved.
     next if (! scalar(@Keys)); # skip it if we did not get anything...      next if (! scalar(@Keys)); # skip it if we did not get anything...
     my $dbptr;      my $dbptr = &LONCAPA::locking_hash_tie($resDBname,&GDBM_READER());
     if (! ($dbptr = tie(%resevalDB,'GDBM_File',$resDBname,&GDBM_WRITER,0640))){      if (! $dbptr ) {
         die "Unable to re-tie to $resDBname.  No deletes occured.";          die "Unable to re-tie to $resDBname.  No deletes occured.";
     }      }
     foreach my $basekey (@Keys) {      foreach my $basekey (@Keys) {
         delete($resevalDB{$basekey});          delete($resevalDB->{$basekey});
     }      }
     # Squish the file down      # Squish the file down
     $dbptr->reorganize();      &LONCAPA::locking_hash_untie($resevalDB);
     $dbptr = undef;  
     untie(%resevalDB);  
     system("chown www:www $resDBname");      system("chown www:www $resDBname");
 }  }
 exit;  exit;
   
 ######################################  ######################################
 sub escape {  
     my $str=shift;  
     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;  
     return $str;  
 }  
   
 sub unescape {  
     my $str=shift;  
     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;  
     return $str;  
 }  
Removed from v.1.4  
changed lines
  Added in v.1.5

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>