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
|
#!/usr/bin/perl
#
# Basic functions used by most of the test scripts.
#
sub run_tests {
my ($testref) = @_;
my @tests = @$testref;
my ($nt, $i);
$nt = scalar @tests; # number of sub-tests
foreach $i (1 .. $nt) {
my $testref = shift @tests;
my ($cols, $rows, $text, @output) = @$testref;
my ($ncols, $nrows, $row, $col, $settings);
my ($line, $aline, $alineref, $galine, $passed);
$settings = undef;
if (ref $cols) {
($settings, $cols, $rows, $text, @output) = @$testref;
}
print "$i..$nt\n";
my $vt = Term::VT102->new ('cols' => $cols, 'rows' => $rows);
($ncols, $nrows) = $vt->size ();
if (($cols != $ncols) or ($rows != $nrows)) {
print "not ok $i\n";
warn "returned size: $ncols x $nrows, wanted $cols x $rows\n";
next;
}
if (defined $settings) {
foreach (keys %$settings) {
if (
!defined $vt->option_set ($_,$settings->{$_})
) {
print "not ok $i\n";
warn "failed to set option: $_";
}
}
}
$vt->process ($text);
$row = 0;
$passed = 1;
while ($#output > 0) {
$line = shift @output;
if (ref $output[0]) {
$alineref = shift @output;
$aline = "";
foreach (@$alineref) {
$aline .= $vt->attr_pack (@$_);
}
} else {
$alineref = undef;
}
$row ++;
if ($vt->row_text ($row) ne $line) {
$passed = 0;
print STDERR "test $i: row $row incorrect, got '" .
show_text ($vt->row_text ($row)) . "', expected '" .
show_text ($line) . "'\n";
next;
}
next if (not defined $alineref);
$galine = $vt->row_attr ($row);
for ($col = 0; $col < $cols; $col ++) {
if (substr ($aline, 2 * $col, 2) ne substr ($galine, 2 * $col, 2)) {
$passed = 0;
print STDERR "test $i: row $row col " . ($col + 1) .
" attributes incorrect, got '" .
show_attr ($vt, substr ($galine, 2 * $col, 2)) .
"', expected '" .
show_attr ($vt, substr ($aline, 2 * $col, 2)) . "'\n";
next;
}
}
}
if ($passed == 0) {
print "not ok $i\n";
print STDERR "screen contents ($cols x $rows):\n";
for (my $dumprow = 1; $dumprow <= $rows; $dumprow++) {
print STDERR "[" . $vt->row_plaintext ($dumprow) . "]\n";
}
} else {
print "ok $i\n";
}
}
}
sub show_text {
my ($text) = @_;
return "" if (not defined $text);
$text =~ s/([^\040-\176])/sprintf ("\\%o", ord ($1))/ge;
return $text;
}
sub show_attr {
my ($vt, $attr) = @_;
my ($fg,$bg,$bo,$fa,$st,$ul,$bl,$rv) = $vt->attr_unpack ($attr);
my $str = "$fg-$bg";
$str .= "b" if ($bo != 0);
$str .= "f" if ($fa != 0);
$str .= "s" if ($st != 0);
$str .= "u" if ($ul != 0);
$str .= "F" if ($bl != 0);
$str .= "r" if ($rv != 0);
return $str . "-" . sprintf ("%04X", unpack ('S', $attr));
}
1;
# EOF
|
