File: Test.pm

package info (click to toggle)
libtickit-perl 0.73-1
  • links: PTS, VCS
  • area: main
  • in suites: bookworm, forky, sid, trixie
  • size: 660 kB
  • sloc: perl: 4,944; makefile: 5
file content (709 lines) | stat: -rw-r--r-- 17,129 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
#  You may distribute under the terms of either the GNU General Public License
#  or the Artistic License (the same terms as Perl itself)
#
#  (C) Paul Evans, 2011-2021 -- leonerd@leonerd.org.uk

package Tickit::Test 0.73;

use v5.14;
use warnings;

use Carp;

use Exporter 'import';

our @EXPORT = qw(
   mk_term
   mk_tickit
   mk_window
   mk_term_and_window
   flush_tickit
   drain_termlog
   clear_term

   resize_term

   presskey
   pressmouse

   is_termlog
   is_display
   is_cursorpos
   is_termctl

   TEXT
   BLANK
   BLANKLINE
   BLANKLINES

   CLEAR
   GOTO
   ERASECH
   SCROLLRECT
   PRINT
   SETPEN
   SETBG
);

use Tickit::Test::MockTerm;
use Tickit::Pen;
use Tickit;

use Tickit::Utils qw( textwidth substrwidth );

use Test::Builder;
use Time::HiRes qw( time );

=head1 NAME

C<Tickit::Test> - unit testing for C<Tickit>-based code

=head1 SYNOPSIS

   use Test::More tests => 2;
   use Tickit::Test;

   use Tickit::Widget::Static;

   my $win = mk_window;

   my $widget = Tickit::Widget::Static->new( text => "Message" );

   $widget->set_window( $win );

   flush_tickit;

   is_termlog( [ SETPEN,
                 CLEAR,
                 GOTO(0,0),
                 SETPEN,
                 PRINT("Message"),
                 SETBG(undef),
                 ERASECH(73) ] );

   is_display( [ "Message" ] );

=head1 DESCRIPTION

This module helps write unit tests for L<Tickit>-based code, such as
L<Tickit::Widget> subclasses. Primarily, it provides a mock terminal
implementation, allowing the code under test to affect a virtual terminal,
whose state is inspectable by the unit test script.

This module is used by the C<Tickit> unit tests themselves, and provided as an
installable module, so that authors of widget subclasses can use it too.

=cut

=head1 FUNCTIONS

=cut

my $term;
my $tickit;

=head2 mk_term

   $term = mk_term

Constructs and returns the mock terminal to unit test with. This object will
be cached and returned if this function is called again. Most unit tests will
want a root window as well; for convenience see instead C<mk_term_and_window>.

The mock terminal usually starts with a size of 80 columns and 25 lines,
though can be overridden by passing named arguments.

   $term = mk_term lines => 30, cols => 100;

=cut

sub mk_term
{
   return $term ||= Tickit::Test::MockTerm->new( @_ );
}

=head2 mk_tickit

   $tickit = mk_tickit

Constructs and returns the mock toplevel L<Tickit> instance to unit test with.
This object will be cached and returned if the function is called again.

Note that this object is not a full implementation and in particular does not
have a real event loop. Any later or timer watches are stored internally and
flushed by the L</flush_tickit> function. This helps isolate unit tests from
real-world effects.

=cut

sub mk_tickit
{
   mk_term;

   return $tickit ||= __PACKAGE__->new(
      term => $term
   );
}

=head2 mk_window

   $win = mk_window

Construct a root window using the mock terminal, to unit test with.

=cut

sub mk_window
{
   mk_tickit;

   my $win = $tickit->rootwin;

   # Clear the method log from ->setup_term
   $term->get_methodlog;

   return $win;
}

=head2 mk_term_and_window

   ( $term, $win ) = mk_term_and_window

Constructs and returns the mock terminal and root window; equivalent to
calling each of C<mk_term> and C<mk_window> separately.

=cut

sub mk_term_and_window
{
   my $term = mk_term( @_ );
   my $win = mk_window;

   return ( $term, $win );
}

## Actual object implementation

use base qw( Tickit );
use Struct::Dumb 0.04;

my @later;
sub watch_later { push @later, $_[1]; return \$later[-1] }

my @timers;
BEGIN {
   struct Timer => [qw( after code )],
      predicate => "is_Timer";
}

sub watch_timer_after {
   # keep list sorted
   @timers = sort { $a->after <=> $b->after } @timers, my $w = Timer( $_[1], $_[2] );
   return $w;
}
sub watch_timer_at {
   watch_timer_after( $_[0], $_[1] - time, $_[2] );
}

sub watch_cancel {
   my ( undef, $w ) = @_;
   if( ref $w eq "REF" ) {
      # later
      @later = grep { \$_ != $w } @later;
   }
   if( is_Timer $w ) {
      @timers = grep { $_ != $w } @timers;
   }
}

sub lines { return $term->lines }
sub cols  { return $term->cols  }

=head2 flush_tickit

   flush_tickit( $timeskip )

Flushes any pending timer or later events in the testing C<Tickit> object.
Because the unit test script has no real event loop, this is required instead,
to flush any pending events.

If the optional C<$timeskip> argument has a nonzero value then any queued
timers will experience the given amount of time passing; any that should now
expire will be invoked.

=cut

sub flush_tickit
{
   my ( $timeskip ) = @_;

   while( @later ) {
      my @queue = @later; @later = ();
      $_->() for @queue;
   }

   if( $timeskip ) {
      $_->after -= $timeskip for @timers;
   }
   while( @timers and $timers[0]->after <= 0 ) {
      ( shift @timers )->code->();
   }

   $tickit->rootwin->flush if $tickit && $tickit->rootwin;
}

=head2 drain_termlog

   drain_termlog

Drains any pending events from the method log used by the C<is_termlog> test.
Useful to clear up non-tested events before running a test.

=cut

sub drain_termlog
{
   $term->get_methodlog;
}

=head2 clear_term

   clear_term

Clears the entire content form the mock terminal. Useful at the end of a
section of tests before starting another one. Don't forget to C<drain_termlog>
afterwards.

=cut

sub clear_term
{
   $term->clear
}

=head2 resize_term

   resize_term( $lines, $cols )

Resize the virtual testing terminal to the size given

=cut

sub resize_term
{
   my ( $lines, $cols ) = @_;
   $term->resize( $lines, $cols );
}

=head2 presskey

   presskey( $type, $str, $mod )

Fire a key event

=cut

sub presskey
{
   my ( $type, $str, $mod ) = @_;

   $term->_emit_key( Tickit::Event::Key->_new( $type, $str, $mod || 0 ) );
}

=head2 pressmouse

   pressmouse( $type, $button, $line, $col, $mod )

Fire a mouse button event

=cut

sub pressmouse
{
   my ( $type, $button, $line, $col, $mod ) = @_;

   $term->_emit_mouse( Tickit::Event::Mouse->_new( $type, $button, $line, $col, $mod || 0 ) );
}

=head1 TEST FUNCTIONS

The following functions can be used like C<Test::More> primitives, in unit
test scripts.

=cut

sub _pen2string
{
   my $pen = shift;
   my %attrs = $pen ? %$pen : ();

   # Normalise requests to reset to default as undef
   defined $attrs{$_} and $attrs{$_} == -1 and undef $attrs{$_} for @Tickit::Pen::INT_ATTRS;
   !$attrs{$_}                             and undef $attrs{$_} for @Tickit::Pen::BOOL_ATTRS;

   # Remove undefs
   defined $attrs{$_} or delete $attrs{$_} for keys %attrs;

   return "{" . join( ",", map { defined $attrs{$_} ? "$_=" . ($attrs{$_} || 0) : "!$_" } sort keys %attrs ) . "}";
}

=head2 is_termlog

   is_termlog( [ @log ], $name )

Asserts that the mock terminal log contains exactly the given sequence of
methods. See also the helper functions below.

Because this test is quite fragile, relying on the exact nature and order of
drawing methods invoked on the terminal, it should only be used rarely. Most
normal cases of widget unit tests should instead only use C<is_display>.

   is_termlog( { $pos => \@log, ... }, $name )

The expectation HASH is keyed by strings giving a GOTO position, and the test
asserts that a sequence of GOTO and other operations were performed equivalent
to the expectations given in the HASH.

This differs from the simpler ARRAY reference form by being somewhat more
robust against rendering order. It checks that every expectation sequence
happens exactly once, but does not care which order the sections happen in.

   is_termlog( { "0,0" => [ PRINT("Hello") ],
                 "0,6" => [ PRINT("World!") ] } );

=cut

sub _step_to_text
{
   my ( $step ) = @_;

   return "none" unless defined $step;

   my ( $op, @args ) = @$step;

   if( $op eq "setpen" ) {
      return "$op(" . _pen2string( $args[0] ) . ")";
   }
   else {
      return "$op(" . join( ",", map { defined $_ ? $_ =~ m/^-?\d+$/ ? $_ : qq("$_") : "undef" } @args ) . ")";
   }
}

sub _steps_ok
{
   my ( $tb, $want_log, $got_log, $stop_before_GOTO, $name ) = @_;

   my $prev_line;

   for( my $idx = 0; @$want_log or @$got_log; $idx++ ) {
      my $got_line;

      if( $stop_before_GOTO and @$got_log and $got_log->[0][0] eq "goto" ) {
         $got_line = undef;
      }
      else {
         $got_line = shift @$got_log;
      }

      my $want_line = shift @$want_log;

      if( $want_line and $want_line->[0] eq "setpen_bg" and
          $got_line  and $got_line->[0] eq "setpen" ) {
         $got_line = [ setpen_bg => $got_line->[1]->{bg} ];
      }

      $_ = _step_to_text($_) for $want_line, $got_line;

      if( $want_line eq $got_line ) {
         $prev_line = $want_line;

         return 1 if $stop_before_GOTO and @$got_log and $got_log->[0][0] eq "goto";
         next;
      }

      local $" = ",";
      my $ok = $tb->ok( 0, $name );
      $tb->diag( "Expected terminal operation $want_line, got $got_line at step $idx" );
      $tb->diag( "  after $prev_line" ) if defined $prev_line;
      return $ok;
   }

   return 1;
}

sub is_termlog
{
   my ( $log, $name ) = @_;

   my $tb = Test::Builder->new;

   my @got_log = $term->get_methodlog;

   if( ref $log eq "ARRAY" ) {
      local $Test::Builder::Level = $Test::Builder::Level + 1;
      return unless _steps_ok( $tb, $log, \@got_log, 0, $name );
   }
   elsif( ref $log eq "HASH" ) {
      my %regions = %$log;

      while( keys %regions and @got_log ) {
         if( !$got_log[0]->[0] eq "goto" ) {
            my $ok = $tb->ok( 0, $name );
            $tb->diag( "Expected a goto terminal operation, got " . _step_to_text( $got_log[0] ) );
            return $ok;
         }

         my $pos = sprintf "%d,%d", @{ shift @got_log }[1,2];
         my $want_log = delete $regions{$pos};
         unless( $want_log ) {
            my $ok = $tb->ok( 0, $name );
            $tb->diag( "Did not expect goto($pos)" );
            return $ok;
         }

         local $Test::Builder::Level = $Test::Builder::Level + 1;
         return unless _steps_ok( $tb, $want_log, \@got_log, 1, $name );
      }

      if( keys %regions ) {
         my $ok = $tb->ok( 0, $name );
         $tb->diag( "Expected a goto(" . ( keys %regions )[0] . ", got none" );
         return $ok;
      }
      if( @got_log ) {
         my $ok = $tb->ok( 0, $name );
         $tb->diag( "Expected none, got " . _step_to_text( $got_log[0] ) );
         return $ok;
      }
   }

   return $tb->ok( 1, $name );
}

=head2 is_display

   is_display( $lines, $name )

Asserts that the mock terminal display is exactly that as given by the content
of C<$lines>, which must be an ARRAY reference containing one value for each
line of the display. Each item may either be a plain string, or an ARRAY
reference.

If a plain string is given, it asserts that the characters on display are
those as given by the string (trailing blanks may be omitted). The pen
attributes of the characters do not matter in this case.

   is_display( [ "some lines of",
                 "content here" ] );

If an ARRAY reference is given, it should contain chunks of content from the
C<TEXT> function. Each chunk represents content on display for the
corresponding columns.

   is_display( [ [TEXT("some"), TEXT(" lines of")],
                 "content here" ] );

The C<TEXT> function accepts pen attributes, to assert that the displayed
characters have exactly the attributes given. In character cells containing
spaces, only the C<bg> attribute is tested.

   is_display( [ [TEXT("This is ",fg=>2), TEXT("bold",fg=>2,b=>1) ] ] );

The C<BLANK> function is a shortcut to providing a number of blank cells

   BLANK(20,bg=>1)  is   TEXT("                    ",bg=>1)

The C<BLANKLINE> and C<BLANKLINES> functions are a shortcut to providing an
entire line, or several lines, of blank content. They yield an array reference
or list of array references directly.

   BLANKLINE      is   [TEXT("")]
   BLANKLINES(3)  is   [TEXT("")], [TEXT("")], [TEXT("")]

=cut

sub is_display
{
   my ( $lines, $name ) = @_;

   my $tb = Test::Builder->new;

   foreach my $line ( 0 .. $term->lines - 1 ) {
      my $want = $lines->[$line];
      if( ref $want ) {
         my @chunks = @$want;

         my $col = 0;
         while( $col < $term->cols ) {
            my $chunk = shift @chunks;
            my ( $want_text ) = ref $chunk ? @$chunk : ( $chunk );

            $want_text .= " " x ( $term->cols - $col ) unless defined $want_text and length $want_text;

            my $got_text = $term->get_display_text( $line, $col, textwidth $want_text );
            if( $got_text ne $want_text ) {
               my $ok = $tb->ok( 0, $name );
               $tb->diag( "Display differs on line $line at column $col" );
               $tb->diag( "Got:      '$got_text'" );
               $tb->diag( "Expected: '$want_text'" );
               return $ok;
            }

            my $want_pen = _pen2string( $chunk->[1] );
            my $idx = 0;
            while( $idx < textwidth $want_text ) {
               if( substrwidth( $want_text, $idx, 1 ) eq " " ) {
                  my $want_bg = $chunk->[1]->{bg} // "undef";
                  my $got_bg = $term->get_display_pen( $line, $col )->{bg} // "undef";
                  if( $got_bg ne $want_bg ) {
                     my $ok = $tb->ok( 0, $name );
                     $tb->diag( "Display differs on line $line at column $col" );
                     $tb->diag( "Got pen bg:      $got_bg" );
                     $tb->diag( "Expected pen bg: $want_bg" );
                     return $ok;
                  }
               }
               else {
                  my $got_pen = _pen2string( $term->get_display_pen( $line, $col ) );
                  if( $got_pen ne $want_pen ) {
                     my $ok = $tb->ok( 0, $name );
                     $tb->diag( "Display differs on line $line at column $col" );
                     $tb->diag( "Got pen:      $got_pen" );
                     $tb->diag( "Expected pen: $want_pen" );
                     return $ok;
                  }
               }
               $idx++;
               $col++;
            }
         }
      }
      elsif( defined $want ) {
         my $display_line = $term->get_display_text( $line, 0, $term->cols );
         # pad blanks
         $want = sprintf "% -*s", $term->cols, $want;

         $want eq $display_line and next;

         my $ok = $tb->ok( 0, $name );
         $tb->diag( "Display differs on line $line" );
         $tb->diag( "Got:      '$display_line'" );
         $tb->diag( "Expected: '$want'" );
         return $ok;
      }
      else {
         my $display_line = $term->get_display_text( $line, 0, $term->cols );
         $display_line eq " " x $term->cols and next;

         my $ok = $tb->ok( 0, $name );
         $tb->diag( "Display differs on line $line" );
         $tb->diag( "Got:      '$display_line'" );
         $tb->diag( "Expected: blank" );
         return $ok;
      }
   }

   return $tb->ok( 1, $name );
}

=head2 is_cursorpos

   is_cursorpos( $line, $col, $name )

Asserts that the mock terminal cursor is at the given position.

=cut

sub is_cursorpos
{
   my ( $line, $col, $name ) = @_;

   my $tb = Test::Builder->new;

   my $at_line = $term->line;
   my $at_col  = $term->col;

   my $ok = $tb->ok( $line == $at_line && $col == $at_col, $name );

   $tb->diag( "Expected to be on line $line, actually on line $at_line"   ) if $line != $at_line;
   $tb->diag( "Expected to be on column $col, actually on column $at_col" ) if $col != $at_col;

   return $ok;
}

=head2 is_termctl

   is_termctl( $ctl, $value, $name )

Asserts that the mock terminal has the given value for the given terminal
control. C<$ctl> should be a value from the C<Tickit::Term::TERMPROP_*>
constants.

=cut

sub is_termctl
{
   my ( $ctl, $value, $name ) = @_;

   my $tb = Test::Builder->new;

   # currently all the supported ctls are numeric anyway
   return $tb->is_num( my $got = $term->getctl( $ctl ), $value, $name );
}

sub TEXT
{
   my $text = shift;
   my %attrs = @_;
   return [ $text, \%attrs ];
}

sub BLANK
{
   my $count = shift;
   TEXT(" "x$count, @_);
}

sub BLANKLINE
{
   [ TEXT("", @_) ];
}

sub BLANKLINES
{
   my $count = shift;
   ( BLANKLINE(@_) ) x $count;
}

use constant DEFAULTPEN => map { $_ => undef } @Tickit::Pen::ALL_ATTRS;

=head1 METHOD LOG HELPER FUNCTIONS

The following functions can be used to help write the expected log for a call
to C<is_termlog>.

   CLEAR
   GOTO($line,$col)
   ERASECH($count,$move_to_end)
   SCROLLRECT($top,$left,$lines,$cols,$downward,$rightward)
   PRINT($string)
   SETPEN(%attrs)
   SETBG($bg_attr)

=cut

sub CLEAR      { [ clear => ] }
sub GOTO       { [ goto => $_[0], $_[1] ] }
sub ERASECH    { [ erasech => $_[0], $_[1] || 0 ] }
sub SCROLLRECT { [ scrollrect => @_[0..5] ] }
sub PRINT      { [ print => $_[0] ] }
sub SETPEN     { [ setpen => { DEFAULTPEN, @_ } ] }
sub SETBG      { [ setpen_bg => $_[0] ] }

=head1 AUTHOR

Paul Evans <leonerd@leonerd.org.uk>

=cut

0x55AA;