Text::Editor::Vip::Buffer::Test - Support functions for testing

  use Test::More qw(no_plan);

  use Text::Editor::Vip::Buffer ;
  use Text::Editor::Vip::Buffer::Test ;

  my $buffer = new Text::Editor::Vip::Buffer() ;

  is(TestDoUndo('$buffer->DeleteLine(3) ;', '$buffer->Insert("Line 1\nLine 2\nLine 3\nLine 4") ;'), 1, 'test undo after DeleteLine') ;

	Khemir Nadim ibn Hamouda
	CPAN ID: NKH
	mailto:nadim@khemir.net
	http:// no web site

package Text::Editor::Vip::Buffer::Test;

use strict;
use warnings ;

use Data::TreeDumper ;
use Data::Hexdumper ;
use Text::Diff ;

use Test::More ;

BEGIN 
{
use Exporter ();
use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
$VERSION     = 0.01;
@ISA         = qw (Exporter);
@EXPORT      = qw (DiagBuffers TestSerialisation TestDoUndo CompareBuffers);
@EXPORT_OK   = qw ();
%EXPORT_TAGS = ();
}

#-------------------------------------------------------------------------------

sub DiagBuffers
{

my ($package, $file_name, $line) = caller() ;

my $buffer  = shift ;
my $comment = shift || '' ;

diag("\n$comment\n>>>>>\n" . $buffer->GetText() . "<<<<<\n") ;
}

#------------------------------------------------------------------------------------------------- 

sub TestSerialisation
{

my $buffer = shift ;
my $new_buffer = $buffer->new() ;

my $do_buffer = $buffer->GetDoScript() ;
if($new_buffer->Do($do_buffer))
	{
	unless(CompareBuffers("Doing (original, new)", $buffer, $new_buffer))
		{
		#~ print "Do buffer:\n" . join("\n", grep{$_ !~ /\s+#/} split("\n",$do_buffer)) . "\n" ;
		#~ print "Do buffer:\n" . $do_buffer ;
		return(0) ;
		}
		
	}
else
	{
	diag("\nFailed Do!\n") ;
	return(0) ;
	}
	
return(1) ;
}

#------------------------------------------------------------------------------------------------- 

sub TestDoUndo
{

my $script = shift ;

my $buffer_original = new Text::Editor::Vip::Buffer();
my $buffer_done     = new Text::Editor::Vip::Buffer();
my $buffer_undone   = new Text::Editor::Vip::Buffer();

my $setup_script = shift ;
my ($result, $message)  ;

for($buffer_original, $buffer_done, $buffer_undone)
	{
	($result, $message) = $_->Do($setup_script) ;
	die "TestDoUndo: Invalid setup script!\n$message" unless $result ;
	}

my $pos = $buffer_done->GetDoPosition() ;
($result, $message) = $buffer_done->Do($script) ;

my $error = 0 ;

if($result)
	{
	my $do_buffer = $buffer_done->GetDoScript($pos) ;
	my $undo_buffer = $buffer_done->GetUndoScript($pos) ;
	
	# test "do" perl script
	($result, $message) = $buffer_undone->Do($do_buffer) ;
	
	if($result)
		{
		ok(1, 'Valid perl do script') ;
		if(CompareBuffers("Doing (done, undone)", $buffer_done, $buffer_undone))
			{
			ok(1, 'perl do script OK')
			}
		else
			{
			$error++ ;
			diag("\nWould you like a do buffer dump?") ;
			my $answer = <STDIN> ;
			$answer = 'y' unless defined $answer ;
			
			if($answer ne "\n")
				{
				diag("do buffer:\n$do_buffer\n<<<<<\n") ;
				}
				
			}
		}
	else
		{
		$error++ ;
		diag($message) ;
		}
	
	# test "undo" perl script
	($result, $message) = $buffer_undone->Do($undo_buffer) ;
	
	if($result)
		{
		ok(1, 'Valid perl undo script') ;
		
		if(CompareBuffers("Undoing (original, undone)", $buffer_original, $buffer_undone))
			{
			ok(1, 'perl undo script OK')
			}
		else
			{
			$error++ ;
			diag("\nWould you like a do and an undo buffer dump?") ;
			my $answer = <STDIN> ;
			$answer = 'y' unless defined $answer ;
			
			if($answer ne "\n")
				{
				diag("do buffer:\n$do_buffer\n<<<<<\n") ;
				diag("Undo buffer:\n$undo_buffer\n<<<<<\n") ;
				}
				
			}
		}
	else
		{
		$error++ ;
		diag($message) ;
		}
		
	if($error)
		{
		diag("\nBuffer original:\n" . $buffer_original->GetText() . "\n<<<<<\n") ;
		diag("\nBuffer done:\n" . $buffer_done->GetText() . "\n<<<<<\n") ;
		diag("\nBuffer undone:\n" . $buffer_undone->GetText() . "\n<<<<<\n") ;
		}
	}
else
	{
	diag("\n Couldn't run TestDoUndo test:\n" . $message) ;
	$error++ ;
	}

return(!$error) ;
}

#------------------------------------------------------------------------------------------------- 

sub CompareBuffers
{

# help functin to compare two buffers

my ($message, $lhb, $rhb) = @_ ;

my ($lhb_line, $lhb_character, $lhb_text) = ($lhb->GetModificationPosition(), $lhb->GetText()) ;
my ($rhb_line, $rhb_character, $rhb_text) = ($rhb->GetModificationPosition(), $rhb->GetText()) ;

# position
if ($lhb_line != $rhb_line || $lhb_character != $rhb_character)
	{
	diag("\n$message: Positon is different! ($lhb_line, $lhb_character) != ($rhb_line, $rhb_character).\n") ;
	
	diag("\nBuffer 1:\n" . hexdump(data => $lhb_text, start_position => 0, end_position => 100)) ;
	diag("\nBuffer 2:\n" . hexdump(data => $rhb_text, start_position => 0, end_position => 100)) ;
	
	return(0) ;
	}

# content
if($lhb_text ne $rhb_text)
	{
	diag("$message\n" . diff(\$lhb_text, \$rhb_text, {STYLE => 'Table'})) ;
	
	diag("\nBuffer 1:\n" . hexdump(data => $lhb_text, start_position => 0, end_position => 100)) ;
	diag("\nBuffer 2:\n" . hexdump(data => $rhb_text, start_position => 0, end_position => 100)) ;
	
	return(0) ;
	}

return(1) ;
}

#-------------------------------------------------------------------------------

sub CompareText
{

my $buffer = shift ;
my $text = shift ;

my $diff =  diff
		(
		  \($buffer->GetText())
		, \$text
		, {STYLE => 'Table', FILENAME_A => "Buffer", FILENAME_B => "Expected", INDEX_LABEL => "Ln"}
		) ;

$diff = "\n" . $diff unless $diff eq '' ;

return($diff) ;
}

#-------------------------------------------------------------------------------

sub PrintPositionData
{

my $buffer = shift ;
my $message = shift || '' ;

my ($package, $file_name, $line) = caller() ;
$message .= " @ '$file_name:$line'" ;

print "\n$message\n\tPosition: " .join(", ", $buffer->GetModificationPosition()) ;
print "\n\tSelection: " . join(", ", $buffer->GetSelectionBoundaries()) . "\n" ;
}

#-------------------------------------------------------------------------------

1;