1package Curses::UI; 2use base qw(Curses::UI::Common Curses::UI::Container); 3 4# If we do not know a terminal type, then imply VT100. 5BEGIN { $ENV{TERM} = 'vt100' unless defined $ENV{TERM} } 6 7use strict; 8use warnings; 9 10use Curses; 11use Curses::UI::Language; 12use Curses::UI::Color; 13use FileHandle; 14use Term::ReadKey; 15 16=head1 NAME 17 18Curses::UI - A curses based OO user interface framework 19 20=head1 VERSION 21 22Version 0.9609 23 24=cut 25 26use vars qw( $VERSION ); 27$VERSION = 0.9609; 28 29=head1 SYNOPSIS 30 31 use Curses::UI; 32 33 # create a new C::UI object 34 my $cui = Curses::UI->new( -clear_on_exit => 1, 35 -debug => $debug, ); 36 37 # this is where we gloss over setting up all the widgets and data 38 # structures :) 39 40 # start the event loop 41 $cui->mainloop; 42 43 44=head1 DESCRIPTION 45 46Curses::UI is an object-oriented user interface framework for Perl. 47 48It contains basic widgets (like buttons and text areas), more 49"advanced" widgets (like UI tabs and a fully-functional basic text 50editor), and some higher-level classes like pre-fab error dialogues. 51 52See L<Curses::UI::Tutorial> and the C<examples> directory of the 53source distribution for more introductory material. 54 55=cut 56 57$Curses::UI::debug = 0; 58$Curses::UI::screen_too_small = 0; 59$Curses::UI::initialized = 0; 60$Curses::UI::color_support = 0; 61$Curses::UI::color_object = 0; 62$Curses::UI::ncurses_mouse = 0; 63$Curses::UI::gpm_mouse = 0; 64 65# Detect if we should use the new moushandler 66if ($ENV{"TERM"} ne "xterm") { 67 eval { require Curses::UI::Mousehandler::GPM; 68 import Curses::UI::Mousehandler::GPM; }; 69 if (!$@) { 70 $Curses::UI::gpm_mouse = gpm_enable(); 71 print STDERR "DEBUG: gpm_mouse: " . $Curses::UI::gpm_mouse . "\n" 72 if $Curses::UI::debug; 73 } 74} else { 75 # Detect ncurses functionality. Magic for Solaris 8 76 eval { $Curses::UI::ncurses_mouse = (Curses->can('NCURSES_MOUSE_VERSION') 77 && 78 (NCURSES_MOUSE_VERSION() >= 1 ) ) }; 79 print STDERR "DEBUG: Detected mouse support $Curses::UI::ncurses_mouse\n" 80 if $Curses::UI::debug; 81} 82 83 84 85=head1 CONSTRUCTOR 86 87Create a new Curses::UI object: 88 89 my $cui = Curses::UI->new( OPTIONS ); 90 91where C<OPTIONS> is one or more of the following. 92 93=head2 -clear_on_exit 94 95If true, Curses::UI will call C<clear> on exit. Defaults to false. 96 97=head2 -color_support 98 99If true, Curses::UI tries to enable color for the 100application. Defaults to false. 101 102=head2 -compat 103 104If true, Curses::UI will run in compatibility mode, meaning that only 105very simple characters will be used for creating the widgets. Defaults 106to false. 107 108=head2 -keydelay 109 110If set to a positive integer, Curses::UI will track elapsed seconds 111since the user's last keystroke, preventing timer events from 112occurring for the specified number of seconds afterwards. By default 113this option is set to '0' (disabled). 114 115=head2 -mouse_support 116 117Curses::UI attempts to auto-discover if mouse support should be 118enabled or not. This option allows a hard override. Expects a boolean 119value. 120 121=head2 -userdata 122 123Takes a scalar (frequently a hashref) as its argument, and stows that 124scalar inside the Curses::UI object where it can be retrieved with the 125L<#userdata> method. Handy inside callbacks and the like. 126 127=head2 -default_colors 128 129Directs the underlying Curses library to allow use of default color 130pairs on terminals. Is preset to true and you almost certainly don't 131want to twiddle it. See C<man use_default_colors> if you think you do. 132 133=cut 134 135sub new { 136 my ($class,%userargs) = @_; 137 138 fatalerror("Curses::UI->new can only be called once!") 139 if $Curses::UI::initialized; 140 141 &Curses::UI::Common::keys_to_lowercase(\%userargs); 142 143 my %args = ( 144 -compat => 0, # Use compatibility mode? 145 -clear_on_exit => 0, # Clear screen if program exits? 146 -cursor_mode => 0, # What is the current cursor_mode? 147 -debug => undef, # Turn on debugging mode? 148 -keydelay => 0, # Track seconds since last keystroke? 149 -language => undef, # Which language to use? 150 -mouse_support => 1, # Do we want mouse support 151 -overlapping => 1, # Whether overlapping widgets are supported 152 -color_support => 0, 153 -default_colors=> 1, 154 #user data 155 -userdata => undef, #user internal data 156 %userargs, 157 -read_timeout => -1, # full blocking read by default 158 -scheduled_code => [], 159 -added_code => {}, 160 -lastkey => 0, # Last keypress time (set in mainloop) 161 ); 162 163 $Curses::UI::debug = $args{-debug} 164 if defined $args{-debug}; 165 166 $Curses::UI::ncurses_mouse = $args{-mouse_support} 167 if defined $args{-mouse_support}; 168 169 if ($Curses::UI::gpm_mouse && $args{-mouse_support}) { 170 $Curses::UI::ncurses_mouse = 1; 171 $args{-read_timeout} = 0.25; 172 } else { 173 $Curses::UI::gpm_mouse = 0; 174 } 175 176 my $self = bless { %args }, $class; 177 178 my $lang = new Curses::UI::Language($self->{-language}); 179 $self->lang($lang); 180 print STDERR "DEBUG: Loaded language: $lang->{-lang}\n" 181 if $Curses::UI::debug; 182 183 # Color support 184 $Curses::UI::color_support = $args{-color_support} if 185 defined $args{-color_support}; 186 187 $self->layout(); 188 189 return $self; 190} 191 192DESTROY { 193 my $self = shift; 194 my $scr = $self->{-canvasscr}; 195 $scr->delwin() if (defined($scr)); 196 endwin(); 197 $Curses::UI::initialized = 0; 198 199 if ($self->{-clear_on_exit}) 200 { Curses::erase(); Curses::clear() } 201} 202 203 204 205=head1 EVENT HANDLING METHODS 206 207=head2 mainloop 208 209The Curses::UI event handling loop. Call once setup is finished to 210"start" a C::UI program. 211 212=cut 213 214sub mainloop { 215 my ($self) = @_; 216 217 # Draw the initial screen. 218 $self->focus(undef, 1); # 1 = forced focus 219 $self->draw; 220 doupdate(); 221 222 $self->{mainloop}=1; 223 224 # Inifinite event loop. 225 while ($self->{mainloop}) { $self->do_one_event } 226} 227 228=head2 mainloopExit 229 230This exits the main loop. 231 232=cut 233 234sub mainloopExit{ 235 my $self=$_[0]; 236 237 $self->{mainloop}=undef; 238} 239 240=head2 schedule_event 241 242Pushes its argument (a coderef) onto the scheduled event stack 243 244=cut 245 246sub schedule_event { 247 my ($self, $code) = @_; 248 249 $self->fatalerror("schedule_event(): callback is no CODE reference") 250 unless defined $code and ref $code eq 'CODE'; 251 252 push @{$self->{-scheduled_code}}, $code; 253} 254 255 256 257=head1 WINDOW/LAYOUT METHODS 258 259=head2 layout 260 261The layout method of Curses::UI tries to find the size of the screen 262then calls the C<layout> method of every contained object (i.e. window 263or widget). It is not normally necessary to call this method directly. 264 265=cut 266 267sub layout { 268 my ($self) = @_; 269 270 $Curses::UI::screen_too_small = 0; 271 272 # find the terminal size. 273 my ($cols,$lines) = GetTerminalSize; 274 $ENV{COLS} = $cols; 275 $ENV{LINES} = $lines; 276 277 if ($Curses::UI::initialized) 278 { 279 my $scr = $self->{-canvasscr}; 280 $scr->delwin() if (defined($scr)); 281 endwin(); 282 } 283 # Initialize the curses screen. 284 initscr(); 285 noecho(); 286 raw(); 287 288 # Colors 289 if ($Curses::UI::color_support) { 290 if ( has_colors() ) { 291 $Curses::UI::color_object = new Curses::UI::Color(-default_colors => $self->{-default_colors}); 292 } else { 293 $Curses::UI::color_support = 0; 294 } 295 } 296 297 # Mouse events if possible 298 my $old = 0; 299 my $mmreturn; 300 if ( $Curses::UI::ncurses_mouse ) 301 { 302 print STDERR "DEBUG: ncurses mouse events are enabled\n" 303 if $Curses::UI::debug; 304 # In case of gpm, mousemask fails. (MT: Not for me, maybe GPM changed?) 305 eval { $mmreturn = mousemask( ALL_MOUSE_EVENTS(), $old ) }; 306 if ($Curses::UI::debug) { 307 print STDERR "DEBUG: mousemask returned $mmreturn\n"; 308 print STDERR "DEBUG: Old is now $old\n"; 309 print STDERR "DEBUG: mousemask() failed: $@\n" if $@; 310 } 311 } 312 313 # Create root window. 314 my $root = newwin($lines, $cols, 0, 0); 315 die "newwin($lines, $cols, 0, 0) failed\n" 316 unless defined $root; 317 318 # Let this object present itself as a standard 319 # Curses::UI widget, regarding size, location and 320 # drawing area. This will make it possible for 321 # child windows / widgets to layout and draw themselves. 322 $self->{-width} = $self->{-w} = $self->{-bw} = $cols; 323 $self->{-height} = $self->{-h} = $self->{-bh} = $lines; 324 $self->{-x} = $self->{-y} = 0; 325 $self->{-canvasscr} = $root; 326 327 # Walk through all contained objects and let them 328 # layout themselves. 329 $self->layout_contained_objects; 330 $self->draw(); 331 332 $Curses::UI::initialized = 1; 333 return $self; 334} 335 336sub layout_new() 337{ 338 my $self = shift; 339 340 $Curses::UI::screen_too_small = 0; 341 342 # find the terminal size. 343 my ($cols,$lines) = GetTerminalSize; 344 $ENV{COLS} = $cols; 345 $ENV{LINES} = $lines; 346 347 # Let this object present itself as a standard 348 # Curses::UI widget, regarding size, location and 349 # drawing area. This will make it possible for 350 # child windows / widgets to layout and draw themselves. 351 # 352 $self->{-width} = $self->{-w} = $self->{-bw} = $cols; 353 $self->{-height} = $self->{-h} = $self->{-bh} = $lines; 354 $self->{-x} = $self->{-y} = 0; 355# $self->{-canvasscr} = $root; 356 357 # Walk through all contained objects and let them 358 # layout themselves. 359 $self->layout_contained_objects; 360 361 $Curses::UI::initialized = 1; 362 $self->draw(); 363 return $self; 364} 365 366 367# ---------------------------------------------------------------------- 368# Event handling 369# ---------------------------------------------------------------------- 370 371 372# TODO: document 373sub do_one_event(;$) 374{ 375 my $self = shift; 376 my $object = shift; 377 $object = $self unless defined $object; 378 379 eval {curs_set($self->{-cursor_mode})}; 380 381 # gpm mouse? 382 if ($Curses::UI::gpm_mouse) { 383 $self->handle_gpm_mouse_event($object); 384 doupdate(); 385 } 386 387 # Read a key or use the feeded key. 388 my $key = $self->{-feedkey}; 389 unless (defined $key) { 390 $key = $self->get_key($self->{-read_timeout}); 391 } 392 $self->{-feedkey} = undef; 393 394 # If there was a keypress, set -lastkey 395 $self->{-lastkey} = time() unless ($key eq '-1'); 396 397 # ncurses sends KEY_RESIZE() key on resize. Ignore this key. 398 # TODO: Try to redraw and layout everything anew 399 # KEY_RESIZE doesn't seem to work right; 400 if (Curses->can("KEY_RESIZE")) { 401 eval { $key = '-1' if $key eq KEY_RESIZE(); }; 402 } 403 my ($cols,$lines) = GetTerminalSize; 404 if ( ($ENV{COLS} != $cols) || ( $ENV{LINES} != $lines )) { 405 $self->layout(); 406 $self->draw; 407 } 408 409 # ncurses sends KEY_MOUSE() 410 if ($Curses::UI::ncurses_mouse) { 411 if ($key eq KEY_MOUSE()) { 412 print STDERR "DEBUG: Got a KEY_MOUSE(), handeling it\n" 413 if $Curses::UI::debug; 414 $self->handle_mouse_event($object); 415 doupdate(); 416 return $self; 417 } 418 } 419 420 # If the screen is too small, then <CTRL+C> will exit. 421 # Else the next event loop will be started. 422 if ($Curses::UI::screen_too_small) { 423 exit(1) if $key eq "\cC"; 424 return $self; 425 } 426 427 # Delegate the keypress. This is not done to $self, 428 # but to $object, so all events will go to the 429 # object that called do_one_event(). This is used to 430 # enable modal focusing. 431 $object->event_keypress($key) unless $key eq '-1'; 432 433 # Execute timer code 434 $self->do_timer; 435 436 # Execute one scheduled event; 437 if (@{$self->{-scheduled_code}}) { 438 my $code = shift @{$self->{-scheduled_code}}; 439 $code->($self); 440 } 441 442 # Execute added code 443 foreach my $key (keys %{$self->{-added_code}}) { 444 my $code = $self->{-added_code}->{$key}; 445 $self->fatalerror("Method $key is not a coderef") 446 if (ref $code ne 'CODE'); 447 $code->($self); 448 } 449 450 451 # Update the screen. 452 doupdate(); 453 454 return $self; 455} 456 457# TODO: document 458 459# TODO: document 460sub add_callback() 461{ 462 my $self = shift; 463 my $id = shift; 464 my $code = shift; 465 466 $self->fatalerror( 467 "add_callback(): is is not set" 468 ) unless defined $id; 469 470 $self->fatalerror( 471 "add_callback(): callback is no CODE reference" 472 ) unless defined $code and ref $code eq 'CODE'; 473 474 $self->{-added_code}->{$id} = $code; 475} 476 477# TODO: document 478sub delete_callback() 479{ 480 my $self = shift; 481 my $id = shift; 482 483 $self->fatalerror( 484 "delete_callback(): id is not set" 485 ) unless defined $id; 486 487 delete $self->{-added_code}->{$id} if 488 defined $self->{-added_code}->{$id}; 489} 490 491sub draw() 492{ 493 my $self = shift; 494 my $no_doupdate = shift || 0; 495 496 if ($Curses::UI::screen_too_small) 497 { 498 my $s = $self->{-canvasscr}; 499 $s->clear; 500 $s->addstr(0, 0, $self->lang->get('screen_too_small')); 501 $s->move(4,0); 502 $s->noutrefresh(); 503 doupdate(); 504 } else { 505 $self->SUPER::draw(1); 506 doupdate() unless $no_doupdate; 507 } 508} 509 510# TODO: document 511sub feedkey() 512{ 513 my $self = shift; 514 my $key = shift; 515 $self->{-feedkey} = $key; 516 return $self; 517} 518 519# TODO: document 520sub flushkeys() 521{ 522 my $self = shift; 523 524 my $key = ''; 525 my @k = (); 526 until ( $key eq "-1" ) { 527 $key = $self->get_key(0); 528 } 529} 530 531# Returns 0 if less than -keydelay seconds have elapsed since the last 532# user action. Returns the number of elapsed seconds otherwise. 533sub keydelay() 534{ 535 my $self = shift; 536 537 my $time = time(); 538 my $elapsed = $time - $self->{-lastkey}; 539 540 return 0 if ($elapsed < $self->{-keydelay}); 541 return $elapsed; 542} 543 544# ---------------------------------------------------------------------- 545# Timed event handling 546# ---------------------------------------------------------------------- 547 548sub set_read_timeout() 549{ 550 my $self = shift; 551 552 my $new_timeout = -1; 553 TIMER: while (my ($id, $config) = each %{$self->{-timers}}) 554 { 555 # Skip timer if it is disabled. 556 next TIMER unless $config->{-enabled}; 557 558 $new_timeout = $config->{-time} 559 unless $new_timeout != -1 and 560 $new_timeout < $config->{-time}; 561 } 562 $new_timeout = 1 if $new_timeout < 0 and $new_timeout != -1; 563 564 $self->{-read_timeout} = $new_timeout; 565 return $self; 566} 567 568sub set_timer($$;) 569{ 570 my $self = shift; 571 my $id = shift; 572 my $callback = shift; 573 my $time = shift || 1; 574 575 $self->fatalerror( 576 "add_timer(): callback is no CODE reference" 577 ) unless defined $callback and ref $callback eq 'CODE'; 578 579 $self->fatalerror( 580 "add_timer(): id is not set" 581 ) unless defined $id; 582 583 my $config = { 584 -time => $time, 585 -callback => $callback, 586 -enabled => 1, 587 -lastrun => time(), 588 }; 589 $self->{-timers}->{$id} = $config; 590 591 $self->set_read_timeout; 592 593 return $self; 594} 595 596sub disable_timer($;) 597{ 598 my ($self,$id) = @_; 599 if (defined $self->{-timers}->{$id}) { 600 $self->{-timers}->{$id}->{-enabled} = 0; 601 } 602 $self->set_read_timeout; 603 return $self; 604} 605 606sub enable_timer($;) 607{ 608 my ($self,$id) = @_; 609 if (defined $self->{-timers}->{$id}) { 610 $self->{-timers}->{$id}->{-enabled} = 1; 611 } 612 $self->set_read_timeout; 613 return $self; 614} 615 616sub delete_timer($;) 617{ 618 my ($self,$id) = @_; 619 if (defined $self->{-timers}->{$id}) { 620 delete $self->{-timers}->{$id}; 621 } 622 $self->set_read_timeout; 623 return $self; 624} 625 626sub do_timer() 627{ 628 my $self = shift; 629 630 my $now = time(); 631 my $timers_done = 0; 632 633 # Short-circuit timers if the keydelay hasn't elapsed 634 if ($self->{-keydelay}) { 635 return $self unless $self->keydelay; 636 } 637 638 TIMER: while (my ($id, $config) = each %{$self->{-timers}}) 639 { 640 # Skip timer if it is disabled. 641 next TIMER unless $config->{-enabled}; 642 643 # No -lastrun set? Then do it now. 644 unless (defined $config->{-lastrun}) 645 { 646 $config->{-lastrun} = $now; 647 next TIMER; 648 } 649 650 if ($config->{-lastrun} <= ($now - $config->{-time})) 651 { 652 $config->{-callback}->($self); 653 $config->{-lastrun} = $now; 654 $timers_done++; 655 } 656 } 657 658 # Bring the cursor back to the focused object by 659 # redrawing it. Due to drawing other objects, it might 660 # have moved to another widget or screen location. 661 # 662 $self->focus_path(-1)->draw if $timers_done; 663 664 return $self; 665} 666 667# ---------------------------------------------------------------------- 668# Mouse events 669# ---------------------------------------------------------------------- 670 671sub handle_mouse_event() 672{ 673 my $self = shift; 674 my $object = shift; 675 $object = $self unless defined $object; 676 677 my $MEVENT = 0; 678 getmouse($MEVENT); 679 680 # $MEVENT is a struct. From curses.h (note: this might change!): 681 # 682 # typedef struct 683 # { 684 # short id; /* ID to distinguish multiple devices */ 685 # int x, y, z; /* event coordinates (character-cell) */ 686 # mmask_t bstate; /* button state bits */ 687 # } MEVENT; 688 # 689 # --------------- 690 # s signed short 691 # x null byte 692 # x null byte 693 # --------------- 694 # i integer 695 # --------------- 696 # i integer 697 # --------------- 698 # i integer 699 # --------------- 700 # l long 701 # --------------- 702 703 my ($id, $x, $y, $z, $bstate) = unpack("sx2i3l", $MEVENT); 704 my %MEVENT = ( 705 -id => $id, 706 -x => $x, 707 -y => $y, 708 -bstate => $bstate, 709 ); 710 711 # Get the objects at the mouse event position. 712 my $tree = $self->object_at_xy($object, $MEVENT{-x}, $MEVENT{-y}); 713 714 # Walk through the object tree, top object first. 715 foreach my $object (reverse @$tree) 716 { 717 # Send the mouse-event to the object. 718 # Leave the loop if the object handled the event. 719 print STDERR "Asking $object to handle $MEVENT{-bstate} ...\n" if 720 $Curses::UI::debug; 721 my $return = $object->event_mouse(\%MEVENT); 722 last if defined $return and $return ne 'DELEGATE'; 723 } 724} 725 726sub handle_gpm_mouse_event() 727{ 728 my $self = shift; 729 my $object = shift; 730 $object = $self unless defined $object; 731 732 return unless $Curses::UI::gpm_mouse; 733 734 my $MEVENT = gpm_get_mouse_event(); 735 # $MEVENT from C:UI:MH:GPM is identical. 736 737 return unless $MEVENT; 738 739 my ($id, $x, $y, $z, $bstate) = unpack("sx2i3l", $MEVENT); 740 my %MEVENT = ( 741 -id => $id, 742 -x => $x, 743 -y => $y, 744 -bstate => $bstate, 745 ); 746 747 # Get the objects at the mouse event position. 748 my $tree = $self->object_at_xy($object, $MEVENT{-x}, $MEVENT{-y}); 749 750 # Walk through the object tree, top object first. 751 foreach my $object (reverse @$tree) 752 { 753 # Send the mouse-event to the object. 754 # Leave the loop if the object handled the event. 755 756 my $return = $object->event_mouse(\%MEVENT); 757 last if defined $return and $return ne 'DELEGATE'; 758 } 759} 760 761 762sub object_at_xy($$;$) 763{ 764 my $self = shift; 765 my $object = shift; 766 my $x = shift; 767 my $y = shift; 768 my $tree = shift; 769 $tree = [] unless defined $tree; 770 771 push @$tree, $object; 772 773 my $idx = -1; 774 while (defined $object->{-draworder}->[$idx]) 775 { 776 my $testobj = $object->getobj($object->{-draworder}->[$idx]); 777 $idx--; 778 779 # Find the window parameters for the $testobj. 780 my $scr = defined $testobj->{-borderscr} ? '-borderscr' : '-canvasscr'; 781 my $winp = $testobj->windowparameters($scr); 782 783 # Does the click fall inside this object? 784 if ( $x >= $winp->{-x} and 785 $x < ($winp->{-x}+$winp->{-w}) and 786 $y >= $winp->{-y} and 787 $y < ($winp->{-y}+$winp->{-h}) ) { 788 789 if ( $testobj->isa('Curses::UI::Container') and 790 not $testobj->isa('Curses::UI::ContainerWidget')) { 791 $self->object_at_xy($testobj, $x, $y, $tree) 792 } else { 793 push @$tree, $testobj; 794 } 795 return $tree; 796 } 797 } 798 799 return $tree; 800} 801 802 803# ---------------------------------------------------------------------- 804# Other subroutines 805# ---------------------------------------------------------------------- 806 807# TODO: document 808sub fatalerror($$;$) 809{ 810 my $self = shift; 811 my $error = shift; 812 my $exit = shift; 813 814 $exit = 1 unless defined $exit; 815 chomp $error; 816 $error .= "\n"; 817 818 my $s = $self->{-canvasscr}; 819 $s->clear; 820 $s->addstr(0,0,"Fatal program error:\n" 821 . "-"x($ENV{COLS}-1) . "\n" 822 . $error 823 . "-"x($ENV{COLS}-1) . "\n" 824 . "Press any key to exit..."); 825 $s->noutrefresh(); 826 doupdate(); 827 828 $self->flushkeys(); 829 for (;;) 830 { 831 my $key = $self->get_key(); 832 last if $key ne "-1"; 833 } 834 835 exit($exit); 836} 837 838sub usemodule($;) 839{ 840 my $self = shift; 841 my $class = shift; 842 843 # Create class filename. 844 my $file = $class; 845 $file =~ s|::|/|g; 846 $file .= '.pm'; 847 848 # Automatically load the required class. 849 if (not defined $INC{$file}) 850 { 851 eval 852 { 853 require $file; 854 $class->import; 855 }; 856 857 # Fatal error if the class could not be loaded. 858 $self->fatalerror("Could not load $class from $file:\n$@") 859 if $@; 860 } 861 862 return $self; 863} 864 865sub focus_path() 866{ 867 my $self = shift; 868 my $index = shift; 869 870 my $p_obj = $self; 871 my @path = ($p_obj); 872 for(;;) 873 { 874 my $p_el = $p_obj->{-draworder}->[-1]; 875 last unless defined $p_el; 876 $p_obj = $p_obj->{-id2object}->{$p_el}; 877 push @path, $p_obj; 878 last if $p_obj->isa('Curses::UI::ContainerWidget'); 879 } 880 881 return (defined $index ? $path[$index] : @path); 882} 883 884# add() is overridden, because we only want to be able 885# to add Curses::UI:Window objects to the Curses::UI 886# rootlevel. 887# 888sub add() 889{ 890 my $self = shift; 891 my $id = shift; 892 my $class = shift; 893 my %args = @_; 894 895 # Make it possible to specify WidgetType instead of 896 # Curses::UI::WidgetType. 897 $class = "Curses::UI::$class" 898 if $class !~ /\:\:/ or 899 $class =~ /^Dialog\:\:[^\:]+$/; 900 901 $self->usemodule($class); 902 903 $self->fatalerror( 904 "You may only add Curses::UI::Window objects to " 905 . "Curses::UI and no $class objects" 906 ) unless $class->isa('Curses::UI::Window'); 907 908 $self->SUPER::add($id, $class, %args); 909} 910 911# Sets/Get the user data 912sub userdata 913{ 914 my $self = shift; 915 if (defined $_[0]) 916 { 917 $self->{-userdata} = $_[0]; 918 } 919 return $self->{-userdata}; 920} 921 922# ---------------------------------------------------------------------- 923# Focusable dialog windows 924# ---------------------------------------------------------------------- 925 926sub tempdialog() 927{ 928 my $self = shift; 929 my $class = shift; 930 my %args = @_; 931 932 my $id = "__window_$class"; 933 934 my $dialog = $self->add($id, $class, %args); 935 $dialog->modalfocus; 936 my $return = $dialog->get; 937 $self->delete($id); 938 $self->root->focus(undef, 1); 939 return $return; 940} 941 942# The argument list will be returned unchanged, unless it 943# contains only one item. In that case ($ifone, $_[0]) will 944# be returned. This enables constructions like: 945# 946# $cui->dialog("Some dialog message"); 947# 948# instead of: 949# 950# $cui->dialog(-message => "Some dialog message"); 951# 952sub process_args() 953{ 954 my $self = shift; 955 my $ifone = shift; 956 if (@_ == 1) { @_ = ($ifone => $_[0]) } 957 return @_; 958} 959 960sub error() 961{ 962 my $self = shift; 963 my %args = $self->process_args('-message', @_); 964 $self->tempdialog('Dialog::Error', %args); 965} 966 967sub dialog() 968{ 969 my $self = shift; 970 my %args = $self->process_args('-message', @_); 971 $self->tempdialog('Dialog::Basic', %args); 972} 973 974sub question() 975{ 976 my $self = shift; 977 my %args = $self->process_args('-question', @_); 978 $self->tempdialog('Dialog::Question', %args); 979} 980 981sub calendardialog() 982{ 983 my $self = shift; 984 my %args = $self->process_args('-title', @_); 985 $self->tempdialog('Dialog::Calendar', %args); 986} 987 988sub filebrowser() 989{ 990 my $self = shift; 991 my %args = $self->process_args('-title', @_); 992 993 # Create title 994 unless (defined $args{-title}) { 995 my $l = $self->root->lang; 996 $args{-title} = $l->get('file_title'); 997 } 998 999 # Select a file to load from. 1000 $self->tempdialog('Dialog::Filebrowser', %args); 1001} 1002 1003sub dirbrowser() 1004{ 1005 my $self = shift; 1006 my %args = $self->process_args('-title', @_); 1007 1008 # Create title 1009 unless (defined $args{-title}) { 1010 my $l = $self->root->lang; 1011 $args{-title} = $l->get('dir_title'); 1012 } 1013 1014 # Select a file to load from. 1015 $self->tempdialog('Dialog::Dirbrowser', %args); 1016} 1017 1018sub savefilebrowser() 1019{ 1020 my $self = shift; 1021 my %args = $self->process_args('-title', @_); 1022 1023 my $l = $self->root->lang; 1024 1025 # Create title. 1026 $args{-title} = $l->get('file_savetitle') 1027 unless defined $args{-title}; 1028 1029 # Select a file to save to. 1030 my $file = $self->filebrowser(-editfilename => 1, %args); 1031 return unless defined $file; 1032 1033 # Check if the file exists. Ask for overwrite 1034 # permission if it does. 1035 if (-e $file) 1036 { 1037 # Get language specific data. 1038 my $pre = $l->get('file_overwrite_question_pre'); 1039 my $post = $l->get('file_overwrite_question_post'); 1040 my $title = $l->get('file_overwrite_title'); 1041 1042 my $overwrite = $self->dialog( 1043 -title => $title, 1044 -buttons => [ 'yes', 'no' ], 1045 -message => $pre . $file . $post, 1046 ); 1047 return unless $overwrite; 1048 } 1049 1050 return $file; 1051} 1052 1053sub loadfilebrowser() 1054{ 1055 my $self = shift; 1056 my %args = $self->process_args('-title', @_); 1057 1058 # Create title 1059 unless (defined $args{-title}) { 1060 my $l = $self->root->lang; 1061 $args{-title} = $l->get('file_loadtitle'); 1062 } 1063 1064 $self->filebrowser(-editfilename => 0, %args); 1065} 1066 1067# ---------------------------------------------------------------------- 1068# Non-focusable dialogs 1069# ---------------------------------------------------------------------- 1070 1071my $status_id = "__status_dialog"; 1072sub status($;) 1073{ 1074 my $self = shift; 1075 my %args = $self->process_args('-message', @_); 1076 1077 $self->delete($status_id); 1078 $self->add($status_id, 'Dialog::Status', %args)->draw; 1079 1080 return $self; 1081} 1082 1083sub nostatus() 1084{ 1085 my $self = shift; 1086 $self->delete($status_id); 1087 $self->flushkeys(); 1088 $self->draw; 1089 return $self; 1090} 1091 1092sub progress() 1093{ 1094 my $self = shift; 1095 my %args = @_; 1096 1097 $self->add( 1098 "__progress_$self", 1099 'Dialog::Progress', 1100 %args 1101 ); 1102 $self->draw; 1103 1104 return $self; 1105} 1106 1107sub setprogress($;$) 1108{ 1109 my $self = shift; 1110 my $pos = shift; 1111 my $message = shift; 1112 1113 # If I do not do this, the progress bar seems frozen 1114 # if a key is pressed on my Solaris machine. Flushing 1115 # the input keys solves this. And this is not a bad 1116 # thing to do during a progress dialog (input is ignored 1117 # this way). 1118 $self->flushkeys; 1119 1120 my $p = $self->getobj("__progress_$self"); 1121 return unless defined $p; 1122 $p->pos($pos) if defined $pos; 1123 $p->message($message) if defined $message; 1124 $p->draw; 1125 1126 return $self; 1127} 1128 1129sub noprogress() 1130{ 1131 my $self = shift; 1132 $self->delete("__progress_$self"); 1133 $self->flushkeys; 1134 $self->draw; 1135 return $self; 1136} 1137 1138sub leave_curses() 1139{ 1140 my $self = shift; 1141 def_prog_mode(); 1142 endwin(); 1143} 1144 1145sub reset_curses() 1146{ 1147 my $self = shift; 1148 reset_prog_mode(); 1149 $self->layout(); # In case the terminal has been resized 1150} 1151 1152### Color support 1153 1154sub color() { 1155 my $self = shift; 1156 return $Curses::UI::color_object; 1157} 1158 1159sub set_color { 1160 my $self = shift; 1161 my $co = shift; 1162 1163 $Curses::UI::color_object = $co; 1164} 1165 1166 1167 1168# ---------------------------------------------------------------------- 1169# Accessor functions 1170# ---------------------------------------------------------------------- 1171 1172sub compat(;$) { shift()->accessor('-compat', shift()) } 1173sub clear_on_exit(;$) { shift()->accessor('-clear_on_exit', shift()) } 1174sub cursor_mode(;$) { shift()->accessor('-cursor_mode', shift()) } 1175sub lang(;$) { shift()->accessor('-language_object', shift()) } 1176sub overlapping(;$) { shift()->accessor('-overlapping', shift()) } 1177 1178# TODO: document 1179sub debug(;$) 1180{ 1181 my $self = shift; 1182 my $value = shift; 1183 $Curses::UI::debug = $self->accessor('-debug', $value); 1184} 1185 1186 1187 1188 1189 1190 1191=head1 CONVENIENCE DIALOG METHODS 1192 1193=head2 dialog 1194 1195Use the C<dialog> method to show a dialog window. If you only provide 1196a single argument, this argument will be used as the message to 1197show. Example: 1198 1199 $cui->dialog("Hello, world!"); 1200 1201If you want to have some more control over the dialog window, you will 1202have to provide more arguments (for an explanation of the arguments 1203that can be used, see L<Curses::UI::Dialog::Basic>. Example: 1204 1205 my $yes = $cui->dialog( 1206 -message => "Hello, world?", 1207 -buttons =3D> ['yes','no'], 1208 -values => [1,0], 1209 -title => 'Question', 1210 ); 1211 1212 if ($yes) { 1213 # whatever 1214 } 1215 1216 1217=head2 error 1218 1219The C<error> method will create an error dialog. This is basically a 1220Curses::UI::Dialog::Basic, but it has an ASCII-art exclamation sign 1221drawn left to the message. For the rest it's just like 1222C<dialog>. Example: 1223 1224 $cui->error("It's the end of the\n" 1225 ."world as we know it!"); 1226 1227=head2 filebrowser 1228 1229Creates a file browser dialog. For an explanation of the arguments 1230that can be used, see L<Curses::UI::Dialog::Filebrowser>. Example: 1231 1232 my $file = $cui->filebrowser( 1233 -path => "/tmp", 1234 -show_hidden => 1, 1235 ); 1236 1237 # Filebrowser will return undef 1238 # if no file was selected. 1239 if (defined $file) { 1240 unless (open F, ">$file") { 1241 print F "Hello, world!\n"; 1242 close F; 1243 } else { 1244 $cui->error(qq(Error on writing to "$file":\n$!)); 1245 } 1246 1247=head2 loadfilebrowser, savefilebrowser 1248 1249These two methods will create file browser dialogs as well. The 1250difference is that these will have the dialogs set up correctly for 1251loading and saving files. Moreover, the save dialog will check if the 1252selected file exists or not. If it does exist, it will show an 1253overwrite confirmation to check if the user really wants to overwrite 1254the selected file. 1255 1256=head2 status, nostatus 1257 1258Using these methods it's easy to provide status information for the 1259user of your program. The status dialog is a dialog with only a label 1260on it. The status dialog doesn't really get the focus. It's only used 1261to display some information. If you need more than one status, you can 1262call C<status> subsequently. Any existing status dialog will be 1263cleaned up and a new one will be created. 1264 1265If you are finished, you can delete the status dialog by calling the 1266C<nostatus> method. Example: 1267 1268 $cui->status("Saying hello to the world..."); 1269 # code for saying "Hello, world!" 1270 1271 $cui->status("Saying goodbye to the world..."); 1272 # code for saying "Goodbye, world!" 1273 1274 $cui->nostatus; 1275 1276=head2 progress, setprogress, noprogress 1277 1278Using these methods it's easy to provide progress information to the 1279user. The progress dialog is a dialog with an optional label on it and 1280a progress bar. Similar to the status dialog, this dialog does not get 1281the focus. 1282 1283Using the C<progress> method, a new progress dialog can be created. 1284This method takes the same arguments as the 1285L<Curses::IU::Dialog::Progress> class. 1286 1287After that the progress can be set using C<setprogress>. This method 1288takes one or two arguments. The first argument is the current position 1289of the progressbar. The second argument is the message to show in the 1290label. If one of these arguments is undefined, the current value will 1291be kept. 1292 1293If you are finished, you can delete the progress dialog by calling the 1294C<noprogress> method. 1295 1296 $cui->progress( 1297 -max => 10, 1298 -message => "Counting 10 seconds...", 1299 ); 1300 1301 for my $second (0..10) { 1302 $cui->setprogress($second) 1303 sleep 1; 1304 } 1305 1306 $cui->noprogress; 1307 1308=cut 1309 1310 1311 1312=head1 OTHER METHODS 1313 1314=over 4 1315 1316=item B<leave_curses> ( ) 1317 1318Temporarily leaves curses mode and recovers normal terminal mode. 1319 1320=item B<reset_curses> ( ) 1321 1322Return to curses mode after B<leave_curses()>. 1323 1324=item B<add> ( ID, CLASS, OPTIONS ) 1325 1326The B<add> method of Curses::UI is almost the same as the B<add> 1327method of Curses::UI::Container. The difference is that Curses::UI 1328will only accept classes that are (descendants) of the 1329Curses::UI::Window class. For the rest of the information see 1330L<Curses::UI::Container|Curses::UI::Container>. 1331 1332=item B<add_callback> ( ID, CODE) 1333 1334This method lets you add a callback into the mainloop permanently. 1335The code is executed after the input handler has run. 1336 1337=item B<delete_callback> ( ID ) 1338 1339This method deletes the CODE specified by ID from the mainloop. 1340 1341=item B<usemodule> ( CLASSNAME ) 1342 1343Loads the with CLASSNAME given module. 1344 1345=item B<userdata> ( [ SCALAR ] ) 1346 1347This method will return the user internal data stored in the UI 1348object. If a SCALAR parameter is specified it will also set the 1349current user data to it. 1350 1351=item B<keydelay> ( ) 1352 1353This method is used internally to control timer events when the 1354B<-keydelay> option is set, but it can be called directly it to find 1355out if the required amount of time has passed since the user's last 1356action. B<keydelay>() will return 0 if insufficent time has passed, 1357and will return the number of elapsed seconds otherwise. 1358 1359=item B<compat> ( [BOOLEAN] ) 1360 1361The B<-compat> option will be set to the BOOLEAN value, unless BOOLEAN 1362is omitted. The method returns the current value for B<-compat>. 1363 1364=item B<clear_on_exit> ( [BOOLEAN] ) 1365 1366The B<-clear_on_exit> option will be set to the BOOLEAN value, unless 1367BOOLEAN is omitted. The method returns the current value for 1368B<-clear_on_exit>. 1369 1370=item B<color> ( ) 1371 1372Returns the currently used Curses::UI::Color object 1373 1374=item B<set_color> ( OBJECT ) 1375 1376Replaces the currently used Color object with another. This can be 1377used to fast change all colors in a Curses::UI application. 1378 1379=back 1380 1381 1382 1383=head1 SEE ALSO 1384 1385=over 1386 1387=item L<Curses> 1388 1389=item L<Curses::UI::POE> (a POE eventsystem and mainloop for Curses::UI) 1390 1391=item L<http://curses-ui.googlecode.com/> (SVN repo, info, and links) 1392 1393=back 1394 1395 1396=head1 BUGS 1397 1398Please report any bugs or feature requests to 1399C<bug-curses-ui@rt.cpan.org>, or through the web interface at 1400L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Curses-UI>. I will be 1401notified, and then you'll automatically be notified of progress on 1402your bug as I make changes. 1403 1404 1405=head1 AUTHOR 1406 1407Shawn Boyette C<< <mdxi@cpan.org> >> 1408 1409See the CREDITS file for additional information. 1410 1411=head1 COPYRIGHT & LICENSE 1412 1413Copyright 2001-2002 Maurice Makaay; 2003-2006 Marcus Thiesen; 2007, 14142008 Shawn Boyette. All Rights Reserved. 1415 1416This program is free software; you can redistribute it and/or modify 1417it under the same terms as Perl itself. 1418 1419This package is free software and is provided "as is" without express 1420or implied warranty. It may be used, redistributed and/or modified 1421under the same terms as perl itself. 1422 1423=cut 1424 1425 1426=head1 CLASS LISTING 1427 1428=head2 Widgets 1429 1430=over 1431 1432=item L<Curses::UI::Buttonbox> 1433 1434=item L<Curses::UI::Calendar> 1435 1436=item L<Curses::UI::Checkbox> 1437 1438=item L<Curses::UI::Label> 1439 1440=item L<Curses::UI::Listbox> 1441 1442=item L<Curses::UI::Menubar> 1443 1444=item L<Curses::UI::MenuListbox> (used by Curses::UI::Menubar) 1445 1446=item L<Curses::UI::Notebook> 1447 1448=item L<Curses::UI::PasswordEntry> 1449 1450=item L<Curses::UI::Popupmenu> 1451 1452=item L<Curses::UI::Progressbar> 1453 1454=item L<Curses::UI::Radiobuttonbox> 1455 1456=item L<Curses::UI::SearchEntry> (used by Curses::UI::Searchable) 1457 1458=item L<Curses::UI::TextEditor> 1459 1460=item L<Curses::UI::TextEntry> 1461 1462=item L<Curses::UI::TextViewer> 1463 1464=item L<Curses::UI::Window> 1465 1466=back 1467 1468=head2 Dialogs 1469 1470=over 1471 1472=item L<Curses::UI::Dialog::Basic> 1473 1474=item L<Curses::UI::Dialog::Error> 1475 1476=item L<Curses::UI::Dialog::Filebrowser> 1477 1478=item L<Curses::UI::Dialog::Status> 1479 1480=back 1481 1482=head2 Base and Support Classes 1483 1484=over 1485 1486=item L<Curses::UI::Widget> 1487 1488=item L<Curses::UI::Container> 1489 1490=item L<Curses::UI::Color> 1491 1492=item L<Curses::UI::Common> 1493 1494=item L<Curses::UI::Searchable> 1495 1496=back 1497 1498=cut 1499 15001; # end of Curses::UI 1501