# Scripts to test PDL memory handling for leaks.

# Replace DPERL by the name of your debugging perl (built with MSTATS)
# executable.

$DPERL = "/usr/bin/dperl";

sub memtest;

memtest "JUSTPERL",<<'END';
{
	my $a = "sljslfsjeflsejflisejflseijfljesfjsefs" x 10;
	my $b = $a . "foo";
}
END

memtest "ALLOCONE",<<'END';
	my $a = zeroes(100,100);
END

memtest "ADDSAME",<<'END';
	my $a = zeroes(100,100);
	my $b = $a + $a;
END

memtest "ADDONE",<<'END';
	my $a = zeroes(100,100);
	my $b = $a + 1;
END

memtest "ADDONE+AT",<<'END';
	my $a = zeroes(50,50);
	my $b = $a + 1;
	my $c = $b->at(5,5);
END

sub memtest {
	my($name,$scr) = @_;
	my @res;
	for(1,51,101) {
	my $res;
		print "$name ROUND $_\n";
	open FILE, ">tmpscript";
	print FILE "BEGIN{print `pwd`;};\$|=1; use blib '../..'; use PDL; 
	  for(\$i = 0; \$i < $_; \$i++) { $scr } print \"FINISHED\\n\";
	";
	close FILE;
	$ENV{PERL_DEBUG_MSTATS}=2;
	open(PIPE,"dperl tmpscript 2>&1 |")
		or die "Couldn't open pipe";
	{ local $_; while(<PIPE>) { $res .= $_ }; }
	close PIPE;
#	print "RESULT: $res ENDRESULT\n";;
	$res =~ /FINISHED/ or die "Couldn't run script!";
	push @res,$res;
	}
	my $tres = join '', 
	map {
		/(Memory allocation statistics after execu.*Total sb[^\n]*$)/s
		 or die "Output $_ doesn't match pattern\n";
		my $str = $1;
		$str =~ /\n([^\n]*used[^\n]*\n)/m
		 or die "Output $str doesn't match pattern2\n";
		$1;
	} @res;
	print "-----------------------\nRES $name:\n$tres\n";
}