/[ttyrec]/jsttyplay/Term/Emulator/Parser.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /jsttyplay/Term/Emulator/Parser.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 6 - (show annotations)
Sat Feb 28 22:48:05 2009 UTC (10 years, 5 months ago) by dpavlin
File size: 23040 byte(s)
warn instead of die on unknown esacpe and mode

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

  ViewVC Help
Powered by ViewVC 1.1.26