The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

use strict;
use warnings;
use utf8;

use Test::More;
use Tickit::Test;

use Tickit::RenderBuffer qw( LINE_SINGLE );

use Tickit::Pen;
use Tickit::Rect;

my $term = mk_term;

my $rb = Tickit::RenderBuffer->new(
   lines => 10,
   cols  => 20,
);

my $mask = Tickit::Rect->new(
   top   => 3,
   left  => 5,
   lines => 4,
   cols  => 6,
);

# mask over text
{
   $rb->mask( $mask );

                       #   MMMMMM
   $rb->text_at( 3, 2, "ABCDEFG" );      # before
   $rb->text_at( 4, 6,     "HI" );       # inside
   $rb->text_at( 5, 8,       "JKLMN" );  # after
   $rb->text_at( 6, 2, "OPQRSTUVWXYZ" ); # spanning

   $rb->flush_to_term( $term );
   is_termlog( [ GOTO(3, 2), SETPEN(), PRINT("ABC"),
                 GOTO(5,11), SETPEN(), PRINT("MN"),
                 GOTO(6, 2), SETPEN(), PRINT("OPQ"),
                    GOTO(6,11), SETPEN(), PRINT("XYZ") ],
              '@methods for text over mask' );
}

# mask over erase
{
   $rb->mask( $mask );

   $rb->erase_at( 3, 2,  6 ); # before
   $rb->erase_at( 4, 6,  2 ); # inside
   $rb->erase_at( 5, 8,  5 ); # after
   $rb->erase_at( 6, 2, 12 ); # spanning

   $rb->flush_to_term( $term );
   is_termlog( [ GOTO(3, 2), SETPEN(), ERASECH(3),
                 GOTO(5,11), SETPEN(), ERASECH(2),
                 GOTO(6, 2), SETPEN(), ERASECH(3),
                    GOTO(6,11), SETPEN(), ERASECH(3) ],
              '@methods for erase over mask' );
}

# mask over lines
{
   $rb->mask( $mask );

   $rb->hline_at( 3, 2,  8, LINE_SINGLE );
   $rb->hline_at( 4, 6,  8, LINE_SINGLE );
   $rb->hline_at( 5, 8, 13, LINE_SINGLE );
   $rb->hline_at( 6, 2, 14, LINE_SINGLE );

   $rb->flush_to_term( $term );
   is_termlog( [ GOTO(3, 2), SETPEN(), PRINT("╶──"),
                 GOTO(5,11), SETPEN(), PRINT("──╴"),
                 GOTO(6, 2), SETPEN(), PRINT("╶──"),
                    GOTO(6,11), SETPEN(), PRINT("───╴") ],
              '@methods for erase over mask' );
}

# restore removes masks
{
   {
      $rb->save;

      $rb->mask( $mask );
      $rb->text_at( 3, 0, "A"x20 );

      $rb->restore;
   }

   $rb->text_at( 4, 0, "B"x20 );

   $rb->flush_to_term( $term );
   is_termlog( [ GOTO(3, 0), SETPEN(), PRINT("AAAAA"),
                    GOTO(3,11), SETPEN(), PRINT("AAAAAAAAA"),
                 GOTO(4, 0), SETPEN(), PRINT("BBBBBBBBBBBBBBBBBBBB") ],
              '@methods for text_at after save/mask/remove' );
}

# translate over mask
{
   $rb->mask( Tickit::Rect->new( top => 2, left => 2, lines => 1, cols => 1 ) );

   { $rb->save; $rb->translate( 0, 0 ); $rb->text_at( 0, 0, "A" ); $rb->restore }
   { $rb->save; $rb->translate( 0, 2 ); $rb->text_at( 0, 0, "B" ); $rb->restore }
   { $rb->save; $rb->translate( 2, 0 ); $rb->text_at( 0, 0, "C" ); $rb->restore }
   { $rb->save; $rb->translate( 2, 2 ); $rb->text_at( 0, 0, "D" ); $rb->restore }

   $rb->flush_to_term( $term );
   is_termlog( [ GOTO(0,0), SETPEN(), PRINT("A"),
                 GOTO(0,2), SETPEN(), PRINT("B"),
                 GOTO(2,0), SETPEN(), PRINT("C"),
                 # D was masked
              ],
              '@methods for text_at after mask over translate' );
}

# mask out of limits doesn't segv
{
   $rb->save;

   # Too big
   $rb->mask( Tickit::Rect->new( top => 0, left => 0, lines => 50, cols => 200 ) );

   # Negative
   $rb->mask( Tickit::Rect->new( top => -10, left => -20, lines => 5, cols => 20 ) );

   $rb->restore;
}

done_testing;