1 |
dpavlin |
1 |
package Term::Emulator::Parser; |
2 |
|
|
use strict; |
3 |
|
|
use warnings; |
4 |
|
|
|
5 |
|
|
use Carp; |
6 |
|
|
use Storable qw/ dclone /; |
7 |
|
|
|
8 |
|
|
sub ASSERTIONS_ENABLED { 0 } |
9 |
|
|
|
10 |
|
|
# attribute indexes |
11 |
|
|
sub FCOLOR () { 0 } |
12 |
|
|
sub BCOLOR () { 1 } |
13 |
|
|
sub BOLD () { 2 } |
14 |
|
|
sub ULINE () { 3 } |
15 |
|
|
sub REVERSE () { 4 } |
16 |
|
|
|
17 |
|
|
sub new { |
18 |
|
|
my ($class, %args) = @_; |
19 |
|
|
my $self = bless {}, $class; |
20 |
|
|
|
21 |
|
|
my $width = exists $args{'width'} ? delete $args{'width'} : 80; |
22 |
|
|
my $height = exists $args{'height'} ? delete $args{'height'} : 24; |
23 |
|
|
|
24 |
|
|
$self->{'width'} = $width; |
25 |
|
|
$self->{'height'} = $height; |
26 |
|
|
$self->{'extra_chars'} = ''; # buffer for incomplete escape codes |
27 |
|
|
$self->{'output'} = ''; # buffer for output |
28 |
|
|
$self->{'output_enable'} = exists $args{'output_enable'} ? delete $args{'output_enable'} : 1; |
29 |
|
|
$self->{'strict'} = exists $args{'strict'} ? delete $args{'strict'} : 0; |
30 |
|
|
|
31 |
|
|
$self->reset; |
32 |
|
|
|
33 |
|
|
return $self; |
34 |
|
|
} |
35 |
|
|
|
36 |
|
|
sub reset { |
37 |
|
|
my ($self) = @_; |
38 |
|
|
|
39 |
|
|
my $defattr = []; |
40 |
|
|
$defattr->[BCOLOR] = 0; |
41 |
|
|
$defattr->[FCOLOR] = 7; |
42 |
|
|
$defattr->[BOLD] = 0; |
43 |
|
|
$defattr->[ULINE] = 0; |
44 |
|
|
$defattr->[REVERSE] = 0; |
45 |
|
|
|
46 |
|
|
$self->{'buffers'} = [map +{ |
47 |
|
|
data => [ map [map " ", 1 .. $self->width], 1 .. $self->height], |
48 |
|
|
attr => [ map [map [@$defattr], 1 .. $self->width], 1 .. $self->height], |
49 |
|
|
regionlow => 1, |
50 |
|
|
regionhi => $self->height, |
51 |
|
|
tabs => [ grep { $_ > 5 and $_ % 8 == 1 } 1 .. $self->width ], # 9, 17, ... |
52 |
|
|
}, 0..1]; |
53 |
|
|
$self->{'active'} = 0; |
54 |
|
|
|
55 |
|
|
$self->{'curpos'} = [1,1]; |
56 |
|
|
$self->{'cursorstack'} = []; |
57 |
|
|
$self->{'cursorattr'} = [@$defattr]; |
58 |
|
|
$self->{'defaultattr'} = [@$defattr]; |
59 |
|
|
|
60 |
|
|
$self->{'wrapnext'} = 0; |
61 |
|
|
$self->{'autowrap'} = 1; |
62 |
|
|
$self->{'originmode'} = 0; |
63 |
|
|
$self->{'linefeedback'} = 1; |
64 |
|
|
$self->{'insertmode'} = 0; |
65 |
|
|
$self->{'localecho'} = 0; |
66 |
|
|
$self->{'title'} = 'Term::Emulator'; |
67 |
|
|
|
68 |
|
|
return $self; |
69 |
|
|
} |
70 |
|
|
|
71 |
|
|
sub softreset { |
72 |
|
|
my ($self) = @_; |
73 |
|
|
|
74 |
|
|
my $defattr = []; |
75 |
|
|
$defattr->[BCOLOR] = 0; |
76 |
|
|
$defattr->[FCOLOR] = 7; |
77 |
|
|
$defattr->[BOLD] = 0; |
78 |
|
|
$defattr->[ULINE] = 0; |
79 |
|
|
$defattr->[REVERSE] = 0; |
80 |
|
|
|
81 |
|
|
$self->{'curpos'} = [1,1]; |
82 |
|
|
$self->{'cursorstack'} = []; |
83 |
|
|
$self->{'cursorattr'} = [@$defattr]; |
84 |
|
|
$self->{'defaultattr'} = [@$defattr]; |
85 |
|
|
|
86 |
|
|
$self->{'wrapnext'} = 0; |
87 |
|
|
$self->{'autowrap'} = 1; |
88 |
|
|
$self->{'originmode'} = 0; |
89 |
|
|
$self->{'linefeedback'} = 1; |
90 |
|
|
$self->{'insertmode'} = 0; |
91 |
|
|
$self->{'localecho'} = 0; |
92 |
|
|
|
93 |
|
|
return $self; |
94 |
|
|
} |
95 |
|
|
|
96 |
|
|
sub clear { |
97 |
|
|
my ($self) = @_; |
98 |
|
|
for my $y ( 0 .. $self->height-1 ) { |
99 |
|
|
for my $x ( 0 .. $self->width-1 ) { |
100 |
|
|
$self->data->[$y]->[$x] = ' '; |
101 |
|
|
$self->attr->[$y]->[$x] = $self->defaultattr; |
102 |
|
|
} |
103 |
|
|
} |
104 |
|
|
} |
105 |
|
|
|
106 |
|
|
sub switch_to_screen { |
107 |
|
|
my ($self, $index) = @_; |
108 |
|
|
die if $index < 0 or $index > $#{$self->{'buffers'}}; |
109 |
|
|
$self->{'active'} = $index; |
110 |
|
|
$self->wrapnext = 0; |
111 |
|
|
return $self; |
112 |
|
|
} |
113 |
|
|
|
114 |
|
|
sub dowrap { |
115 |
|
|
my ($self) = @_; |
116 |
|
|
|
117 |
|
|
if ( $self->wrapnext ) { |
118 |
|
|
$self->curposx = 1; |
119 |
|
|
|
120 |
|
|
if ( $self->curposy == $self->regionhi ) { |
121 |
|
|
$self->scroll(1); |
122 |
|
|
} else { |
123 |
|
|
$self->curposy++; |
124 |
|
|
} |
125 |
|
|
|
126 |
|
|
$self->wrapnext = 0; |
127 |
|
|
} |
128 |
|
|
} |
129 |
|
|
|
130 |
|
|
sub key { |
131 |
|
|
my ($self, $key) = @_; |
132 |
|
|
die if length($key) > 1; |
133 |
|
|
if ( $key =~ /^[-0-9a-zA-Z<>,.\/?;:'"\[\]\{\}\\\|_=+~`!\@#\$\%^\&*\(\) \t\n]$/ ) { |
134 |
|
|
# printable ascii |
135 |
|
|
$self->output .= $key; |
136 |
|
|
$self->parse_char($key) if $self->localecho; |
137 |
|
|
} else { |
138 |
|
|
# unprintable ascii |
139 |
|
|
$self->output .= $key; |
140 |
|
|
} |
141 |
|
|
} |
142 |
|
|
|
143 |
|
|
sub userinput { |
144 |
|
|
my ($self, $input) = @_; |
145 |
|
|
for my $ch ( split //, $input ) { |
146 |
|
|
$self->key($ch); |
147 |
|
|
} |
148 |
|
|
} |
149 |
|
|
|
150 |
|
|
sub parse { |
151 |
|
|
my ($self, $string) = @_; |
152 |
|
|
|
153 |
|
|
# take our extra incomplete escape codes first |
154 |
|
|
$string = $self->{'extra_chars'} . $string; |
155 |
|
|
|
156 |
|
|
pos($string) = 0; |
157 |
|
|
while ( pos($string) != length($string) ) { |
158 |
|
|
if ( $string =~ /\G\033([-#()*+.\/].)/gc ) { # character set sequence (SCS) |
159 |
|
|
$self->parse_escape($1); |
160 |
|
|
|
161 |
|
|
} elsif ( $string =~ /\G\033(\].*?\007)/gc ) { |
162 |
|
|
$self->parse_escape($1); |
163 |
|
|
|
164 |
|
|
} elsif ( $string =~ /\G\033(\[.*?[a-zA-Z<>])/gc ) { |
165 |
|
|
$self->parse_escape($1); |
166 |
|
|
|
167 |
|
|
} elsif ( $string =~ /\G\033([^\[\]#()])/gc ) { |
168 |
|
|
$self->parse_escape($1); |
169 |
|
|
|
170 |
|
|
} elsif ( $string =~ /\G([^\033])/gcs ) { |
171 |
|
|
$self->parse_char($1); |
172 |
|
|
|
173 |
|
|
} else { last } |
174 |
|
|
} |
175 |
|
|
|
176 |
|
|
# save the incomplete escape codes for the next parse |
177 |
|
|
$self->{'extra_chars'} = substr $string, pos $string; |
178 |
|
|
|
179 |
|
|
return $self; |
180 |
|
|
} |
181 |
|
|
|
182 |
|
|
sub parse_escape { |
183 |
|
|
my ($self, $escape) = @_; |
184 |
|
|
|
185 |
|
|
if ( $escape =~ /^\[([0-9;]*)m$/ ) { |
186 |
|
|
$self->set_color($1); |
187 |
|
|
|
188 |
|
|
} elsif ( $escape =~ /^\]2;(.*)\007$/ ) { |
189 |
|
|
$self->title = $1; # window title |
190 |
|
|
|
191 |
|
|
} elsif ( $escape =~ /^\]1;(.*)\007$/ ) { |
192 |
|
|
# icon title |
193 |
|
|
|
194 |
|
|
} elsif ( $escape =~ /^\]0;(.*)\007$/ ) { |
195 |
|
|
$self->title = $1; # window and icon title |
196 |
|
|
|
197 |
|
|
} elsif ( $escape =~ /^\[(\??)(.+)h$/ ) { |
198 |
|
|
# set mode |
199 |
|
|
my ($q, $c) = ($1, $2); |
200 |
|
|
my @codes = map "$q$_", split /;/, $c; |
201 |
|
|
local $_; |
202 |
|
|
$self->set_mode($_) for @codes; |
203 |
|
|
|
204 |
|
|
} elsif ( $escape =~ /^\[(\??)(.+)l$/ ) { |
205 |
|
|
# reset mode |
206 |
|
|
my ($q, $c) = ($1, $2); |
207 |
|
|
my @codes = map "$q$_", split /;/, $c; |
208 |
|
|
local $_; |
209 |
|
|
$self->reset_mode($_) for @codes; |
210 |
|
|
|
211 |
|
|
} elsif ( 0 |
212 |
|
|
or $escape eq "=" # keypad mode |
213 |
|
|
or $escape eq ">" # keypad mode |
214 |
|
|
or $escape eq "[>" # ??? |
215 |
|
|
or $escape eq "#5" # single-width single-height line |
216 |
|
|
or $escape =~ /^\[.q$/ # leds |
217 |
|
|
or $escape =~ /^[()*+].$/ # set character sets |
218 |
|
|
) { |
219 |
|
|
# ignore |
220 |
|
|
|
221 |
|
|
} elsif ( $escape eq "[c" or $escape eq "[0c" ) { |
222 |
|
|
# report device attributes |
223 |
|
|
$self->output .= "\033[?1;2c"; # I am VT100 with advanced video option |
224 |
|
|
|
225 |
|
|
} elsif ( $escape eq "Z" ) { |
226 |
|
|
# identify terminal (report) |
227 |
|
|
$self->output .= "\033[/Z"; # I am VT52 |
228 |
|
|
|
229 |
|
|
} elsif ( $escape eq "[5n" ) { |
230 |
|
|
# status report |
231 |
|
|
$self->output .= "\033[0n"; # OK - we'll never have hardware problems. |
232 |
|
|
|
233 |
|
|
} elsif ( $escape eq "[6n" ) { |
234 |
|
|
# report cursor position (CPR) |
235 |
|
|
$self->output .= "\033[".$self->curposy.";".$self->curposx."R"; |
236 |
|
|
|
237 |
|
|
} elsif ( $escape eq "7" ) { |
238 |
|
|
# save cursor and attribute |
239 |
|
|
push @{$self->cursorstack}, { |
240 |
|
|
posx => $self->curposx, |
241 |
|
|
posy => $self->curposy, |
242 |
|
|
}; |
243 |
|
|
|
244 |
|
|
} elsif ( $escape eq "8" ) { |
245 |
|
|
# restore cursor and attribute |
246 |
|
|
my $state = pop @{$self->cursorstack}; |
247 |
|
|
if ( defined $state ) { |
248 |
|
|
$self->curposx = $state->{'posx'}; |
249 |
|
|
$self->curposy = $state->{'posy'}; |
250 |
|
|
} |
251 |
|
|
$self->wrapnext = 0; |
252 |
|
|
|
253 |
|
|
} elsif ( $escape =~ /^\[(\d+);(\d+)r$/ ) { |
254 |
|
|
# set margins |
255 |
|
|
my ($lo,$hi) = ($1,$2); |
256 |
|
|
$lo = 1 if $lo < 1; |
257 |
|
|
$hi = $self->height if $hi > $self->height; |
258 |
|
|
$self->regionlow = $lo; |
259 |
|
|
$self->regionhi = $hi; |
260 |
|
|
|
261 |
|
|
} elsif ( $escape eq "[r" ) { |
262 |
|
|
# reset margins |
263 |
|
|
$self->regionlow = 1; |
264 |
|
|
$self->regionhi = $self->height; |
265 |
|
|
|
266 |
|
|
} elsif ( $escape eq "[H" or $escape eq "[f" ) { |
267 |
|
|
# cursor home |
268 |
|
|
$self->curposx = 1; |
269 |
|
|
$self->curposy = 1; |
270 |
|
|
$self->wrapnext = 0; |
271 |
|
|
|
272 |
|
|
} elsif ( $escape =~ /^\[(\d+);(\d+)[Hf]$/ ) { |
273 |
|
|
# cursor set position |
274 |
|
|
my ($y,$x) = ($1,$2); |
275 |
|
|
$x = 1 if $x < 1; $x = $self->width if $x > $self->width; |
276 |
|
|
$y = 1 if $y < 1; $y = $self->height if $y > $self->height; |
277 |
|
|
$self->curposx = $x; |
278 |
|
|
$self->curposy = $y; |
279 |
|
|
$self->wrapnext = 0; |
280 |
|
|
|
281 |
|
|
} elsif ( $escape eq "[K" or $escape eq "[0K" ) { |
282 |
|
|
# erase from cursor to end of line |
283 |
|
|
my $row = $self->data->[$self->curposy-1]; |
284 |
|
|
my $arow = $self->attr->[$self->curposy-1]; |
285 |
|
|
for my $x ( $self->curposx .. $self->width ) { |
286 |
|
|
$row->[$x-1] = ' '; |
287 |
|
|
$arow->[$x-1] = $self->defaultattr; |
288 |
|
|
} |
289 |
|
|
|
290 |
|
|
} elsif ( $escape eq "[1K" ) { |
291 |
|
|
# erase from start of line to cursor |
292 |
|
|
my $row = $self->data->[$self->curposy-1]; |
293 |
|
|
my $arow = $self->attr->[$self->curposy-1]; |
294 |
|
|
for my $x ( 1 .. $self->curposx ) { |
295 |
|
|
$row->[$x-1] = ' '; |
296 |
|
|
$arow->[$x-1] = $self->defaultattr; |
297 |
|
|
} |
298 |
|
|
|
299 |
|
|
} elsif ( $escape eq "[2K" ) { |
300 |
|
|
# erase line |
301 |
|
|
my $row = $self->data->[$self->curposy-1]; |
302 |
|
|
@$row = map ' ', @$row; |
303 |
|
|
my $arow = $self->attr->[$self->curposy-1]; |
304 |
|
|
@$arow = map { +$self->defaultattr } @$arow; |
305 |
|
|
|
306 |
|
|
} elsif ( $escape =~ /^\[(\d*)M$/ ) { |
307 |
|
|
# delete lines |
308 |
|
|
my $erase = $1; |
309 |
|
|
$erase = 1 if not length $erase; |
310 |
|
|
if ( $self->curposy >= $self->regionlow and $self->curposy <= $self->regionhi ) { |
311 |
|
|
$erase = $self->regionhi-$self->curposy+1 if $erase > $self->regionhi-$self->curposy+1; |
312 |
|
|
my $aclone = $self->attr->[$self->regionhi-1]; |
313 |
|
|
splice @{$self->attr}, $self->curposy-1, $erase; |
314 |
|
|
splice @{$self->attr}, $self->regionhi-$erase, 0, map {+ dclone $aclone } 1 .. $erase; |
315 |
|
|
splice @{$self->data}, $self->curposy-1, $erase; |
316 |
|
|
splice @{$self->data}, $self->regionhi-$erase, 0, map [ (' ') x $self->width ], 1 .. $erase; |
317 |
|
|
} |
318 |
|
|
|
319 |
|
|
} elsif ( $escape =~ /^\[(\d*)L$/ ) { |
320 |
|
|
# insert lines |
321 |
|
|
my $insert = $1; |
322 |
|
|
$insert = 1 if not length $insert; |
323 |
|
|
if ( $self->curposy >= $self->regionlow and $self->curposy <= $self->regionhi ) { |
324 |
|
|
$insert = $self->regionhi-$self->curposy+1 if $insert > $self->regionhi-$self->curposy+1; |
325 |
|
|
splice @{$self->attr}, $self->curposy-1, 0, map [ map {+ $self->defaultattr } 1 .. $self->width ], 1 .. $insert; |
326 |
|
|
splice @{$self->attr}, $self->regionhi-$insert, $insert; |
327 |
|
|
splice @{$self->data}, $self->curposy-1, 0, map [ (' ') x $self->width ], 1 .. $insert; |
328 |
|
|
splice @{$self->data}, $self->regionhi-$insert, $insert; |
329 |
|
|
} |
330 |
|
|
|
331 |
|
|
} elsif ( $escape =~ /^\[(\d+)P$/ ) { |
332 |
|
|
# delete characters |
333 |
|
|
my $del = $1; |
334 |
|
|
my $row = $self->data->[$self->curposy-1]; |
335 |
|
|
my $arow = $self->attr->[$self->curposy-1]; |
336 |
|
|
splice @$row, $self->curposx-1, $del; |
337 |
|
|
push @$row, (' ') x $del; |
338 |
|
|
splice @$arow, $self->curposx-1, $del; |
339 |
|
|
push @$arow, map {+ dclone($arow->[-1]) } 1 .. $del; |
340 |
|
|
|
341 |
|
|
} elsif ( $escape =~ /^\[.?J$/ ) { |
342 |
|
|
# erase display |
343 |
|
|
$self->clear; |
344 |
|
|
|
345 |
|
|
} elsif ( $escape eq "[g" or $escape eq "[0g" ) { |
346 |
|
|
# tab clear at cursor position |
347 |
|
|
$self->tabs = [ grep { $_ != $self->curposx } $self->tabs ]; |
348 |
|
|
|
349 |
|
|
} elsif ( $escape eq "[3g" ) { |
350 |
|
|
# clear all tabs |
351 |
|
|
$self->tabs = []; |
352 |
|
|
|
353 |
|
|
} elsif ( $escape eq "H" ) { |
354 |
|
|
# set tab stop at cursor position |
355 |
|
|
$self->tabs = [ sort { $a <=> $b } keys %{{ map +($_,1), @{$self->tabs}, $self->curposx }} ]; |
356 |
|
|
|
357 |
|
|
} elsif ( $escape =~ /^\[(\d*)A$/ ) { |
358 |
|
|
# cursor up |
359 |
|
|
my $n = $1; |
360 |
|
|
$n = 1 unless length $n; |
361 |
|
|
$self->curposy -= $n; |
362 |
|
|
$self->curposy = 1 if $self->curposy < 1; |
363 |
|
|
|
364 |
|
|
} elsif ( $escape =~ /^\[(\d*)B$/ ) { |
365 |
|
|
# cursor down |
366 |
|
|
my $n = $1; |
367 |
|
|
$n = 1 unless length $n; |
368 |
|
|
$self->curposy += $n; |
369 |
|
|
$self->curposy = $self->height if $self->curposy > $self->height; |
370 |
|
|
|
371 |
|
|
} elsif ( $escape =~ /^\[(\d*)C$/ ) { |
372 |
|
|
# cursor forward |
373 |
|
|
my $n = $1; |
374 |
|
|
$n = 1 unless length $n; |
375 |
|
|
$self->curposx += $n; |
376 |
|
|
$self->curposx = $self->width if $self->curposx > $self->width; |
377 |
|
|
|
378 |
|
|
} elsif ( $escape =~ /^\[(\d*)D$/ ) { |
379 |
|
|
# cursor backward |
380 |
|
|
my $n = $1; |
381 |
|
|
$n = 1 unless length $n; |
382 |
|
|
$self->curposx -= $n; |
383 |
|
|
$self->curposx = 1 if $self->curposx < 1; |
384 |
|
|
|
385 |
|
|
} elsif ( $escape eq "D" ) { |
386 |
|
|
# index |
387 |
|
|
$self->dowrap; |
388 |
|
|
$self->curposy++; |
389 |
|
|
if ( $self->curposy > $self->height ) { |
390 |
|
|
$self->curposy--; |
391 |
|
|
$self->scroll(1); |
392 |
|
|
} |
393 |
|
|
|
394 |
|
|
} elsif ( $escape eq "M" ) { |
395 |
|
|
# reverse index |
396 |
|
|
$self->dowrap; |
397 |
|
|
$self->curposy--; |
398 |
|
|
if ( $self->curposy < 1 ) { |
399 |
|
|
$self->curposy++; |
400 |
|
|
$self->scroll(-1); |
401 |
|
|
} |
402 |
|
|
|
403 |
|
|
} elsif ( $escape eq "[!p" ) { |
404 |
|
|
# soft terminal reset |
405 |
|
|
$self->softreset; |
406 |
|
|
|
407 |
|
|
} elsif ( $escape eq "c" ) { |
408 |
|
|
# hard terminal reset |
409 |
|
|
$self->reset; |
410 |
|
|
|
411 |
|
|
} else { |
412 |
|
|
die "unknown escape: '$escape' (".unpack("H*",$escape).")"; |
413 |
|
|
} |
414 |
|
|
|
415 |
|
|
$self->assert; |
416 |
|
|
} |
417 |
|
|
|
418 |
|
|
sub set_mode { |
419 |
|
|
my ($self, $mode) = @_; |
420 |
|
|
|
421 |
|
|
if ( $mode eq "8" # auto repeat |
422 |
|
|
or $mode eq "9" # interlacing |
423 |
|
|
or $mode eq "0" # newline mode or error |
424 |
|
|
or $mode eq "5" # reverse video |
425 |
|
|
or $mode eq "?1" # cursor keys |
426 |
|
|
or $mode eq "?4" # smooth scrolling |
427 |
|
|
or $mode eq "?3" # 132-column mode |
428 |
|
|
or $mode eq "?9" # mouse tracking on button press |
429 |
|
|
or $mode eq "?1000" # mouse tracking on button press and release |
430 |
|
|
or $mode eq "7" # ??? |
431 |
|
|
or $mode eq "6" # ??? |
432 |
|
|
or $mode eq "?25" # ??? |
433 |
|
|
) { |
434 |
|
|
# ignore |
435 |
|
|
|
436 |
|
|
} elsif ( $mode eq "?7" ) { |
437 |
|
|
$self->autowrap = 1; |
438 |
|
|
|
439 |
|
|
} elsif ( $mode eq "?6" ) { |
440 |
|
|
$self->originmode = 1; |
441 |
|
|
die "origin mode not supported"; |
442 |
|
|
|
443 |
|
|
} elsif ( $mode eq "20" ) { |
444 |
|
|
$self->linefeedback = 1; |
445 |
|
|
|
446 |
|
|
} elsif ( $mode eq "4" ) { |
447 |
|
|
$self->insertmode = 1; |
448 |
|
|
|
449 |
|
|
} elsif ( $mode eq "?47" ) { |
450 |
|
|
$self->switch_to_screen(0); # primary |
451 |
|
|
|
452 |
|
|
} elsif ( $mode eq "12" ) { |
453 |
|
|
$self->localecho = 0; |
454 |
|
|
|
455 |
|
|
} else { |
456 |
|
|
die "unknown mode '$mode'"; |
457 |
|
|
} |
458 |
|
|
|
459 |
|
|
$self->assert; |
460 |
|
|
} |
461 |
|
|
|
462 |
|
|
sub reset_mode { |
463 |
|
|
my ($self, $mode) = @_; |
464 |
|
|
|
465 |
|
|
if ( $mode eq "8" # auto repeat |
466 |
|
|
or $mode eq "9" # interlacing |
467 |
|
|
or $mode eq "0" # newline mode or error |
468 |
|
|
or $mode eq "5" # reverse video |
469 |
|
|
or $mode eq "?1" # cursor keys |
470 |
|
|
or $mode eq "?4" # smooth scrolling |
471 |
|
|
or $mode eq "?3" # 80 column mode |
472 |
|
|
or $mode eq "?9" # mouse tracking on button press |
473 |
|
|
or $mode eq "?1000" # mouse tracking on button press and release |
474 |
|
|
or $mode eq "7" # ??? |
475 |
|
|
or $mode eq "6" # ??? |
476 |
|
|
or $mode eq "?25" # ??? |
477 |
|
|
) { |
478 |
|
|
# ignore |
479 |
|
|
|
480 |
|
|
} elsif ( $mode eq "?7" ) { |
481 |
|
|
$self->autowrap = 0; |
482 |
|
|
|
483 |
|
|
} elsif ( $mode eq "?6" ) { |
484 |
|
|
$self->originmode = 0; |
485 |
|
|
|
486 |
|
|
} elsif ( $mode eq "20" ) { |
487 |
|
|
$self->linefeedback = 0; |
488 |
|
|
|
489 |
|
|
} elsif ( $mode eq "4" ) { |
490 |
|
|
$self->insertmode = 0; |
491 |
|
|
|
492 |
|
|
} elsif ( $mode eq "?47" ) { |
493 |
|
|
$self->switch_to_screen(1); # secondary |
494 |
|
|
|
495 |
|
|
} elsif ( $mode eq "12" ) { |
496 |
|
|
$self->localecho = 1; |
497 |
|
|
|
498 |
|
|
} else { |
499 |
|
|
die "unknown mode '$mode'"; |
500 |
|
|
} |
501 |
|
|
|
502 |
|
|
$self->assert; |
503 |
|
|
} |
504 |
|
|
|
505 |
|
|
sub set_color { |
506 |
|
|
my ($self, $colorstring) = @_; |
507 |
|
|
|
508 |
|
|
my $rev = $self->cursorattr->[REVERSE]; |
509 |
|
|
|
510 |
|
|
for my $m ( length $colorstring ? split /;/, $colorstring : '' ) { |
511 |
|
|
if ( not length $m or $m == 0 ) { |
512 |
|
|
@{$self->cursorattr} = @{$self->defaultattr}; |
513 |
|
|
|
514 |
|
|
} elsif ( $m == 1 ) { |
515 |
|
|
$self->cursorattr->[BOLD] = 1; |
516 |
|
|
|
517 |
|
|
} elsif ( $m == 4 ) { |
518 |
|
|
$self->cursorattr->[ULINE] = 1; |
519 |
|
|
|
520 |
|
|
} elsif ( $m >= 30 and $m <= 37 ) { |
521 |
|
|
$self->cursorattr->[$rev ? BCOLOR : FCOLOR] = $m-30; |
522 |
|
|
|
523 |
|
|
} elsif ( $m >= 40 and $m <= 47 ) { |
524 |
|
|
$self->cursorattr->[$rev ? FCOLOR : BCOLOR] = $m-40; |
525 |
|
|
|
526 |
|
|
} elsif ( $m == 7 ) { |
527 |
|
|
if ( ! $self->cursorattr->[REVERSE] ) { |
528 |
|
|
my $fg = $self->cursorattr->[FCOLOR]; |
529 |
|
|
my $bg = $self->cursorattr->[BCOLOR]; |
530 |
|
|
$self->cursorattr->[BCOLOR] = $fg; |
531 |
|
|
$self->cursorattr->[FCOLOR] = $bg; |
532 |
|
|
} |
533 |
|
|
$rev = $self->cursorattr->[REVERSE] = 1; |
534 |
|
|
|
535 |
|
|
} elsif ( $m == 22 ) { |
536 |
|
|
$self->cursorattr->[BOLD] = 0; |
537 |
|
|
|
538 |
|
|
} elsif ( $m == 24 ) { |
539 |
|
|
$self->cursorattr->[ULINE] = 0; |
540 |
|
|
|
541 |
|
|
} elsif ( $m == 27 ) { |
542 |
|
|
if ( $self->cursorattr->[REVERSE] ) { |
543 |
|
|
my $fg = $self->cursorattr->[FCOLOR]; |
544 |
|
|
my $bg = $self->cursorattr->[BCOLOR]; |
545 |
|
|
$self->cursorattr->[BCOLOR] = $fg; |
546 |
|
|
$self->cursorattr->[FCOLOR] = $bg; |
547 |
|
|
} |
548 |
|
|
$rev = $self->cursorattr->[REVERSE] = 0; |
549 |
|
|
|
550 |
|
|
} elsif ( $m == 5 ) { |
551 |
|
|
# blink, ignore |
552 |
|
|
|
553 |
|
|
} else { |
554 |
|
|
warn "unknown color mode $m"; |
555 |
|
|
} |
556 |
|
|
} |
557 |
|
|
} |
558 |
|
|
|
559 |
|
|
sub parse_char { |
560 |
|
|
my ($self, $char) = @_; |
561 |
|
|
if ( $char eq "\015" ) { # carriage return |
562 |
|
|
$self->curposx = 1; |
563 |
|
|
$self->wrapnext = 0; |
564 |
|
|
|
565 |
|
|
} elsif ( $char eq "\012" ) { # line feed |
566 |
|
|
$self->curposx = 1 if $self->linefeedback; |
567 |
|
|
$self->curposy++; |
568 |
|
|
$self->wrapnext = 0; |
569 |
|
|
if ( $self->curposy > $self->regionhi ) { |
570 |
|
|
$self->curposy = $self->regionhi; |
571 |
|
|
$self->scroll(1); |
572 |
|
|
} |
573 |
|
|
|
574 |
|
|
} elsif ( $char eq "\011" ) { # tab |
575 |
|
|
my $to = $self->tabpositionfrom($self->curposx); |
576 |
|
|
while ( $self->curposx != $to ) { |
577 |
|
|
$self->data->[$self->curposy-1]->[$self->curposx-1] = ' '; |
578 |
|
|
$self->attr->[$self->curposy-1]->[$self->curposx-1] = dclone $self->cursorattr; |
579 |
|
|
$self->curposx++; |
580 |
|
|
} |
581 |
|
|
|
582 |
|
|
} elsif ( $char eq "\010" ) { # backspace |
583 |
|
|
$self->curposx--; |
584 |
|
|
if ( $self->curposx == 0 ) { |
585 |
|
|
$self->curposx = 1; |
586 |
|
|
} |
587 |
|
|
|
588 |
|
|
} elsif ( $char =~ /[[:print:]]/ or ord $char > 127 ) { |
589 |
|
|
$self->dowrap if $self->wrapnext; |
590 |
|
|
|
591 |
|
|
if ( $self->insertmode ) { |
592 |
|
|
splice @{$self->data->[$self->curposy-1]}, $self->curposx-1, 0, $char; |
593 |
|
|
pop @{$self->data->[$self->curposy-1]}; |
594 |
|
|
splice @{$self->attr->[$self->curposy-1]}, $self->curposx-1, 0, dclone $self->cursorattr; |
595 |
|
|
pop @{$self->attr->[$self->curposy-1]}; |
596 |
|
|
} else { |
597 |
|
|
$self->data->[$self->curposy-1]->[$self->curposx-1] = $char; |
598 |
|
|
$self->attr->[$self->curposy-1]->[$self->curposx-1] = dclone $self->cursorattr; |
599 |
|
|
} |
600 |
|
|
|
601 |
|
|
my $pos = $self->curpos; |
602 |
|
|
$pos->[0]++; |
603 |
|
|
if ( $pos->[0] > $self->width ) { |
604 |
|
|
$pos->[0] = $self->width; |
605 |
|
|
$self->wrapnext = 1 if $self->autowrap; |
606 |
|
|
} |
607 |
|
|
|
608 |
|
|
} elsif ( ord $char == 0 # null |
609 |
|
|
or ord $char == 7 # bell |
610 |
|
|
or ord $char == 016 # shift out |
611 |
|
|
or ord $char == 017 # shift in |
612 |
|
|
) { |
613 |
|
|
# ignore |
614 |
|
|
|
615 |
|
|
} else { |
616 |
|
|
die ord $char; |
617 |
|
|
} |
618 |
|
|
|
619 |
|
|
$self->assert; |
620 |
|
|
} |
621 |
|
|
|
622 |
|
|
sub scroll { |
623 |
|
|
my ($self, $amt) = @_; |
624 |
|
|
|
625 |
|
|
my @part = splice @{$self->data}, $self->regionlow-1, $self->regionhi-$self->regionlow+1; |
626 |
|
|
my @apart = splice @{$self->attr}, $self->regionlow-1, $self->regionhi-$self->regionlow+1; |
627 |
|
|
|
628 |
|
|
local $_; |
629 |
|
|
if ( $amt > 0 ) { |
630 |
|
|
shift @part for 1 .. $amt; |
631 |
|
|
shift @apart for 1 .. $amt; |
632 |
|
|
push @part, [ (' ') x $self->width ] for 1 .. $amt; |
633 |
|
|
push @apart, [ map {+ $self->defaultattr } 1 .. $self->width ] for 1 .. $amt; |
634 |
|
|
|
635 |
|
|
} elsif ( $amt < 0 ) { |
636 |
|
|
$amt = -$amt; |
637 |
|
|
pop @part for 1 .. $amt; |
638 |
|
|
pop @apart for 1 .. $amt; |
639 |
|
|
unshift @part, [ (' ') x $self->width ] for 1 .. $amt; |
640 |
|
|
unshift @apart, [ map {+ $self->defaultattr } 1 .. $self->width ] for 1 .. $amt; |
641 |
|
|
|
642 |
|
|
} else { die } |
643 |
|
|
|
644 |
|
|
splice @{$self->data}, $self->regionlow-1, 0, @part; |
645 |
|
|
splice @{$self->attr}, $self->regionlow-1, 0, @apart; |
646 |
|
|
|
647 |
|
|
$self->assert; |
648 |
|
|
} |
649 |
|
|
|
650 |
|
|
sub as_string { join "\n", map { join "", @$_ } @{$_[0]->data} } |
651 |
|
|
|
652 |
|
|
sub fg_as_string { join "\n", map { join "", map $_->[FCOLOR], @$_ } @{$_[0]->attr} } |
653 |
|
|
sub bg_as_string { join "\n", map { join "", map $_->[BCOLOR], @$_ } @{$_[0]->attr} } |
654 |
|
|
sub bold_as_string { join "\n", map { join "", map +($_->[BOLD] ? "1" : "0"), @$_ } @{$_[0]->attr} } |
655 |
|
|
sub underline_as_string { join "\n", map { join "", map +($_->[ULINE] ? "1" : "0"), @$_ } @{$_[0]->attr} } |
656 |
|
|
|
657 |
|
|
sub as_termstring { |
658 |
|
|
my ($self) = @_; |
659 |
|
|
|
660 |
|
|
my $defat = $self->defaultattr; |
661 |
|
|
|
662 |
|
|
my $str = "\033[m"; |
663 |
|
|
for my $y ( 0 .. $self->height-1 ) { |
664 |
|
|
|
665 |
|
|
my $drow = $self->data->[$y]; |
666 |
|
|
my $arow = $self->attr->[$y]; |
667 |
|
|
|
668 |
|
|
my $lastattr = $self->defaultattr; |
669 |
|
|
|
670 |
|
|
for my $x ( 0 .. $self->width-1 ) { |
671 |
|
|
if ( join('/', @$lastattr) ne join('/', @{$arow->[$x]}) ) { |
672 |
|
|
|
673 |
|
|
my $at = $arow->[$x]; |
674 |
|
|
|
675 |
|
|
$str .= "\033[".join(';', '', |
676 |
|
|
($at->[BOLD] ? "1" : ()), |
677 |
|
|
($at->[ULINE] ? "4" : ()), |
678 |
|
|
($at->[BCOLOR] != $defat->[BCOLOR] ? 4 . $at->[BCOLOR] : ()), |
679 |
|
|
($at->[FCOLOR] != $defat->[FCOLOR] ? 3 . $at->[FCOLOR] : ()), |
680 |
|
|
)."m"; |
681 |
|
|
|
682 |
|
|
$lastattr = $at; |
683 |
|
|
} |
684 |
|
|
|
685 |
|
|
$str .= $drow->[$x]; |
686 |
|
|
} |
687 |
|
|
|
688 |
|
|
$str .= "\n\033[m"; |
689 |
|
|
} |
690 |
|
|
return $str; |
691 |
|
|
} |
692 |
|
|
|
693 |
|
|
sub tabpositionfrom { |
694 |
|
|
my ($self, $pos) = @_; |
695 |
|
|
for my $tab ( @{$self->tabs} ) { |
696 |
|
|
return $tab if $tab > $pos; |
697 |
|
|
} |
698 |
|
|
return $self->width; |
699 |
|
|
} |
700 |
|
|
|
701 |
|
|
sub assert { |
702 |
|
|
my ($self) = @_; |
703 |
|
|
return unless ASSERTIONS_ENABLED; |
704 |
|
|
confess unless @{$self->{'buffers'}}; |
705 |
|
|
confess if $self->{'active'} < 0; |
706 |
|
|
confess if $self->{'active'} > $#{$self->{'buffers'}}; |
707 |
|
|
confess if $self->curposx <= 0; |
708 |
|
|
confess if $self->curposy <= 0; |
709 |
|
|
confess if $self->curposx > $self->width; |
710 |
|
|
confess if $self->curposy > $self->height; |
711 |
|
|
confess if $self->regionlow <= 0; |
712 |
|
|
confess if $self->regionlow > $self->height; |
713 |
|
|
confess if $self->regionhi <= 0; |
714 |
|
|
confess if $self->regionhi > $self->height; |
715 |
|
|
confess if $self->regionhi < $self->regionlow; |
716 |
|
|
|
717 |
|
|
for my $row ( 0 .. $self->height-1 ) { |
718 |
|
|
confess $row if @{$self->data->[$row]} != $self->width; |
719 |
|
|
confess $row if @{$self->attr->[$row]} != $self->width; |
720 |
|
|
|
721 |
|
|
for my $ch ( 0 .. $self->width-1 ) { |
722 |
|
|
confess "$row,$ch" if length $self->data->[$row]->[$ch] != 1; |
723 |
|
|
confess "$row,$ch" if not ref $self->attr->[$row]->[$ch]; |
724 |
|
|
confess "$row,$ch" if $self->attr->[$row]->[$ch]->[FCOLOR] < 0; |
725 |
|
|
confess "$row,$ch" if $self->attr->[$row]->[$ch]->[BCOLOR] < 0; |
726 |
|
|
confess "$row,$ch" if $self->attr->[$row]->[$ch]->[FCOLOR] > 7; |
727 |
|
|
confess "$row,$ch" if $self->attr->[$row]->[$ch]->[BCOLOR] > 7; |
728 |
|
|
} |
729 |
|
|
} |
730 |
|
|
} |
731 |
|
|
|
732 |
|
|
sub active_buf { $_[0]{'buffers'}[$_[0]->{'active'}] } |
733 |
|
|
|
734 |
|
|
sub data { $_[0]->active_buf->{'data'} } |
735 |
|
|
sub attr { $_[0]->active_buf->{'attr'} } |
736 |
|
|
|
737 |
|
|
sub width { $_[0]->{'width'} } |
738 |
|
|
sub height { $_[0]->{'height'} } |
739 |
|
|
sub defaultattr { [@{$_[0]->{'defaultattr'}}] } |
740 |
|
|
|
741 |
|
|
sub curpos { $_[0]->{'curpos'} } |
742 |
|
|
sub curposx :lvalue { $_[0]->{'curpos'}[0] } |
743 |
|
|
sub curposy :lvalue { $_[0]->{'curpos'}[1] } |
744 |
|
|
sub cursorstack { $_[0]->{'cursorstack'} } |
745 |
|
|
sub cursorattr { $_[0]->{'cursorattr'} } |
746 |
|
|
|
747 |
|
|
sub regionlow :lvalue { $_[0]->active_buf->{'regionlow'} } |
748 |
|
|
sub regionhi :lvalue { $_[0]->active_buf->{'regionhi'} } |
749 |
|
|
|
750 |
|
|
sub tabs :lvalue { $_[0]->active_buf->{'tabs'} } |
751 |
|
|
|
752 |
|
|
sub autowrap :lvalue { $_[0]->{'autowrap'} } |
753 |
|
|
sub wrapnext :lvalue { $_[0]->{'wrapnext'} } |
754 |
|
|
sub originmode :lvalue { $_[0]->{'originmode'} } |
755 |
|
|
sub linefeedback :lvalue { $_[0]->{'linefeedback'} } |
756 |
|
|
sub localecho :lvalue { $_[0]->{'localecho'} } |
757 |
|
|
|
758 |
|
|
sub insertmode :lvalue { $_[0]->{'insertmode'} } |
759 |
|
|
sub title :lvalue { $_[0]->{'title'} } |
760 |
|
|
|
761 |
|
|
sub output :lvalue { my $t = ''; $_[0]->{'output_enable'} ? $_[0]->{'output'} : $t } |
762 |
|
|
sub output_enable { $_[0]->{'output_enable'} } |
763 |
|
|
|
764 |
|
|
1; |
765 |
|
|
|