#! /usr/bin/perl
# 
# $Id$
# Checks assumptions on Cc* (Cache Manager) behaviour by reading TraceFS log
# Copyright (C) 2003 Jan Kratochvil <project-captive@jankratochvil.net>
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; exactly version 2 of June 1991 is required
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA


use strict;
use warnings;
use Data::Dumper;


my $filter=0;
$Data::Dumper::Sortkeys=1;
my $ntfs_blocksize=0x200;

# $Object{"by"}="CcSomeFunction";
# $Object{"line_enter"}=123;
# $Object{"line_leave"}=124;
# $Object{"process_thread"}="0x12345678/0x12345678";
# $FileObject{$FileObject}{"FileObject"}="0x12345678";
# $FileObject{$FileObject}{"Allocation"}="0x12345";
# $FileObject{$FileObject}{"FileSize"}="0x12345";
# $FileObject{$FileObject}{"map"}="0x12345678" (Bcb);
# $FileObject{$FileObject}{"pin"}{"0x1000"}="0x12345678" (Bcb);
# $FileObject{$FileObject}{"PinAccess"}=0 or 1;
# $Bcb{$Bcb}{"Bcb"}="0x12345678";
# $Bcb{$Bcb}{"FileObject"}="0x12345678";
# $Bcb{$Bcb}{"type"}="pin" or "map";
# $Bcb{$Bcb}{"ref_count"}=1
# $Bcb{$Bcb}{"FileOffset"}="0x1000" if {"type"} eq "pin";
# $Bcb{$Bcb}{"Buffer"}="0x12345678";	# PAGE_SIZE-aligned for "pin", FileOffset_0-aligned for "map"

my %FileObject;
my %Bcb;

END {
	print Data::Dumper->Dump([\%FileObject,\%Bcb],[qw(%FileObject %Bcb)]) if !$filter;
	}

my $Object;

sub tohex($)
{
my($num)=@_;

	return sprintf("0x%X",$num);
}

sub CcInitializeCacheMap($$$$$)
{
my($FileObject,$AllocationSize,$FileSize,$ValidDataLength,$PinAccess)=@_;

	$ValidDataLength=$FileSize if $ValidDataLength==eval("0x".("F"x8));
	if ($FileObject{$FileObject}) {
#		warn "FileObject $FileObject registered twice";
		return if !(my $FObject=FObject($FileObject));
		delete_FObject($FObject);
		}
	$FileObject{$FileObject}=$Object;
	$Object->{"FileObject"}=$FileObject;
	$Object->{"AllocationSize"}=tohex($AllocationSize);
	$Object->{"FileSize"}=tohex($FileSize);
	$Object->{"map"}=undef();
	$Object->{"pin"}={};
	$Object->{"PinAccess"}=$PinAccess;
	CcSetFileSizes($FileObject,$AllocationSize,$FileSize,$ValidDataLength);
}

sub FObject($)
{
my($FileObject)=@_;

	my $FObject=$FileObject{$FileObject};
	warn "Non-existent FileObject $FileObject" if !$FObject;
	return $FObject;
}

sub delete_FObject($)
{
my($FObject)=@_;

	my $FileObject=$FObject->{"FileObject"};
	do { warn "Trailing map $_ of FileObject $FileObject during its deletion" if $_; } for ($FObject->{"map"});
	do { warn "Trailing pin $_ of FileObject $FileObject during its deletion" if $_; } for (values(%{$FObject->{"pin"}}));
	delete $FileObject{$FileObject};
}

sub CcUninitializeCacheMap($$)
{
my($FileObject,$TruncateSize)=@_;

	# CcUninitializeCacheMap() w/o CcInitializeCacheMap() is allowed:
	return if !$FileObject{$FileObject};
	return if !(my $FObject=FObject $FileObject);
	delete_FObject $FObject;
}

sub CcSetFileSizes($$$$)
{
my($FileObject,$AllocationSize,$FileSize,$ValidDataLength)=@_;

	return if !(my $FObject=FObject $FileObject);
	if ($AllocationSize!=eval($FObject->{"AllocationSize"})) {
		do { warn "Existing map $_ of FileObject $FileObject during CcSetAllocationSizes(),"
						." AllocationSize=".$FObject->{"AllocationSize"} if $_; }
				for ($FObject->{"map"});
		do { warn "Existing pin $_ of FileObject $FileObject during CcSetAllocationSizes(),"
						." AllocationSize=".$FObject->{"AllocationSize"} if $_; }
				for (values(%{$FObject->{"pin"}}));
		}
	# $ValidDataLength can be > $FObject->{"FileSize"};
	warn "ValidDataLength ".tohex($ValidDataLength)." > FileSize ".tohex($FileSize)
			if $ValidDataLength>$FileSize;
	warn "0 != AllocationSize ".tohex($AllocationSize)." % ntfs_blocksize ".tohex($ntfs_blocksize)
			if 0!=($AllocationSize%$ntfs_blocksize);
	# $AllocationSize can be higher
	warn "FileSize ".tohex($FileSize)." > AllocationSize ".tohex($AllocationSize)
			if $FileSize>$AllocationSize;
	$FObject->{"FileSize"}=tohex($FileSize);
	$FObject->{"AllocationSize"}=tohex($AllocationSize);
}

sub BObject($)
{
my($Bcb)=@_;

	my $BObject=$Bcb{$Bcb};
	warn "Non-existent Bcb $Bcb" if !$BObject;
	return $BObject;
}

sub Bcb_conflict($;@)
{
my($FObject,@Bcb_list)=@_;

	my $arg=0;
	my %check=(
		"map"=>$FObject->{"map"},
		map(("arg".($arg++)=>$_),@Bcb_list),
		%{$FObject->{"pin"}},
		);
	my %reversed;
	my $BufferBase;	# relativized to FileOffset 0
	my $BufferBase_val;
	while (my($key,$val)=each(%check)) {
		next if !defined $val;
		warn "Conflicting Bcb $val of keys $key and ".$reversed{$val}." of FileObject ".$FObject->{"FileObject"}
				if $reversed{$val};
		# Buffer base should match even between 'map's and 'pin's
		# as the data are always mapped only once.
		if (my $BObject=BObject $val) {
			my $Buffer=eval $BObject->{"Buffer"};
			$Buffer-=eval($BObject->{"FileOffset"}) if exists $BObject->{"FileOffset"};
			warn "Non-matching Bcb ".$BObject->{"type"}." $val Buffer base ".tohex($Buffer)
							." with Bcb ".$Bcb{$BufferBase_val}->{"type"}." $BufferBase_val BufferBase ".tohex($BufferBase)
					if defined($BufferBase) && $Buffer!=$BufferBase;
			$BufferBase=$Buffer;
			$BufferBase_val=$val;
			}
		$reversed{$val}=$key;
		}
}

# New $BObject will always be forced as the last stored reference.
sub Bcb_checkref($$)
{
my($BObject,$ref)=@_;

	return if !(my $FObject=FObject $BObject->{"FileObject"});
	my $type=$BObject->{"type"};
	my $Bcb=$BObject->{"Bcb"};
	if ($$ref) {
		my $BObject2=$Bcb{$$ref};
		warn "new $type Bcb $Bcb != old $type Bcb $$ref"
				if $Bcb ne $$ref;
		warn "new $type $Bcb type ".$BObject->{"type"}." != old $type $$ref type ".$BObject2->{"type"}
				if $BObject->{"type"} ne $BObject2->{"type"};
		warn "new $type $Bcb Buffer ".$BObject->{"Buffer"}." != old $type $$ref Buffer ".$BObject2->{"Buffer"}
				if $BObject->{"Buffer"} ne $BObject2->{"Buffer"};
		}
	if ($$ref && $$ref eq $Bcb) {
		$BObject->{"ref_count"}+=$Bcb{$$ref}->{"ref_count"};
		$$ref=undef();
		}
	$Bcb{$Bcb}=$BObject;	# &Bcb_conflict needs this reference
	Bcb_conflict $FObject,$Bcb;
	$$ref=$Bcb;
}

sub map_new($;$$)
{
my($FileObject,$FileOffset,$Length)=@_;

	return if !(my $FObject=FObject $FileObject);
	if (defined($FileOffset) && defined($Length)) {
		warn "Mapping data (end ".tohex($FileOffset+$Length).") out of FileSize ".$FObject->{"FileSize"}
				if $FileOffset+$Length>eval($FObject->{"FileSize"});
		}
	$Object->{"FileObject"}=$FileObject;
	if (defined $FileOffset) {
		$Object->{"FileOffset"}=tohex($FileOffset);
		}
	$Object->{"type"}="map";
	$Object->{"ref_count"}=1;
}

sub map_new_leave($;$)
{
my($Bcb,$Buffer)=@_;

	$Object->{"Bcb"}=$Bcb;
	return if !(my $FObject=FObject $Object->{"FileObject"});

	if (defined $Buffer) {
		$Object->{"Buffer"}=tohex(eval($Buffer)-(eval($Object->{"FileOffset"}) || 0));
		}
	delete $Object->{"FileOffset"};

	my $ref=\$FObject->{"map"};
	Bcb_checkref $Object,$ref;
}

sub CcMapData($$$)
{
my($FileObject,$FileOffset,$Length)=@_;

	map_new $FileObject,$FileOffset,$Length;
}

sub CcMapData_leave($$)
{
my($Bcb,$Buffer)=@_;

	map_new_leave $Bcb,$Buffer;
}

sub pin_new($$$)
{
my($FileObject,$FileOffset,$Length)=@_;

	return if !(my $FObject=FObject $FileObject);
	warn "Pinning of non-PinAccess FileObject $FileObject" if !$FObject->{"PinAccess"};
	warn "Mapping data (end ".tohex($FileOffset+$Length).") out of FileSize ".$FObject->{"FileSize"}
			if $FileOffset+$Length>eval($FObject->{"FileSize"});
	warn "Pinning Length ".tohex($Length)." > 0x1000" if $Length>0x1000;
	warn "Pinning across file page (start=".tohex($FileOffset).",end-1=".tohex($FileOffset+$Length-1).")"
			if ($FileOffset&~0xFFF)!=(($FileOffset+$Length-1)&~0xFFF);
	$Object->{"FileObject"}=$FileObject;
	$Object->{"FileOffset"}=tohex($FileOffset);
	$Object->{"type"}="pin";
	$Object->{"ref_count"}=1;
}

sub pin_new_leave($$)
{
my($Bcb,$Buffer)=@_;

	$Object->{"Bcb"}=$Bcb;
	return if !(my $FObject=FObject $Object->{"FileObject"});
	$Object->{"Buffer"}=tohex(eval($Buffer)-(eval($Object->{"FileOffset"})&0xFFF));
	my $shift=eval($Object->{"FileOffset"})&0xFFF;
	$Object->{"FileOffset"}=tohex(eval($Object->{"FileOffset"})-$shift);
	$Object->{"Buffer"}=tohex(eval($Buffer)-$shift);

	my $ref=\$FObject->{"pin"}{$Object->{"FileOffset"}};
	Bcb_checkref $Object,$ref;
}

sub CcPinRead($$$)
{
my($FileObject,$FileOffset,$Length)=@_;

	pin_new $FileObject,$FileOffset,$Length;
}

sub CcPinRead_leave($$)
{
my($Bcb,$Buffer)=@_;

	pin_new_leave $Bcb,$Buffer;
}

sub CcPreparePinWrite($$$)
{
my($FileObject,$FileOffset,$Length)=@_;

	pin_new $FileObject,$FileOffset,$Length;
}

sub CcPreparePinWrite_leave($$)
{
my($Bcb,$Buffer)=@_;

	pin_new_leave $Bcb,$Buffer;
}

sub CcPinMappedData($$$)
{
my($FileObject,$FileOffset,$Length)=@_;

	pin_new $FileObject,$FileOffset,$Length;
}

sub CcPinMappedData_leave($)
{
my($Bcb)=@_;

	return if !(my $FObject=FObject $Object->{"FileObject"});
	do { warn "CcPinMappedData() with Bcb $Bcb on non-CcMapData()ed FileObject ".$Object->{"FileObject"}; return; }
			if !(my $mapBcb=$FObject->{"map"});
	return if !(my $BmapObject=BObject $mapBcb);
	my $Buffer=tohex(eval($BmapObject->{"Buffer"})+eval($Object->{"FileOffset"}));

	my $Bcb2=$FObject->{"pin"}{tohex(eval($Object->{"FileOffset"})&~0xFFF)};
	my $BObject2=BObject $Bcb2 if $Bcb2;
	if ($BObject2 && $BObject2->{"CcPinMappedData_double"}
			&& eval($BObject2->{"CcPinMappedData_double"})==eval($Object->{"FileOffset"})) {	# unaligned yet
		my $BmapBuffer=eval($BmapObject->{"Buffer"})+(eval($Object->{"FileOffset"})&~0xFFF);
		warn "CcPinMappedData-double cludge non-matching new Bcb $Bcb != old Bcb ".$BObject2->{"Bcb"}
				if $Bcb ne $BObject2->{"Bcb"};
		warn "CcPinMappedData-double cludge non-matching Buffer new Bcb $Bcb Buffer $BmapBuffer"
						." != old Bcb ".$BObject2->{"Bcb"}." Buffer ".$BObject2->{"Buffer"}
				if eval($BmapBuffer)!=eval($BObject2->{"Buffer"});
		return;
		}

	$Object->{"CcPinMappedData_double"}=$Object->{"FileOffset"};	# unaligned yet
	pin_new_leave $Bcb,$Buffer;
#	print STDERR "$.:".Dumper($Object);
}

sub CcSetDirtyPinnedData($$)
{
my($Bcb,$Lsn)=@_;

	return if !(my $BObject=BObject $Bcb);
	delete $BObject->{"CcPinMappedData_double"};
}

sub CcRemapBcb($)
{
my($Bcb)=@_;

	return if !(my $BObject=BObject $Bcb);
	map_new $BObject->{"FileObject"};
	$Object->{"Buffer"}=tohex(eval($BObject->{"Buffer"})-eval($BObject->{"FileOffset"} || 0));
}

sub CcRemapBcb_leave($)
{
my($r)=@_;

	map_new_leave $r;
}

sub unpin($)
{
my($Bcb)=@_;

	return if !(my $BObject=BObject $Bcb);
	delete $BObject->{"CcPinMappedData_double"};
	return if --$BObject->{"ref_count"};
	return if !(my $FObject=FObject $BObject->{"FileObject"});
	if ($BObject->{"type"} eq "map") {
		for my $pin (values(%{$FObject->{"pin"}})) {
			warn "unpin map but CcPinMappedData pin $pin still exists"
					if $Bcb{$pin}->{"by"} eq "CcPinMappedData";
			}
		}
	for my $ref ($BObject->{"type"} eq "map" ? \$FObject->{"map"} : \$FObject->{"pin"}{$BObject->{"FileOffset"}}) {
		warn "Final unpin but ".$BObject->{"type"}." Bcb $Bcb not registered"
						." in FileObject ".$FObject->{"FileObject"}." ref ".($$ref || "<undef>")
				if !defined($BObject->{"OwnerPointer"}) && !($$ref && $$ref eq $Bcb);
		if ($$ref && $$ref eq $Bcb) {
			$$ref=undef();
			delete $FObject->{"pin"}{$BObject->{"FileOffset"}} if $BObject->{"type"} eq "pin";
			}
		}
	delete $Bcb{$Bcb};
}

sub CcUnpinData($)
{
my($Bcb)=@_;

	unpin $Bcb;
}

sub CcUnpinDataForThread($)
{
my($Bcb)=@_;

	unpin $Bcb;
}

sub CcSetBcbOwnerPointer($$)
{
my($Bcb,$OwnerPointer)=@_;

	return if !(my $BObject=BObject $Bcb);
	warn "CcSetBcbOwnerPointer() on map Bcb $Bcb" if $BObject->{"type"} ne "pin";
	return if !(my $FObject=FObject $BObject->{"FileObject"});
	warn "Double CcSetBcbOwnerPointer() on Bcb $Bcb" if defined $BObject->{"OwnerPointer"};
	my $val=$FObject->{"pin"}{$BObject->{"FileOffset"}};
	warn "CcSetBcbOwnerPointer() on unregistered pin Bcb $Bcb" if !$val || $val ne $Bcb;
	delete $FObject->{"pin"}{$BObject->{"FileOffset"}} if $val && $val eq $Bcb;
	$BObject->{"OwnerPointer"}=$OwnerPointer;
}

sub IRP_MJ_CLOSE($)
{
my($FileObject)=@_;

	return if !$FileObject{$FileObject};
	return if !(my $FObject=FObject $FileObject);
	warn "CcUnpinData() not called for FileObject $FileObject before IRP_MJ_CLOSE";
	delete_FObject $FObject;
}


local $_;
my $hex='0x[\dA-F]+';
my %last_irp_mj;
my %enter_leave;
while (<>) {
	chomp;
	s/\r$//;
	# We may get some foreign garbage without '\n' before our debug data line:
	s#^.*?\bTraceFS[(]($hex/$hex)[)]: ## or do { print "$_\n" if $filter; next; };
	my($process_thread)=($1);

	$Object=undef();
	if (/^enter: (\w+)/) {
		$Object={};
		$Object->{"by"}=$1;
		$Object->{"line_enter"}=$.;
		$Object->{"process_thread"}=$process_thread;
		push @{$enter_leave{$process_thread}},$Object;
		}
	if (/^leave: (\w+)/) {
		warn "Empty pop stack during 'leave' of $1" if !($Object=pop @{$enter_leave{$process_thread}});
		warn "Non-matching popped 'by' ".$Object->{"by"}." ne current 'leave' $1"
				if $Object->{"by"} ne $1;
		$Object->{"line_leave"}=$.;
		}

	if (my($FileObject,$AllocationSize,$FileSize,$ValidDataLength,$PinAccess)=
			/^enter: CcInitializeCacheMap: FileObject=($hex),FileSizes,->AllocationSize=($hex),->FileSize=($hex),->ValidDataLength=($hex),PinAccess=([01]),/) {
		CcInitializeCacheMap $FileObject,eval($AllocationSize),eval($FileSize),eval($ValidDataLength),eval($PinAccess);
		next;
		}
	if (my($FileObject,$TruncateSize)=
			/^enter: CcUninitializeCacheMap: FileObject=($hex),TruncateSize=($hex),/) {
		CcUninitializeCacheMap $FileObject,eval($TruncateSize);
		next;
		}

	if (my($FileObject,$AllocationSize,$FileSize,$ValidDataLength)=
			/^enter: CcSetFileSizes: FileObject=($hex),FileSizes,->AllocationSize=($hex),->FileSize=($hex),->ValidDataLength=($hex)/) {
		CcSetFileSizes $FileObject,eval($AllocationSize),eval($FileSize),eval($ValidDataLength);
		next;
		}

	if (my($FileObject,$FileOffset,$Length)=
			/^enter: CcMapData: FileObject=($hex),FileOffset=($hex),Length=($hex),Flags=0x1/) {
		CcMapData $FileObject,eval($FileOffset),eval($Length);
		next;
		}
	if (my($Bcb,$Buffer)=
			/^leave: CcMapData: r=1,Bcb=($hex),Buffer=($hex)/) {
		CcMapData_leave $Bcb,$Buffer;
		next;
		}

	if (my($FileObject,$FileOffset,$Length)=
			/^enter: CcPinRead: FileObject=($hex),FileOffset=($hex),Length=($hex),Flags=0x1/) {
		CcPinRead $FileObject,eval($FileOffset),eval($Length);
		next;
		}
	if (my($Bcb,$Buffer)=
			/^leave: CcPinRead: r=1,Bcb=($hex),Buffer=($hex)/) {
		CcPinRead_leave $Bcb,$Buffer;
		next;
		}

	if (my($FileObject,$FileOffset,$Length)=
			/^enter: CcPreparePinWrite: FileObject=($hex),FileOffset=($hex),Length=($hex),Zero=([01]),Flags=0x1/) {
		CcPreparePinWrite $FileObject,eval($FileOffset),eval($Length);
		next;
		}
	if (my($Bcb,$Buffer)=
			/^leave: CcPreparePinWrite: r=1,Bcb=($hex),Buffer=($hex)/) {
		CcPreparePinWrite_leave $Bcb,$Buffer;
		next;
		}

	if (my($FileObject,$FileOffset,$Length)=
			/^enter: CcPinMappedData: FileObject=($hex),FileOffset=($hex),Length=($hex),Flags=0x1/) {
		CcPinMappedData $FileObject,eval($FileOffset),eval($Length);
		next;
		}
	if (my($Bcb)=
			/^leave: CcPinMappedData: r=1,Bcb=($hex)/) {
		CcPinMappedData_leave $Bcb;
		next;
		}

	if (my($BcbVoid,$Lsn)=
			/^enter: CcSetDirtyPinnedData: BcbVoid=($hex),Lsn=($hex)/) {
		CcSetDirtyPinnedData $BcbVoid,$Lsn;
		next;
		}

	if (my($Bcb)=
			/^enter: CcRemapBcb: Bcb=($hex)/) {
		CcRemapBcb $Bcb;
		next;
		}
	if (my($r)=
			/^leave: CcRemapBcb: r=($hex)/) {
		CcRemapBcb_leave $r;
		next;
		}

	if (my($Bcb)=
			/^enter: CcUnpinData: Bcb=($hex)/) {
		CcUnpinData $Bcb;
		next;
		}
	if (my($Bcb)=
			/^enter: CcUnpinDataForThread: Bcb=($hex)/) {
		CcUnpinDataForThread $Bcb;
		next;
		}

	if (my($Bcb,$OwnerPointer)=
			/^enter: CcSetBcbOwnerPointer: Bcb=($hex),OwnerPointer=($hex)/) {
		CcSetBcbOwnerPointer $Bcb,$OwnerPointer;
		next;
		}

	if (my($irp_mj)=
			/^enter: (IRP_MJ_\w+)/) {
		push @{$last_irp_mj{$process_thread}},$irp_mj;
		next;
		}
	if (my($irp_mj)=
			/^leave: (IRP_MJ_\w+)/) {
		my $irp_mj_last=pop @{$last_irp_mj{$process_thread}};
		warn "Non-matching popped IRP name irp_mj $irp_mj ne irp_mj_last $irp_mj_last"
				if $irp_mj ne $irp_mj_last;
		next;
		}

	if (my($FileObject)=
			/^FileObject=($hex):/) {
		my $aref=$last_irp_mj{$process_thread};
		my $irp_mj_last=${$aref}[$#$aref];
		next if !$irp_mj_last || $irp_mj_last ne "IRP_MJ_CLOSE";
		IRP_MJ_CLOSE $FileObject;
		next;
		}

	print "$_\n" if $filter;
	}
for my $FileObject (keys(%FileObject)) {
	warn "EXIT: still CcInitializeCacheMap FileObject $FileObject";
	next if !(my $FObject=FObject $FileObject);
	delete_FObject $FObject;
	}
