The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
#
# TCtest.pl
#
# test program to exercise the screen contol module
#
# by Mark Kaehny 1995
# this file is available under the same terms as the perl language 
# distribution. See the Artistic License.
#
# Grabbed by Daniel Podolsky <tpaba@cpan.org> from Term::Screen v.1.01 sources
# to enable test of Term::Screen::Win32

require Term::Screen::Win32;

$scr = new Term::Screen::Win32;

#test clear screen and output
$scr->clrscr();
$scr->puts("Test series for Term::Screen::Win32 module for perl5");

# test cursor movement, output and linking together
$scr->at(2,3)->puts("1. Should be at row 2 col 3 (upper left is 0,0)");

#test current position update
$r = $scr->{'r'}; $c = $scr->{'c'};
$scr->at(3,0)->puts("2. Last position $r $c -- should be 2 50.");

#test rows and cols ( should be updated for signal )
$scr->at(4,0)->puts("3. Screen size: " . $scr->{'rows'} . " rows and " . 
                                           $scr->{'cols'} . " columns.");
# test standout and normal test
$scr->at(6,0);
$scr->puts("4. Testing ")->reverse()->puts("reverse");
$scr->normal()->puts(" mode, ");
$scr->bold()->puts("bold")->normal()->puts(" mode, ");
$scr->bold()->reverse()->puts("and both")->normal()->puts(" together.");

# test clreol 
# first put some stuff up
$line = "0---------10--------20--------30--------40--------50--------60--------70-------";
$scr->at(7,0)->puts("5. Testing clreol - " . 
                      "   The next 2 lines should end at col 20 and 30.");
for (8 .. 10) {$scr->at($_,0)->puts($line);}
$scr->at(8,20)->clreol()->at(9,30)->clreol();

# test clreos
for (11 .. 20) { $scr->at($_,0)->puts($line); }
$scr->at(11,0)->puts("6. Clreos - Hit a key to clear all right and below:");
$scr->getch();
$scr->clreos();

#test insert line and delete line
$scr->at(12,0)->puts("7. Test insert and delete line - 15 deleted, and ...");
for (13 .. 16) { $scr->at($_,0)->puts($_ . substr($line,2)); }
$scr->at(15,0)->dl();
$scr->at(14,0)->il()->at(14,0)->puts("... this is where line 14 was");

# test key_pressed
$scr->at(18,0)->puts("8. Key_pressed - Don't Hit a key in the next 5 seconds: ");
if ($scr->key_pressed(5)) { $scr->puts("HEY A KEY WAS HIT"); } 
  else { $scr->puts("GOOD - NO KEY HIT!"); }
$scr->at(19,0)->puts("Hit a key in next 15 seconds: ");
if ($scr->key_pressed(15)) { $scr->puts("KEY HIT!"); } 
  else { $scr->puts("NO KEY HIT"); }

# test getch
# clear buffer out
$scr->flush_input();
$scr->at(21,0)->puts("Testing getch, Enter Key (q to quit): ")->at(21,40);
$ch = '';
while(($ch = $scr->getch()) ne 'q') 
{
  if (length($ch) == 1) 
    {
      $scr->at(21,50)->clreol()->puts("ord of char is: ");
      $scr->puts(ord($ch))->at(21,40);
    }
  else 
    {
      $scr->at(21,50)->clreol()->puts("function value: $ch");
      $scr->at(21,40);
    }
}

$scr->at(22,0);