Changeset 64 for trunk

Show
Ignore:
Timestamp:
05/03/08 20:32:00 (8 months ago)
Author:
scott
Message:

Updated Tests and Major Refactor
This has been a major refactoring of Curses::UI::POE to make it a lot more
palpable and easier to understand. I've fallen out of love with programming in
a big hash-ref.

Fixes:

  • Migrated to a object-states and a more OO approach.
  • Cleaned up the handling of modality so as to not be so dependent upon odd hash references, and the like.
  • Extended session interaction to allow Curses::UI::POE constructor to take more POE::Session options, including:
    • package_states
    • object_states
    • options
    • args
  • Updated tests so they're compatible with latest Curses::UI version…should probably remove language tests.
  • Updated session test so it does full regression to ensure session integration works.
  • Bumped version to 0.03
Location:
trunk/Curses-UI-POE
Files:
4 modified

Legend:

Unmodified
Added
Removed

  • trunk/Curses-UI-POE/POE.pm

    r13 r64  
    2424BEGIN { run POE::Kernel } 
    2525 
    26 *VERSION = \0.029; 
     26*VERSION = \0.03; 
    2727our $VERSION; 
    2828 
    … …  
    3131use constant ROOT => 0; 
    3232 
    33 my %ModalData; 
    34  
    3533sub import { 
    3634    my $caller = caller; 
    … …  
    4240} 
    4341 
    44 sub new {  
    45     my $RootObject = &Curses::UI::new(@_); 
    46     my ($class, %Options) = @_; 
    47  
    48     $Options{inline_states} ||= {}; 
     42# XXX We assume that there will never be two Curses::UI::POE sessions. 
     43my @modal_objects; 
     44my @modal_callbacks; 
     45 
     46# The session needed to make curses run in POE. 
     47sub new { 
     48    my ($type, %options) = @_; 
     49    my $self = bless &Curses::UI::new(@_), $type; 
     50 
     51    $self->{modal_objects}      = \@modal_objects; 
     52    $self->{modal_callbacks}    = \@modal_callbacks; 
     53    $self->{options}            = \%options; 
     54 
     55    # Default so we don't get a warning about using undef as an array. 
     56    $options{object_states}   ||= []; 
     57    $options{package_states}  ||= []; 
     58    $options{options}         ||= {}; 
    4959 
    5060    POE::Session->create 
    51         ( inline_states => { 
    52             %{ $Options{inline_states} }, 
    53  
    54             _start  => sub { 
    55                 $_[KERNEL]->select(\*STDIN, "-keyin"); 
    56  
    57                 # Turn blocking back on for STDIN.  Some Curses 
    58                 # implementations don't deal well with non-blocking STDIN. 
    59                 my $flags = fcntl STDIN, F_GETFL, 0 or die $!; 
    60                 fcntl STDIN, F_SETFL, $flags & ~O_NONBLOCK or die $!; 
    61  
    62                 $ModalData{$RootObject} = {Objects => [$RootObject], Callbacks => [undef]}; 
    63                 set_read_timeout($RootObject); 
    64  
    65                 $_[HEAP] = $RootObject; 
    66  
    67                 $Options{inline_states}{_start}(@_) 
    68                     if defined $Options{inline_states}{_start}; 
    69             }, 
    70  
    71             -keyin  => sub { 
    72                 $Curses::UI::rootobject = $_[HEAP]; 
    73                 my $modalObjects = $ModalData{$_[HEAP]}->{Objects}; 
    74                 my $modalCallbacks = $ModalData{$_[HEAP]}->{Callbacks}; 
    75                  
    76                 unless ($#$modalObjects) { 
    77                     $RootObject->do_one_event; 
    78                 } 
    79                 else { 
    80                     $$modalObjects[TOP]->root->do_one_event($$modalObjects[TOP]); 
    81                 } 
    82                 Curses::curs_set($$modalObjects[ROOT]->{-cursor_mode}); 
    83  
    84 #                if (my $key = $_[HEAP]->get_key(0)) { 
    85 #                    $RootObject->feedkey($key) unless $key eq '-1'; 
    86 #                    $RootObject->do_one_event; 
    87 #                } 
    88  
    89                  
    90                 # If this is a callback modal focus, and we lost modal focus, 
    91                 # do the callback. 
    92                 if (defined($$modalCallbacks[TOP]) && !$$modalObjects[TOP]->{-has_modal_focus} ) { 
    93                     $$modalObjects[TOP]->{-focus} = 0; 
    94                     pop @$modalObjects; 
    95                     my (@args) = @{pop @$modalCallbacks}; 
    96                      
    97                     # Invoke the callback. 
    98                     my ($sub) = shift(@args); 
    99                     &{$sub} (@args); 
    100                 } 
    101             }, 
    102  
    103             -timer  => sub { 
    104                 $Curses::UI::rootobject = $_[HEAP]; 
    105                 my $modalObjects = $ModalData{$_[HEAP]}->{Objects}; 
    106                 my $modalCallbacks = $ModalData{$_[HEAP]}->{Callbacks}; 
    107                 $$modalObjects[TOP]->do_timer; 
    108                 Curses::curs_set($$modalObjects[ROOT]->{-cursor_mode}); 
    109  
    110                 set_read_timeout($$modalObjects[TOP]); 
    111              
    112                 # If this is a callback modal focus, and we lost modal focus, 
    113                 # do the callback. 
    114                 if (defined($$modalCallbacks[TOP]) && !$$modalObjects[TOP]->{-has_modal_focus} ) { 
    115                     $$modalObjects[TOP]->{-focus} = 0; 
    116                     pop @$modalObjects; 
    117                     my ($cb) = pop @$modalCallbacks; 
    118                      
    119                     # Invoke the callback. 
    120                     my ($sub) = shift(@$cb); 
    121                     my (@args) = @$cb; 
    122                     &{$sub} (@args); 
    123                 } 
    124             }, 
    125  
    126             shutdown => sub { 
    127                 $_[KERNEL]->select(\*STDIN); 
    128             }, 
    129           }, 
    130  
    131           heap => $RootObject, 
    132         ); 
    133  
    134      $RootObject->{-no_output} = $Options{-no_output} || 0; 
    135  
    136      return $RootObject; 
     61        ( options        => $options{options}, 
     62          args           => $options{args}, 
     63          inline_states  => $options{inline_states}, 
     64          package_states => $options{package_states}, 
     65 
     66          object_states  => [ 
     67            @{ $options{object_states} }, 
     68            $self, [ qw( _start keyin timer shutdown ) ] 
     69          ], 
     70           
     71          # This is to maintain backward compatibility. 
     72          heap => $self ); 
     73 
     74    # Copy the no-output option 
     75    $self->{-no_output} = $options{no_output} || 0; 
     76 
     77    no warnings "redefine"; 
     78    # Redefine the callbackmodalfocus to ensure that callbacks and objects make 
     79    # it on to our own private stack. 
     80    sub Curses::UI::Widget::callbackmodalfocus { 
     81        my ($this, $cb) = @_; 
     82 
     83        # "Fake" focus for this object. 
     84        $this->{-has_modal_focus} = 1; 
     85        $this->focus; 
     86        $this->draw; 
     87 
     88        push @modal_objects, $this; 
     89 
     90        if (defined $cb) { 
     91            # They need a callback, so register it. 
     92            push @modal_callbacks, $cb; 
     93        } else { 
     94            # Push a null callback. 
     95            push @modal_callbacks, [sub { }]; 
     96        } 
     97 
     98        # We assume our callers are going to return immediately back to the 
     99        # main event loop, so we don't need a recursive call.        
     100        return; 
     101    } 
     102 
     103    # Let modalfocus() be a reentrant into the POE Kernel.  This is stackable, 
     104    # so it should not impact other behaviors, and POE keeps chugging along 
     105    # uneffected.  This is a modal focus without a callback, this method does 
     106    # not return until the modal widget get's cleared out. 
     107    sub Curses::UI::Widget::modalfocus () { 
     108        my ($this) = @_; 
     109 
     110        # "Fake" focus for this object. 
     111        $this->{-has_modal_focus} = 1; 
     112        $this->focus; 
     113        $this->draw; 
     114 
     115        push @modal_objects, $this; 
     116        push @modal_callbacks, undef; 
     117 
     118        # This is reentrant into the POE::Kernel  
     119        while ( $this->{-has_modal_focus} ) { 
     120            $poe_kernel->loop_do_timeslice; 
     121        } 
     122 
     123        $this->{-focus} = 0; 
     124 
     125        pop @modal_callbacks; 
     126        pop @modal_objects; 
     127 
     128        return $this; 
     129    } 
     130 
     131    return $self; 
     132} 
     133 
     134sub _start { 
     135    my ($self, $kernel) = @_[ OBJECT, KERNEL ]; 
     136 
     137    $kernel->select(\*STDIN, "-keyin"); 
     138 
     139    # Turn blocking back on for STDIN.  Some Curses 
     140    # implementations don't deal well with non-blocking STDIN. 
     141    my $flags = fcntl STDIN, F_GETFL, 0 or die $!; 
     142    fcntl STDIN, F_SETFL, $flags & ~O_NONBLOCK or die $!; 
     143 
     144    # This self reference is just so we can stack and peel onto the list of 
     145    # modal objects, and get to ourselves when we reach the top. 
     146    $self->{modal_objects} = [ $self ]; 
     147 
     148    set_read_timeout($self); 
     149 
     150    # Unmask... 
     151    $self->{options}{inline_states}{_start}(@_) 
     152        if (defined $self->{options}->{inline_states} && 
     153            defined $self->{options}{inline_states}{_start}); 
     154} 
     155 
     156sub _clear_modal_callback { 
     157    my ($self) = @_; 
     158 
     159    my $top_object = pop @{ $self->{_modal_objects} }; 
     160 
     161    # Reset focus 
     162    $top_object->{-focus} = 0; 
     163 
     164    # Dispatch callback. 
     165    my @args = @{ pop @{ $self->{_modal_callbacks} } }; 
     166    my ($sub) = shift @args; 
     167    &{$sub}(@args); 
     168} 
     169 
     170sub keyin { 
     171    my ($self, $kernel) = @_[ OBJECT, KERNEL ]; 
     172 
     173    my $top_object = $self->{modal_objects}->[TOP]; 
     174    # dispatch the event to the top-most modal object, or the root. 
     175    $top_object->root->do_one_event($top_object); 
     176 
     177    # Set the root cursor mode 
     178    Curses::curs_set($self->{-cursor_mode}); 
     179 
     180    _clear_modal_callback($self) unless $top_object->{-has_modal_focus}; 
     181} 
     182 
     183sub timer { 
     184    my ($self) = @_; 
     185 
     186    my $top_object = $self->{modal_objects}->[TOP]; 
     187    # dispatch the event to the top-most modal object, or the root. 
     188    $top_object->do_timer; 
     189 
     190    # Set the root cursor mode. 
     191    Curses::curs_set($self->{-cursor_mode}); 
     192 
     193    set_read_timeout($top_object); 
     194 
     195    _clear_modal_callback($self) unless $top_object->{-has_modal_focus}; 
     196} 
     197 
     198sub shutdown { 
     199    my ($kernel) = $_[ KERNEL ]; 
     200 
     201    # Unselect stdin 
     202    $kernel->select(\*STDIN); 
    137203} 
    138204 
    139205sub MainLoop {  
    140     my $modalObjects = $ModalData{$Curses::UI::rootobject}->{Objects}; 
    141     unless ($$modalObjects[TOP]) { 
    142         die "MailLoop: Curses::UI::rootobject not created."; 
     206    # When does this even happen!? 
     207    # I need more comments! 
     208    my $root = $Curses::UI::rootobject; 
     209    die "MainLoop: Must create a curses UI object first." unless defined $root; 
     210 
     211    # If some how we didn't get our object into the rootobject...redefine that 
     212    # bad boy. 
     213    if (ref $root ne __PACKAGE__) { 
     214        $root = bless $root, __PACKAGE__; 
     215        $Curses::UI::rootobject = $root; 
    143216    } 
    144217 
    145     $$modalObjects[TOP]->mainloop  
     218    $root->mainloop; 
    146219} 
    147220 
    148221sub mainloop { 
    149     my $this = shift; 
     222    my ($this) = @_; 
    150223 
    151224    $this->focus(undef, 1); 
    … …  
    176249 
    177250    return $this; 
    178 } 
    179  
    180 # Redefine the modalfocus loop because it sucks. 
    181 { 
    182     no warnings "redefine";  
    183     sub Curses::UI::Widget::modalfocus () { 
    184         my $this = shift; 
    185  
    186         # "Fake" focus for this object. 
    187         $this->{-has_modal_focus} = 1; 
    188         $this->focus; 
    189         $this->draw; 
    190  
    191         my $modalObjects = $ModalData{$Curses::UI::rootobject}->{Objects}; 
    192         my $modalCallbacks = $ModalData{$Curses::UI::rootobject}->{Callbacks}; 
    193         push @$modalObjects, $this; 
    194         push @$modalCallbacks, undef; 
    195  
    196         # This is reentrant into the POE::Kernel  
    197         while ( $this->{-has_modal_focus} ) { 
    198             $poe_kernel->loop_do_timeslice; 
    199         } 
    200  
    201         $this->{-focus} = 0; 
    202  
    203         pop @$modalCallbacks; 
    204         pop @$modalObjects; 
    205  
    206         return $this; 
    207     } 
    208  
    209  
    210     sub Curses::UI::Widget::callbackmodalfocus { 
    211         my $this = shift; 
    212         my ($cb) = shift; 
    213          
    214         # "Fake" focus for this object. 
    215         $this->{-has_modal_focus} = 1; 
    216         $this->focus; 
    217         $this->draw; 
    218  
    219         my $modalObjects = $ModalData{$Curses::UI::rootobject}->{Objects}; 
    220         my $modalCallbacks = $ModalData{$Curses::UI::rootobject}->{Callbacks}; 
    221         push @$modalObjects, $this; 
    222  
    223         if (defined $cb) { 
    224             # They need a callback, so register it. 
    225             push @$modalCallbacks, $cb; 
    226         } else { 
    227             # Push a null callback. 
    228             push @$modalCallbacks, [sub { }]; 
    229         } 
    230  
    231         # We assume our callers are going to return immediately back to the 
    232         # main event loop, so we don't need a recursive call.        
    233         return; 
    234     } 
    235251} 
    236252 

  • trunk/Curses-UI-POE/examples/demo-widgets

    r13 r64  
    871871# ---------------------------------------------------------------------- 
    872872 
    873 MainLoop; 
    874  
     873$cui->mainloop; 
     874 

  • trunk/Curses-UI-POE/t/language_classes.t

    r13 r64  
     1#!/usr/bin/perl 
    12use strict; 
    2 use Test::Simple tests => 12; 
     3use Test::Simple tests => 14; 
    34use File::Spec; 
    45use FindBin; 
    … …  
    1516 
    1617opendir DIR, "$filename" or die "Couldn't open language dir $filename: $!\n"; 
    17 my @entries = grep /.pm/, readdir(DIR); 
     18my @entries = grep /.pm$/, readdir(DIR); 
    1819 
    1920foreach my $file (@entries) { 

  • trunk/Curses-UI-POE/t/session.t

    r13 r64  
    66use warnings FATAL => "all"; 
    77 
    8 use Test::Simple tests => 1; 
    9 sub POE::Kernel::ASSERT_DEFAULT () { 1 } 
     8use Test::Simple tests => 4; 
     9 
     10# Trick Curses... 
     11BEGIN { 
     12    open OLDERR, ">&", \*STDERR; 
     13    open OLDOUT, ">&", \*STDOUT; 
     14    open STDOUT, ">>", "/dev/null"; 
     15    open STDERR, ">>", "/dev/null"; 
     16} 
     17 
     18#sub POE::Kernel::ASSERT_DEFAULT () { 1 } 
    1019use Curses::UI::POE; 
    1120 
    1221my $cui = new Curses::UI::POE inline_states => { 
    1322    _start => sub { 
     23        open STDOUT, ">>&=", \*OLDOUT; 
     24        open STDERR, ">>&=", \*OLDERR; 
     25 
    1426        ok("_start"); 
    15         exit; 
    1627 
    17         $_[KERNEL]->alias_set("TEST"); 
     28        $_[KERNEL]->yield("test"); 
    1829        $_[KERNEL]->yield("shutdown"); 
    19         $_[KERNEL]->yield("test"); 
    2030    }, 
    2131 
    … …  
    2636    _stop => sub { 
    2737        ok("_stop"); 
     38        open STDOUT, ">>", "/dev/null"; 
     39        open STDERR, ">>", "/dev/null"; 
    2840    }, 
    2941};