]>
Commit | Line | Data |
---|---|---|
e5433948 | 1 | #!/usr/bin/perl -w |
a151895d | 2 | # |
5b74111a | 3 | ## Copyright (C) 1996-2018 The Squid Software Foundation and contributors |
a151895d AJ |
4 | ## |
5 | ## Squid software is distributed under GPLv2+ license and includes | |
6 | ## contributions from numerous individuals and organizations. | |
7 | ## Please see the COPYING and CONTRIBUTORS files for details. | |
8 | ## | |
e5433948 AR |
9 | |
10 | # Reads cache.log and displays lines that correspond to a given store entry. | |
11 | # | |
12 | # Store entry can be identified by its key or an anchor slot ID in a rock-style | |
13 | # map. | |
14 | # | |
15 | # Currently, the script reads and remembers many irrelevant lines because it | |
16 | # does not know which one should be tracked in advance. | |
17 | # | |
18 | ||
19 | use strict; | |
20 | use warnings; | |
21 | use Carp; | |
22 | ||
23 | my @InterestingEntries = @ARGV; | |
24 | #die("usage: $0 [entry number|key value|pointer address] ...\n"); | |
25 | ||
26 | my $LastEntryId = 0; | |
27 | my %Entries = (); | |
28 | my %EntriesByPartId = (); | |
29 | ||
30 | my %CurrentEntries = (); | |
31 | my $Kid; | |
32 | my %Entering = (); | |
33 | my %Inside = (); | |
34 | ||
35 | my $DEB; | |
36 | ||
37 | while (<STDIN>) { | |
38 | my $line = $_; | |
39 | #$DEB = 1 if /16:53:44.632/; | |
40 | ||
41 | ($Kid) = (/(kid\d+)[|]/); | |
42 | $Kid = 'kid0' unless defined $Kid; | |
43 | ||
44 | &enterBlock($., $_) if | |
45 | (/[|:] entering\b/ && !/Port::noteRead/) || | |
46 | (/Port::noteRead/ && /handling/); | |
47 | ||
48 | next unless $Inside{$Kid}; | |
49 | ||
50 | while ($line =~ s@\b(entry) (\d+) .*?(\S*_map)@ @) { | |
51 | &processEntryPartId("$3.$1", $2); | |
52 | } | |
53 | ||
54 | while ($line =~ s@\b(slice|slot) (\d+)@ @) { | |
55 | &processEntryPartId($1, $2); | |
56 | } | |
57 | ||
58 | #while ($line =~ s@\b(page) (\w+)@ @) { | |
59 | # &processEntryPartId($1, $2); | |
60 | #} | |
61 | ||
62 | while ($line =~ s@\b(key) '?(\w+)@ @) { | |
63 | &processEntryPartId($1, $2); | |
64 | } | |
65 | ||
66 | while ($line =~ s@\b([A-Z0-9]{32})\b@ @) { | |
67 | &processEntryPartId('key', $1); | |
68 | } | |
69 | ||
70 | while ($line =~ s@\be:\S*?/(0x\w+)@ @ || $line =~ s@\bStoreEntry\s+(0x\w+)@ @) { | |
71 | &processEntryPartId('pointer', $1); | |
72 | } | |
73 | ||
74 | if ($line ne $_ || /[|:] leaving\b/) { | |
75 | if (my $entry = $CurrentEntries{$Kid}) { | |
76 | &updateEntry($entry, $Entering{$Kid}) if exists $Entering{$Kid}; | |
77 | delete $Entering{$Kid}; | |
78 | &updateEntry($entry, &historyLine($., $_)); | |
79 | } | |
80 | } | |
81 | ||
82 | &leaveBlock() if | |
83 | (/[|:] leaving\b/ && !/Port::noteRead/) || | |
84 | (/Port::noteRead/ && /handled/); | |
85 | } | |
86 | ||
87 | ||
88 | # merge same entries | |
89 | my %cleanEntries = (); | |
90 | foreach my $id (sort { $a <=> $b } keys %Entries) { | |
91 | my $entry = $Entries{$id}; | |
92 | ||
93 | next unless &mergeAllLinkedEntries($entry); | |
94 | ||
95 | $entry->{id} = 1 + scalar keys %cleanEntries; | |
96 | $cleanEntries{$entry->{id}} = $entry; | |
97 | } | |
98 | %Entries = %cleanEntries; | |
99 | ||
100 | printf("Saw %d entries\n", scalar keys %Entries); | |
101 | ||
102 | if (!@InterestingEntries) { # print all entries | |
103 | foreach my $id (sort { $a <=> $b } keys %Entries) { | |
104 | my $entry = $Entries{$id}; | |
105 | reportEntry($entry, 1); | |
106 | } | |
107 | } else { | |
108 | foreach my $description (@InterestingEntries) { | |
109 | my ($part, $id) = ($description =~ /(\w+)\s+(\w+)/); | |
110 | my $entry = &getExistingEntry($part, $id); | |
111 | reportEntry($entry, 1); | |
112 | } | |
113 | } | |
114 | ||
115 | exit(0); | |
116 | ||
117 | sub enterBlock { | |
118 | my ($lineNo, $lineText) = @_; | |
119 | ||
120 | $Entering{$Kid} = &historyLine($., $_); | |
121 | die("double entrance, stopped") if $Inside{$Kid}; | |
122 | $Inside{$Kid} = 1; | |
123 | } | |
124 | ||
125 | sub leaveBlock { | |
126 | $CurrentEntries{$Kid} = undef(); | |
127 | delete $Entering{$Kid}; | |
128 | $Inside{$Kid} = 0; | |
129 | } | |
130 | ||
131 | sub processEntryPartId { | |
132 | my ($part, $id) = @_; | |
133 | ||
134 | #warn("XXX1: $Kid| part.id: $part.$id\n") if $DEB; | |
135 | ||
136 | my $entry; | |
137 | my $curEntry = $CurrentEntries{$Kid}; | |
138 | my $oldEntry = &getExistingEntry($part, $id); | |
139 | if ($curEntry && $oldEntry && $curEntry->{id} != $oldEntry->{id}) { | |
140 | &linkEntries($curEntry, $oldEntry, "$part.$id"); | |
141 | $entry = $curEntry; | |
142 | } else { | |
143 | $entry = $curEntry ? $curEntry : $oldEntry; | |
144 | } | |
145 | $entry = &getEntry($part, $id) unless defined $entry; | |
146 | $CurrentEntries{$Kid} = $entry; | |
147 | ||
148 | $entry->{parts}->{$part} = {} unless exists $entry->{parts}->{$part}; | |
149 | $entry->{parts}->{$part}->{$id} = $_ unless exists $entry->{parts}->{$part}->{$id}; | |
150 | } | |
151 | ||
152 | sub historyLine { | |
153 | my ($lineCount, $line) = @_; | |
154 | return sprintf("#%06d %s", $lineCount, $line); | |
155 | } | |
156 | ||
157 | sub updateEntry { | |
158 | my ($entry, $historyLine) = @_; | |
159 | ||
160 | $entry->{history} .= $historyLine; | |
161 | } | |
162 | ||
163 | sub linkEntries { | |
164 | my ($e1, $e2, $ctx) = @_; | |
165 | ||
166 | $e1->{sameAs}->{$e2->{id}} = 1; | |
167 | $e2->{sameAs}->{$e1->{id}} = 1; | |
168 | } | |
169 | ||
170 | sub mergeAllLinkedEntries { | |
171 | my ($entry) = @_; | |
172 | ||
173 | #warn(sprintf("merging %d <-- * %s\n", $entry->{id}, $entry->{merged} ? "skipped" : "")); | |
174 | ||
175 | return 0 if $entry->{merged}; | |
176 | $entry->{merged} = 1; | |
177 | ||
178 | foreach my $otherId (keys %{$entry->{sameAs}}) { | |
179 | my $otherE = $Entries{$otherId}; | |
180 | die("missing internal entry$otherId, stopped") unless $otherE; | |
181 | next if $otherE->{merged}; | |
182 | &mergeAllLinkedEntries($otherE); | |
183 | &mergeOneEntry($entry, $otherE); | |
184 | $otherE->{merged} = 1; | |
185 | } | |
186 | ||
187 | return 1; | |
188 | } | |
189 | ||
190 | sub mergeOneEntry { | |
191 | my ($entry, $otherE) = @_; | |
192 | ||
193 | #warn(sprintf("merging %d <-- %d\n", $entry->{id}, $otherE->{id})); | |
194 | ||
195 | foreach my $part (keys %{$otherE->{parts}}) { | |
196 | foreach my $id (keys %{$otherE->{parts}->{$part}}) { | |
197 | $entry->{parts}->{$part}->{$id} = $otherE->{parts}->{$part}->{$id}; | |
198 | } | |
199 | } | |
200 | ||
201 | $entry->{history} .= $otherE->{history}; | |
202 | } | |
203 | ||
204 | sub getExistingEntry { | |
205 | my ($part, $id) = @_; | |
206 | ||
207 | return $EntriesByPartId{$part}->{$id} if exists $EntriesByPartId{$part}; | |
208 | return undef(); | |
209 | } | |
210 | ||
211 | sub getEntry { | |
212 | my ($part, $id) = @_; | |
213 | ||
214 | $EntriesByPartId{$part} = {} unless exists $EntriesByPartId{$part}; | |
215 | my $entry = $EntriesByPartId{$part}->{$id}; | |
216 | return $entry if $entry; | |
217 | ||
218 | $entry = { | |
219 | id => ++$LastEntryId, | |
220 | ||
221 | parts => {}, | |
222 | ||
223 | history => '', | |
224 | ||
225 | reported => 0, | |
226 | }; | |
227 | ||
228 | $entry->{parts}->{$part} = {}; | |
229 | $EntriesByPartId{$part}->{$id} = $entry; | |
230 | $Entries{$LastEntryId} = $entry; | |
231 | return $entry; | |
232 | } | |
233 | ||
234 | ||
235 | sub reportEntry { | |
236 | my ($entry, $recursive) = @_; | |
237 | ||
238 | return if $entry->{reported}; | |
239 | $entry->{reported} = 1; | |
240 | ||
241 | printf("entry%d:\n", $entry->{id}); | |
242 | ||
243 | foreach my $part (keys %{$entry->{parts}}) { | |
244 | printf("\t%s(s):", $part); | |
245 | foreach my $id (keys %{$entry->{parts}->{$part}}) { | |
246 | printf(" %s", $id); | |
247 | } | |
248 | print("\n"); | |
249 | } | |
250 | ||
251 | &reportEntryHistory($entry); | |
252 | } | |
253 | ||
254 | sub reportEntryParam { | |
255 | my ($entry, $name, $value) = @_; | |
256 | ||
257 | $value = $entry->{$name} if @_ < 3; | |
258 | $value = '?' unless defined $value; | |
259 | $value = "\n$value" if $value =~ /\n/m; | |
260 | printf("\t%s: %s\n", $name, $value); | |
261 | } | |
262 | ||
263 | sub reportEntryHistory { | |
264 | my ($entry) = @_; | |
265 | ||
266 | my $history = $entry->{history}; | |
267 | my @lines = split(/\n/, $history); | |
268 | &reportEntryParam($entry, 'history', (scalar @lines) . " lines"); | |
269 | ||
270 | my $lastKid = ''; | |
271 | foreach my $line (sort @lines) { | |
272 | my ($kid) = ($line =~ /(kid\d+)[|]/); | |
273 | $kid = 'kid0' unless defined $kid; | |
274 | ||
275 | print "\n" if $lastKid ne $kid; | |
276 | print "$line\n"; | |
277 | $lastKid = $kid; | |
278 | } | |
279 | print "\n" if @lines; | |
280 | } |