tagging KDE 3.5.8
[kdevelop:kdevelop.git] / admin / bcheck.pl
1 #!/usr/bin/perl -w
2
3 use DB_File;
4 use Fcntl ':flock';
5
6 if (!defined($ARGV[0])) {
7     print "usage: requires .class dump as parameter!\n";
8     exit;
9 }
10
11 sub bailout
12 {
13     untie %bcheckdb if(defined(%bcheckdb));
14
15     if(defined(MYLOCK)) {
16         flock MYLOCK, LOCK_UN;
17         close(MYLOCK);
18     }
19
20     print @_;
21     exit 5;
22 }
23
24 sub ask_user
25 {
26     my ($dbkey, $dbchunk) = @_;
27
28     if (defined($ENV{"BCHECK_UPDATE"})) {
29         $bcheckdb{$dbkey} = $dbchunk;
30         return;
31     }
32
33     &bailout("BC problem detected") if (! -t STDIN);
34
35     print "(I)gnore / (Q)uit / (U)pdate: ";
36
37     my $key;
38     while(defined(read STDIN, $key, 1)) {
39         $key = lc($key);
40
41         print "got: >$key<\n";
42
43         return if ($key eq 'i');
44
45         &bailout("BC problem. aborted") if ($key eq 'q');
46
47         if ($key eq 'u') {
48             $bcheckdb{$dbkey} = $dbchunk;
49             return;
50         }
51         print "\n(I)gnore / (Q)uit / (U)pdate: ";
52     }
53 }
54
55 sub diff_chunk($$)
56 {
57     my ($oldl, $newl) = @_;
58     my @old = split /^/m, $oldl;
59     my @new = split /^/m, $newl;
60     my $haschanges = 0;
61     my $max = $#old > $#new ? $#old : $#new;
62
63     die "whoops. key different" if ($old[0] ne $new[0]);
64
65     if ($#old != $#new) {
66         warn ("Structural difference.\n");
67         print @old;
68         print "-----------------------------------------------\n";
69         print @new;
70         $haschanges = 1;
71         return $haschanges;
72     }
73
74     print $old[0];
75
76     my ($class) = ($old[0] =~ /^(?:Class |Vtable for )(\S+)/);
77
78     my $c = 1;
79     while ($c < $max) {
80         my ($o, $n) = ($old[$c], $new[$c]);
81         chomp $o;
82         chomp $n;
83         $c++;
84         next if ($o eq $n);
85
86         if(defined($class) and $n =~ /^(\d+\s+)\w+(::\S+\s*.*)$/) {
87             next if ($n eq "$1$class$2");
88         }
89
90         $haschanges = 1;
91
92         print "-$o\n+$n\n\n";
93     }
94
95     return $haschanges;
96 }
97
98 local $dblock = $ENV{"HOME"} . "/bcheck.lock";
99 my $dbfile = $ENV{"HOME"} . "/bcheck.db";
100 my $cdump  = $ARGV[0];
101
102 die "file $cdump is not readable: $!" if (! -f $cdump);
103
104 # make sure the advisory lock exists
105 open(MYLOCK, ">$dblock");
106 print MYLOCK "";
107
108 flock MYLOCK, LOCK_EX;
109
110 tie %bcheckdb, 'DB_File', $dbfile;
111
112 my $chunk = "";
113
114 open (IN, "<$cdump") or die "cannot open $cdump: $!";
115 while (<IN>) {
116
117     chop;
118
119     s/0x[0-9a-fA-F]+/0x......../g;
120     s/base size=/size=/g;
121     s/\(\)\s*$//g;
122     s/base align=/align=/g;
123
124     $chunk .= $_ . "\n";
125
126     if(/^\s*$/) {
127         my @lines = split /^/m, $chunk;
128         my $key = $lines[0];
129         chomp $key;
130
131         if($key !~ /<anonymous struct>/ &&
132            $key !~ /<anonymous union>/) {
133             if(defined($bcheckdb{$key})) {
134                 my $dbversion = $bcheckdb{$key};
135
136                 if($dbversion ne $chunk) {
137                      &ask_user($key, $chunk) if(&diff_chunk($dbversion, $chunk));
138                 }
139             }
140             else {
141                 $bcheckdb{$key} = $chunk;
142                 print "NEW: $key\n";
143             }
144         }
145
146         $chunk = "";
147         next;
148     }
149
150 }
151 close(IN);
152
153 untie %bcheckdb;
154 flock MYLOCK, LOCK_UN;
155 close(MYLOCK);
156
157 exit 0;