#!/usr/bin/perl -w
#
## Copyright (C) 1996-2018 The Squid Software Foundation and contributors
##
## Squid software is distributed under GPLv2+ license and includes
## contributions from numerous individuals and organizations.
## Please see the COPYING and CONTRIBUTORS files for details.
##

# Reads cache.log and displays lines that correspond to a given store entry.
#
# Store entry can be identified by its key or an anchor slot ID in a rock-style
# map.
#
# Currently, the script reads and remembers many irrelevant lines because it
# does not know which one should be tracked in advance.
# 

use strict;
use warnings;
use Carp;

my @InterestingEntries = @ARGV;
#die("usage: $0 [entry number|key value|pointer address] ...\n");

my $LastEntryId = 0;
my %Entries = ();
my %EntriesByPartId = ();

my %CurrentEntries = ();
my $Kid;
my %Entering = ();
my %Inside = ();

my $DEB;

while (<STDIN>) {
	my $line = $_;
	#$DEB = 1 if /16:53:44.632/;

	($Kid) = (/(kid\d+)[|]/);
	$Kid = 'kid0' unless defined $Kid;

	&enterBlock($., $_) if
		(/[|:] entering\b/ && !/Port::noteRead/) ||
        (/Port::noteRead/ && /handling/);

	next unless $Inside{$Kid};

	while ($line =~ s@\b(entry) (\d+) .*?(\S*_map)@ @) {
		&processEntryPartId("$3.$1", $2);
	}

	while ($line =~ s@\b(slice|slot) (\d+)@ @) {
		&processEntryPartId($1, $2);
	}

	#while ($line =~ s@\b(page) (\w+)@ @) {
	#	&processEntryPartId($1, $2);
	#}

	while ($line =~ s@\b(key) '?(\w+)@ @) {
		&processEntryPartId($1, $2);
	}

	while ($line =~ s@\b([A-Z0-9]{32})\b@ @) {
		&processEntryPartId('key', $1);
	}

	while ($line =~ s@\be:\S*?/(0x\w+)@ @ || $line =~ s@\bStoreEntry\s+(0x\w+)@ @) {
		&processEntryPartId('pointer', $1);
	}

	if ($line ne $_ || /[|:] leaving\b/) {
		if (my $entry = $CurrentEntries{$Kid}) {
			&updateEntry($entry, $Entering{$Kid}) if exists $Entering{$Kid};
			delete $Entering{$Kid};
			&updateEntry($entry, &historyLine($., $_));
		}
	}

	&leaveBlock() if
       (/[|:] leaving\b/ && !/Port::noteRead/) ||
        (/Port::noteRead/ && /handled/);
}


# merge same entries
my %cleanEntries = ();
foreach my $id (sort { $a <=> $b } keys %Entries) {
	my $entry = $Entries{$id};

	next unless &mergeAllLinkedEntries($entry);

	$entry->{id} = 1 + scalar keys %cleanEntries;
	$cleanEntries{$entry->{id}} = $entry;
}
%Entries = %cleanEntries;

printf("Saw %d entries\n", scalar keys %Entries);

if (!@InterestingEntries) { # print all entries
	foreach my $id (sort { $a <=> $b } keys %Entries) {
		my $entry = $Entries{$id};
		reportEntry($entry, 1);
	}
} else {
	foreach my $description (@InterestingEntries) {
		my ($part, $id) = ($description =~ /(\w+)\s+(\w+)/);
		my $entry = &getExistingEntry($part, $id);
		reportEntry($entry, 1);
	}
}

exit(0);

sub enterBlock {
	my ($lineNo, $lineText) = @_;

	$Entering{$Kid} = &historyLine($., $_);
	die("double entrance, stopped") if $Inside{$Kid};
	$Inside{$Kid} = 1;
}

sub leaveBlock {
	$CurrentEntries{$Kid} = undef();
	delete $Entering{$Kid};
	$Inside{$Kid} = 0;
}

sub processEntryPartId {
	my ($part, $id) = @_;

	#warn("XXX1: $Kid| part.id: $part.$id\n") if $DEB;

	my $entry;
	my $curEntry = $CurrentEntries{$Kid};
	my $oldEntry = &getExistingEntry($part, $id);
	if ($curEntry && $oldEntry && $curEntry->{id} != $oldEntry->{id}) {
		&linkEntries($curEntry, $oldEntry, "$part.$id");
		$entry = $curEntry;
	} else {
		$entry = $curEntry ? $curEntry : $oldEntry;
	}
	$entry = &getEntry($part, $id) unless defined $entry;
	$CurrentEntries{$Kid} = $entry;

	$entry->{parts}->{$part} = {} unless exists $entry->{parts}->{$part};
	$entry->{parts}->{$part}->{$id} = $_ unless exists $entry->{parts}->{$part}->{$id};
}

sub historyLine {
	my ($lineCount, $line) = @_;
	return sprintf("#%06d %s", $lineCount, $line);
}

sub updateEntry {
	my ($entry, $historyLine) = @_;

	$entry->{history} .= $historyLine;
}

sub linkEntries {
	my ($e1, $e2, $ctx) = @_;

	$e1->{sameAs}->{$e2->{id}} = 1;
	$e2->{sameAs}->{$e1->{id}} = 1;
}

sub mergeAllLinkedEntries {
	my ($entry) = @_;

	#warn(sprintf("merging %d <-- * %s\n", $entry->{id}, $entry->{merged} ? "skipped" : ""));

	return 0 if $entry->{merged};
	$entry->{merged} = 1;

	foreach my $otherId (keys %{$entry->{sameAs}}) {
		my $otherE = $Entries{$otherId};
		die("missing internal entry$otherId, stopped") unless $otherE;
		next if $otherE->{merged};
		&mergeAllLinkedEntries($otherE);
		&mergeOneEntry($entry, $otherE);
		$otherE->{merged} = 1;
	}

	return 1;
}

sub mergeOneEntry {
	my ($entry, $otherE) = @_;

	#warn(sprintf("merging %d <-- %d\n", $entry->{id}, $otherE->{id}));

	foreach my $part (keys %{$otherE->{parts}}) {
        foreach my $id (keys %{$otherE->{parts}->{$part}}) {
            $entry->{parts}->{$part}->{$id} = $otherE->{parts}->{$part}->{$id};
		}
	}

	$entry->{history} .= $otherE->{history};
}

sub getExistingEntry {
	my ($part, $id) = @_;

	return $EntriesByPartId{$part}->{$id} if exists $EntriesByPartId{$part};
	return undef();
}

sub getEntry {
	my ($part, $id) = @_;

	$EntriesByPartId{$part} = {} unless exists $EntriesByPartId{$part};
	my $entry = $EntriesByPartId{$part}->{$id};
	return $entry if $entry;

	$entry = {
		id => ++$LastEntryId,

		parts => {},

		history => '',

		reported => 0,
	};

	$entry->{parts}->{$part} = {};
	$EntriesByPartId{$part}->{$id} = $entry;
	$Entries{$LastEntryId} = $entry;
	return $entry;
}


sub reportEntry {
	my ($entry, $recursive) = @_;

	return if $entry->{reported};
	$entry->{reported} = 1;

	printf("entry%d:\n", $entry->{id});

	foreach my $part (keys %{$entry->{parts}}) {
		printf("\t%s(s):", $part);
		foreach my $id (keys %{$entry->{parts}->{$part}}) {
			printf(" %s", $id);
		}
		print("\n");
	}

	&reportEntryHistory($entry);
}

sub reportEntryParam {
	my ($entry, $name, $value) = @_;

	$value = $entry->{$name} if @_ < 3;
	$value = '?' unless defined $value;
	$value = "\n$value" if $value =~ /\n/m;
	printf("\t%s: %s\n", $name, $value);
}

sub reportEntryHistory {
	my ($entry) = @_;

	my $history = $entry->{history};
	my @lines = split(/\n/, $history);
	&reportEntryParam($entry, 'history', (scalar @lines) . " lines");

	my $lastKid = '';
	foreach my $line (sort @lines) {
		my ($kid) = ($line =~ /(kid\d+)[|]/);
		$kid = 'kid0' unless defined $kid;

		print "\n" if $lastKid ne $kid;
		print "$line\n";
		$lastKid = $kid;
	}
	print "\n" if @lines;
}
