scripts/trace-entry.pl

   1 #!/usr/bin/perl -w
   2 #
   3 ## Copyright (C) 1996-2023 The Squid Software Foundation and contributors
   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 ##
   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         parts => {},
 221         history => '',
 222         reported => 0,
 223         };
 224
 225     $entry->{parts}->{$part} = {};
 226     $EntriesByPartId{$part}->{$id} = $entry;
 227     $Entries{$LastEntryId} = $entry;
 228     return $entry;
 229 }
 230
 231
 232 sub reportEntry {
 233     my ($entry, $recursive) = @_;
 234
 235     return if $entry->{reported};
 236     $entry->{reported} = 1;
 237
 238     printf("entry%d:\n", $entry->{id});
 239
 240     foreach my $part (keys %{$entry->{parts}}) {
 241         printf("\t%s(s):", $part);
 242         foreach my $id (keys %{$entry->{parts}->{$part}}) {
 243             printf(" %s", $id);
 244         }
 245         print("\n");
 246     }
 247
 248     &reportEntryHistory($entry);
 249 }
 250
 251 sub reportEntryParam {
 252     my ($entry, $name, $value) = @_;
 253
 254     $value = $entry->{$name} if @_ < 3;
 255     $value = '?' unless defined $value;
 256     $value = "\n$value" if $value =~ /\n/m;
 257     printf("\t%s: %s\n", $name, $value);
 258 }
 259
 260 sub reportEntryHistory {
 261     my ($entry) = @_;
 262
 263     my $history = $entry->{history};
 264     my @lines = split(/\n/, $history);
 265     &reportEntryParam($entry, 'history', (scalar @lines) . " lines");
 266
 267     my $lastKid = '';
 268     foreach my $line (sort @lines) {
 269         my ($kid) = ($line =~ /(kid\d+)[|]/);
 270         $kid = 'kid0' unless defined $kid;
 271
 272         print "\n" if $lastKid ne $kid;
 273         print "$line\n";
 274         $lastKid = $kid;
 275     }
 276     print "\n" if @lines;
 277 }