| 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 |
warn "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 |
warn "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 |
warn "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 |
|
Parent Directory
| 
Revision Log