1# ---------------------------------------------------------------------- 2# Curses::UI::Common 3# 4# (c) 2001-2002 by Maurice Makaay. All rights reserved. 5# (c) 2003-2005 by Marcus Thiesen et al. 6# This file is part of Curses::UI. Curses::UI is free software. 7# You can redistribute it and/or modify it under the same terms 8# as perl itself. 9# 10# Currently maintained by Marcus Thiesen 11# e-mail: marcus@cpan.thiesenweb.de 12# ---------------------------------------------------------------------- 13 14# TODO: fix dox 15 16package Curses::UI::Common; 17 18use strict; 19use Term::ReadKey; 20use Curses; 21require Exporter; 22 23use vars qw( 24 @ISA 25 @EXPORT_OK 26 @EXPORT 27 $VERSION 28); 29 30$VERSION = '1.10'; 31 32@ISA = qw( 33 Exporter 34); 35 36@EXPORT = qw( 37 keys_to_lowercase 38 text_wrap 39 text_draw 40 text_length 41 text_chop 42 scrlength 43 split_to_lines 44 text_dimension 45 CUI_ESCAPE CUI_SPACE CUI_TAB 46 WORDWRAP NO_WORDWRAP 47); 48 49# ---------------------------------------------------------------------- 50# Misc. routines 51# ---------------------------------------------------------------------- 52 53sub parent() 54{ 55 my $this = shift; 56 $this->{-parent}; 57} 58 59sub root() 60{ 61 my $this = shift; 62 my $root = $this; 63 while (defined $root->{-parent}) { 64 $root = $root->{-parent}; 65 } 66 return $root; 67} 68 69sub accessor($;$) 70{ 71 my $this = shift; 72 my $key = shift; 73 my $value = shift; 74 75 $this->{$key} = $value if defined $value; 76 return $this->{$key}; 77} 78 79sub keys_to_lowercase($;) 80{ 81 my $hash = shift; 82 83 my $copy = {%$hash}; 84 while (my ($k,$v) = each %$copy) { 85 $hash->{lc $k} = $v; 86 } 87 88 return $hash; 89} 90 91# ---------------------------------------------------------------------- 92# Text processing 93# ---------------------------------------------------------------------- 94 95sub split_to_lines($;) 96{ 97 # Make $this->split_to_lines() possible. 98 shift if ref $_[0]; 99 my $text = shift; 100 101 # Break up the text in lines. IHATEBUGS is 102 # because a split with /\n/ on "\n\n\n" would 103 # return zero result :-( 104 my @lines = split /\n/, $text . "IHATEBUGS"; 105 $lines[-1] =~ s/IHATEBUGS$//g; 106 107 return \@lines; 108} 109 110sub scrlength($;) 111{ 112 # Make $this->scrlength() possible. 113 shift if ref $_[0]; 114 my $line = shift; 115 116 return 0 unless defined $line; 117 118 my $scrlength = 0; 119 for (my $i=0; $i < length($line); $i++) 120 { 121 my $chr = substr($line, $i, 1); 122 $scrlength++; 123 if ($chr eq "\t") { 124 while ($scrlength%8) { 125 $scrlength++; 126 } 127 } 128 } 129 return $scrlength; 130} 131 132# Contstants for text_wrap() 133sub NO_WORDWRAP() { 1 } 134sub WORDWRAP() { 0 } 135 136sub text_wrap($$;) 137{ 138 # Make $this->text_wrap() possible. 139 shift if ref $_[0]; 140 my ($line, $maxlen, $wordwrap) = @_; 141 $wordwrap = WORDWRAP unless defined $wordwrap; 142 $maxlen = int $maxlen; 143 144 return [""] if $line eq ''; 145 146 my @wrapped = (); 147 my $len = 0; 148 my $wrap = ''; 149 150 # Special wrapping is needed if the line contains tab 151 # characters. These should be expanded to the TAB-stops. 152 if ($line =~ /\t/) 153 { 154 CHAR: for (my $i = 0; $i <= length($line); $i++) 155 { 156 my $nextchar = substr($line, $i, 1); 157 158 # Find the length of the string in case the 159 # next character is added. 160 my $newlen = $len + 1; 161 if ($nextchar eq "\t") { while($newlen%8) { $newlen++ } } 162 163 # Would that go beyond the end of the available width? 164 if ($newlen > $maxlen) 165 { 166 if ($wordwrap == WORDWRAP 167 and $wrap =~ /^(.*)([\s])(\S+)$/) 168 { 169 push @wrapped, $1 . $2; 170 $wrap = $3; 171 $len = scrlength($wrap) + 1; 172 } else { 173 $len = 1; 174 push @wrapped, $wrap; 175 $wrap = ''; 176 } 177 } else { 178 $len = $newlen; 179 } 180 $wrap .= $nextchar; 181 } 182 push @wrapped, $wrap if defined $wrap; 183 184 # No tab characters in the line? Then life gets a bit easier. We can 185 # process large chunks at once. 186 } else { 187 my $idx = 0; 188 189 # Line shorter than allowed? Then return immediately. 190 return [$line] if length($line) < $maxlen; 191 return ["internal wrap error: wraplength undefined"] 192 unless defined $maxlen; 193 194 CHUNK: while ($idx < length($line)) 195 { 196 my $next = substr($line, $idx, $maxlen); 197 if (length($next) < $maxlen) 198 { 199 push @wrapped, $next; 200 last CHUNK; 201 } 202 elsif ($wordwrap == WORDWRAP) 203 { 204 my $space_idx = rindex($next, " "); 205 if ($space_idx == -1 or $space_idx == 0) 206 { 207 push @wrapped, $next; 208 $idx += $maxlen; 209 } else { 210 push @wrapped, substr($next, 0, $space_idx + 1); 211 $idx += $space_idx + 1; 212 } 213 } else { 214 push @wrapped, $next; 215 $idx += $maxlen; 216 } 217 } 218 } 219 220 return \@wrapped; 221} 222 223sub text_tokenize { 224 my ($text) = @_; 225 226 my @tokens = (); 227 while ($text ne '') { 228 if ($text =~ m/^<\/?[a-zA-Z0-9_]+>/s) { 229 push(@tokens, $&); 230 $text = $'; 231 } 232 elsif ($text =~ m/^.+?(?=<\/?[a-zA-Z0-9_]+>)/s) { 233 push(@tokens, $&); 234 $text = $'; 235 } 236 else { 237 push(@tokens, $text); 238 last; 239 } 240 } 241 return @tokens; 242} 243 244sub text_draw($$;) 245{ 246 my $this = shift; 247 my ($y, $x, $text) = @_; 248 249 if ($this->{-htmltext}) { 250 my @tokens = &text_tokenize($text); 251 foreach my $token (@tokens) { 252 if ($token =~ m/^<(standout|reverse|bold|underline|blink|dim)>$/s) { 253 my $type = $1; 254 if ($type eq 'standout') { $this->{-canvasscr}->attron(A_STANDOUT); } 255 elsif ($type eq 'reverse') { $this->{-canvasscr}->attron(A_REVERSE); } 256 elsif ($type eq 'bold') { $this->{-canvasscr}->attron(A_BOLD); } 257 elsif ($type eq 'underline') { $this->{-canvasscr}->attron(A_UNDERLINE); } 258 elsif ($type eq 'blink') { $this->{-canvasscr}->attron(A_BLINK); } 259 elsif ($type eq 'dim') { $this->{-canvasscr}->attron(A_DIM); } 260 } elsif ($token =~ m/^<\/(standout|reverse|bold|underline|blink|dim)>$/s) { 261 my $type = $1; 262 if ($type eq 'standout') { $this->{-canvasscr}->attroff(A_STANDOUT); } 263 elsif ($type eq 'reverse') { $this->{-canvasscr}->attroff(A_REVERSE); } 264 elsif ($type eq 'bold') { $this->{-canvasscr}->attroff(A_BOLD); } 265 elsif ($type eq 'underline') { $this->{-canvasscr}->attroff(A_UNDERLINE); } 266 elsif ($type eq 'blink') { $this->{-canvasscr}->attroff(A_BLINK); } 267 elsif ($type eq 'dim') { $this->{-canvasscr}->attroff(A_DIM); } 268 # Tags: (see, man 5 terminfo) 269 # | <4_ACS_VLINE> -- Vertical line (4 items). 270 # -- <5_ACS_HLINE> -- Horizontal line (5 items). 271 # ` <12_ACS_TTEE> -- Tee pointing down (12 items). 272 # ~ <ACS_BTEE> -- Tee pointing up (1 item). 273 # + <ACS_PLUS> -- Large plus or crossover (1 item). 274 # ------------------------------------------------------------------ 275 } elsif ($token =~ m/^<(\d*)_?(ACS_HLINE|ACS_VLINE|ACS_TTEE|ACS_BTEE|ACS_PLUS)>$/s) { 276 no strict 'refs'; 277 my $scrlen = ($1 || 1); 278 my $type = &{ $2 }; 279 $this->{-canvasscr}->hline( $y, $x, $type, $scrlen ); 280 $x += $scrlen; 281 } else { 282 $this->{-canvasscr}->addstr($y, $x, $token); 283 $x += length($token); 284 } 285 } 286 } 287 else { 288 $this->{-canvasscr}->addstr($y, $x, $text); 289 } 290} 291 292sub text_length { 293 my $this = shift; 294 my ($text) = @_; 295 296 my $length = 0; 297 if ($this->{-htmltext}) { 298 my @tokens = &text_tokenize($text); 299 foreach my $token (@tokens) { 300 if ($token !~ m/^<\/?(reverse|bold|underline|blink|dim)>$/s) { 301 $length += length($token); 302 } 303 } 304 } 305 else { 306 $length = length($text); 307 } 308 return $length; 309} 310 311sub text_chop { 312 my $this = shift; 313 my ($text, $max_length) = @_; 314 315 if ($this->{-htmltext}) { 316 my @open = (); 317 my @tokens = &text_tokenize($text); 318 my $length = 0; 319 $text = ''; 320 foreach my $token (@tokens) { 321 if ($token =~ m/^<(\/?)(reverse|bold|underline|blink|dim)>/s) { 322 my ($type, $name) = ($1, $2); 323 if (defined($type) and $type eq '/') { 324 pop(@open); 325 } 326 else { 327 push(@open, $name); 328 } 329 $text .= $token; 330 } 331 else { 332 $text .= $token; 333 $length += length($token); 334 if ($length > $max_length) { 335 $text = substr($text, 0, $max_length); 336 $text =~ s/.$/\$/; 337 while (defined($token = pop(@open))) { 338 $text .= "</$token>"; 339 } 340 last; 341 } 342 } 343 } 344 } 345 else { 346 if (length($text) > $max_length) { 347 $text = substr($text, 0, $max_length); 348 } 349 } 350 return $text; 351} 352 353sub text_dimension ($;) 354{ 355 # Make $this->text_wrap() possible. 356 shift if ref $_[0]; 357 my $text = shift; 358 359 my $lines = split_to_lines($text); 360 361 my $height = scalar @$lines; 362 363 my $width = 0; 364 foreach (@$lines) 365 { 366 my $l = length($_); 367 $width = $l if $l > $width; 368 } 369 370 return ($width, $height); 371} 372 373# ---------------------------------------------------------------------- 374# Keyboard input 375# ---------------------------------------------------------------------- 376 377# Constants: 378 379# Keys that are not defined in curses.h, but which might come in handy. 380sub CUI_ESCAPE() { "\x1b" } 381sub CUI_TAB() { "\t" } 382sub CUI_SPACE() { " " } 383 384# Make ascii representation of a key. 385sub key_to_ascii($;) 386{ 387 my $this = shift; 388 my $key = shift; 389 390 if ($key eq CUI_ESCAPE()) { 391 $key = '<Esc>'; 392 } 393 # Control characters. Change them into something printable 394 # via Curses' unctrl function. 395 elsif ($key lt ' ' and $key ne "\n" and $key ne "\t") { 396 $key = '<' . uc(unctrl($key)) . '>'; 397 } 398 399 # Extended keys get translated into their names via Curses' 400 # keyname function. 401 elsif ($key =~ /^\d{2,}$/) { 402 $key = '<' . uc(keyname($key)) . '>'; 403 } 404 405 return $key; 406} 407 408# For the select() syscall in char_read(). 409my $rin = ''; 410my $fno = fileno(STDIN); 411$fno = 0 unless $fno >= 0; 412vec($rin, $fno , 1) = 1; 413 414sub char_read(;$) 415{ 416 my $this = shift; 417 my $blocktime = shift; 418 419 # Initialize the toplevel window for 420 # reading a key. 421 my $s = $this->root->{-canvasscr}; 422 noecho(); 423 raw(); 424 $s->keypad(1); 425 426 # Read input on STDIN. 427 my $key = '-1'; 428 $blocktime = undef if $blocktime < 0; # Wait infinite 429 my $crin = $rin; 430 $! = 0; 431 my $found = select($crin, undef, undef, $blocktime); 432 433 if ($found < 0 ) { 434 print STDERR "DEBUG: get_key() -> select() -> $!\n" 435 if $Curses::UI::debug; 436 } elsif ($found) { 437 $key = $s->getch(); 438 } 439 440 return $key; 441} 442 443sub get_key(;$) 444{ 445 my $this = shift; 446 my $blocktime = shift || 0; 447 448 my $key = $this->char_read($blocktime); 449 450 # ------------------------------------ # 451 # Hacks for broken termcaps / curses # 452 # ------------------------------------ # 453 454 $key = KEY_BACKSPACE if ( 455 ord($key) == 127 or 456 $key eq "\cH" 457 ); 458 459 $key = KEY_DC if ( 460 $key eq "\c?" or 461 $key eq "\cD" 462 ); 463 464 $key = KEY_ENTER if ( 465 $key eq "\n" or 466 $key eq "\cM" 467 ); 468 469 # Catch ESCape sequences. 470 my $ESC = CUI_ESCAPE(); 471 if ($key eq $ESC) 472 { 473 $key .= $this->char_read(0); 474 475 # Only ESC pressed? 476 $key = $ESC if $key eq "${ESC}-1" 477 or $key eq "${ESC}${ESC}"; 478 return $key if $key eq $ESC; 479 480 # Not only a single ESC? 481 # Then get extra keypresses. 482 $key .= $this->char_read(0); 483 while ($key =~ /\[\d+$/) { 484 $key .= $this->char_read(0); 485 } 486 487 # Function keys on my Sun Solaris box. 488 # I have no idea of the portability of 489 # this stuff, but it works for me... 490 if ($key =~ /\[(\d+)\~/) 491 { 492 my $digit = $1; 493 if ($digit >= 11 and $digit <= 15) { 494 $key = KEY_F($digit-10); 495 } elsif ($digit >= 17 and $digit <= 21) { 496 $key = KEY_F($digit-11); 497 } 498 } 499 500 $key = KEY_HOME if ( 501 $key eq $ESC . "OH" or 502 $key eq $ESC . "[7~" or 503 $key eq $ESC . "[1~" 504 ); 505 506 $key = KEY_BTAB if ( 507 $key eq $ESC . "OI" or # My xterm under solaris 508 $key eq $ESC . "[Z" # My xterm under Redhat Linux 509 ); 510 511 $key = KEY_DL if ( 512 $key eq $ESC . "[2K" 513 ); 514 515 $key = KEY_END if ( 516 $key eq $ESC . "OF" or 517 $key eq $ESC . "[4~" 518 ); 519 520 $key = KEY_PPAGE if ( 521 $key eq $ESC . "[5~" 522 ); 523 524 $key = KEY_NPAGE if ( 525 $key eq $ESC . "[6~" 526 ); 527 } 528 529 # ----------# 530 # Debugging # 531 # ----------# 532 533 if ($Curses::UI::debug and $key ne "-1") 534 { 535 my $k = ''; 536 my @k = split //, $key; 537 foreach (@k) { $k .= $this->key_to_ascii($_) } 538 print STDERR "DEBUG: get_key() -> [$k]\n" 539 } 540 541 return $key; 542} 543 5441; 545 546 547=pod 548 549=head1 NAME 550 551Curses::UI::Common - Common methods for Curses::UI 552 553=head1 CLASS HIERARCHY 554 555 Curses::UI::Common - base class 556 557 558=head1 SYNOPSIS 559 560 package MyPackage; 561 562 use Curses::UI::Common; 563 use vars qw(@ISA); 564 @ISA = qw(Curses::UI::Common); 565 566=head1 DESCRIPTION 567 568Curses::UI::Common is a collection of methods that is 569shared between Curses::UI classes. 570 571 572 573 574=head1 METHODS 575 576=head2 Various methods 577 578=over 4 579 580=item * B<parent> ( ) 581 582Returns the data member $this->{B<-parent>}. 583 584=item * B<root> ( ) 585 586Returns the topmost B<-parent> (the Curses::UI instance). 587 588=item * B<delallwin> ( ) 589 590This method will walk through all the data members of the 591class intance. Each data member that is a Curses::Window 592descendant will be removed. 593 594=item * B<accessor> ( NAME, [VALUE] ) 595 596If VALUE is set, the value for the data member $this->{NAME} 597will be changed. The method will return the current value for 598data member $this->{NAME}. 599 600=item * B<keys_to_lowercase> ( HASHREF ) 601 602All keys in the hash referred to by HASHREF will be 603converted to lower case. 604 605=back 606 607 608=head2 Text processing 609 610=over 4 611 612=item B<split_to_lines> ( TEXT ) 613 614This method will split TEXT into a list of separate lines. 615It returns a reference to this list. 616 617=item B<scrlength> ( LINE ) 618 619Returns the screenlength of the string LINE. The difference 620with the perl function length() is that this method will 621expand TAB characters. It is exported by this class and it may 622be called as a stand-alone routine. 623 624=item B<text_dimension> ( TEXT ) 625 626This method will return an array containing the width 627(the length of the longest line) and the height (the 628number of lines) of the TEXT. 629 630=item B<text_wrap> ( LINE, LENGTH, WORDWRAP ) 631 632=item B<WORDWRAP> ( ) 633 634=item B<NO_WORDWRAP> ( ) 635 636This method will wrap a line of text (LINE) to a 637given length (LENGTH). If the WORDWRAP argument is 638true, wordwrap will be enabled (this is the default 639for WORDWRAP). It will return a reference to a list 640of wrapped lines. It is exported by this class and it may 641be called as a stand-alone routine. 642 643The B<WORDWRAP> and B<NO_WORDWRAP> routines will 644return the correct value vor the WORDWRAP argument. 645These routines are exported by this class. 646 647Example: 648 649 $this->text_wrap($line, 50, NO_WORDWRAP); 650 651=back 652 653 654 655=head2 Reading key input 656 657=over 4 658 659=item B<CUI_ESCAPE> ( ) 660 661=item B<CUI_TAB> ( ) 662 663=item B<CUI_SPACE> ( ) 664 665These are a couple of routines that are not defined by the 666L<Curses|Curses> module, but which might be useful anyway. 667These routines are exported by this class. 668 669=item B<get_key> ( BLOCKTIME, CURSOR ) 670 671This method will try to read a key from the keyboard. 672It will return the key pressed or -1 if no key was 673pressed. It is exported by this class and it may 674be called as a stand-alone routine. 675 676The BLOCKTIME argument can be used to set 677the curses halfdelay (the time to wait before the 678routine decides that no key was pressed). BLOCKTIME is 679given in tenths of seconds. The default is 0 (non-blocking 680key read). 681 682Example: 683 684 my $key = $this->get_key(5) 685 686=back 687 688 689 690=head1 SEE ALSO 691 692L<Curses::UI|Curses::UI> 693 694 695 696 697=head1 AUTHOR 698 699Copyright (c) 2001-2002 Maurice Makaay. All rights reserved. 700 701Maintained by Marcus Thiesen (marcus@cpan.thiesenweb.de) 702 703 704This package is free software and is provided "as is" without express 705or implied warranty. It may be used, redistributed and/or modified 706under the same terms as perl itself. 707 708