Annotation of loncom/debugging_tools/seed_accesscount.pl, revision 1.3
1.1 matthew 1: #!/usr/bin/perl -w
2: #
3: # The LearningOnline Network
4: #
1.3 ! matthew 5: # $Id: seed_accesscount.pl,v 1.2 2003/11/14 20:41:48 matthew Exp $
1.1 matthew 6: #
7: # Copyright Michigan State University Board of Trustees
8: #
9: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
10: #
11: # LON-CAPA is free software; you can redistribute it and/or modify
12: # it under the terms of the GNU General Public License as published by
13: # the Free Software Foundation; either version 2 of the License, or
14: # (at your option) any later version.
15: #
16: # LON-CAPA is distributed in the hope that it will be useful,
17: # but WITHOUT ANY WARRANTY; without even the implied warranty of
18: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19: # GNU General Public License for more details.
20: #
21: # You should have received a copy of the GNU General Public License
22: # along with LON-CAPA; if not, write to the Free Software
23: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
24: #
25: # /home/httpd/html/adm/gpl.txt
26: #
27: # http://www.lon-capa.org/
28: #
29: #################################################
30: use strict;
31: use Getopt::Long;
32: use GDBM_File;
33:
34: #
35: # Options
36: my ($verbose,$help) = (0);
37: GetOptions("v" => \$verbose,
38: "help" => \$help);
39:
40: #
41: # Help them out if they ask for it
42: if ($help) {
43: print <<END;
44: seed_accesscount.pl
45: END
46: exit;
47: }
48:
49: #
50: # Loop through ARGV getting files.
51: $|=1;
52: while (my $resDBname = shift()) {
53: my ($path) = ($resDBname =~ /^(.*)nohist_resevaldata.db$/);
54: print STDERR $path.$/;
55: my %resevalDB;
56: if (! tie(%resevalDB,'GDBM_File',$resDBname,&GDBM_READER,0640)) {
57: warn "Unable to tie to $resDBname";
58: next;
59: }
60: #
61: my $accessDBname = $path.'nohist_accesscount.db';
62: my %accessDB;
63: if (! tie(%accessDB,'GDBM_File',$accessDBname,&GDBM_WRCREAT,0640)) {
64: warn "Unable to tie to $accessDBname";
65: next;
66: }
67: #
68: my @Keys;
69: my ($basekey,$value);
70: #
71: $! = 0;
72: while (eval('($basekey,$value) = each(%resevalDB);')) {
73: if ($!) {
74: print STDERR $1.$/;
75: $!=0;
76: }
77: my $key = &unescape($basekey);
78: my $src;
79: next if (! ((undef,$src) = ($key =~ /^(.*)___(.*)___count/)));
80: my $value = &unescape($value);
1.2 matthew 81: $src = &escape($src);
1.1 matthew 82: if (exists($accessDB{$src})) {
83: $accessDB{$src}+=$value;
84: } else {
85: $accessDB{$src}=$value;
86: }
87: push (@Keys,$basekey);
88: }
89: #
90: untie %accessDB;
91: untie %resevalDB;
92: # remove the keys we saved.
93: next if (! scalar(@Keys)); # skip it if we did not get anything...
1.3 ! matthew 94: my $dbptr;
! 95: if (! ($dbptr = tie(%resevalDB,'GDBM_File',$resDBname,&GDBM_WRITER,0640))){
1.1 matthew 96: die "Unable to re-tie to $resDBname. No deletes occured.";
97: }
98: foreach my $basekey (@Keys) {
99: delete($resevalDB{$basekey});
100: }
1.3 ! matthew 101: # Squish the file down
! 102: $dbptr->reorganize();
! 103: $dbptr = undef;
! 104: untie(%resevalDB);
1.1 matthew 105: }
106: exit;
107:
108: ######################################
1.2 matthew 109: sub escape {
110: my $str=shift;
111: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
112: return $str;
113: }
114:
1.1 matthew 115: sub unescape {
116: my $str=shift;
117: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
118: return $str;
119: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>