lib/App/CPAN2Pkg/Curses.pm

   1 #
   2 # This file is part of App::CPAN2Pkg.
   3 # Copyright (c) 2009 Jerome Quelin, all rights reserved.
   4 #
   5 # This program is free software; you can redistribute it and/or modify
   6 # it under the same terms as Perl itself.
   7 #
   8 #
   9
  10 package App::CPAN2Pkg::Curses;
  11
  12 use strict;
  13 use warnings;
  14
  15 use App::CPAN2Pkg;
  16 use Class::XSAccessor
  17     constructor => '_new',
  18     accessors   => {
  19         _current  => '_current',
  20         _lb       => '_listbox',
  21         _listbox  => '_listbox',
  22         _panes    => '_panes',
  23         _prereqs  => '_prereqs',
  24         _viewers  => '_viewers',
  25         _win      => '_win',
  26         _opts     => '_opts',
  27     };
  28 use Curses;
  29 use Curses::UI::Common;
  30 use Curses::UI::POE;
  31 use POE;
  32
  33
  34 #--
  35 # CONSTRUCTOR
  36
  37 sub spawn {
  38     my ($class, $opts) = @_;
  39
  40     # the userdata object
  41     my $self = $class->_new(
  42         _opts    => $opts,
  43         _panes   => {},
  44         _prereqs => {},
  45         _viewers => {},
  46     );
  47
  48     # the curses::ui object
  49     my $cui  = Curses::UI::POE->new(
  50         -color_support => 1,
  51         -userdata      => $self,
  52         inline_states  => {
  53             # public events
  54             append           => \&append,
  55             module_available => \&module_available,
  56             module_spawned   => \&module_spawned,
  57             prereqs          => \&prereqs,
  58             # inline states
  59             _start => \&_start,
  60             _stop  => sub { warn "_stop"; },
  61         },
  62     );
  63     return $cui;
  64 }
  65
  66
  67 #--
  68 # SUBS
  69
  70 # -- public events
  71
  72 sub append {
  73     my ($cui, $module, $line) = @_[HEAP, ARG0, ARG1];
  74     my $self = $cui->userdata;
  75
  76     my $name   = $module->name;
  77     my $viewer = $self->_viewers->{$name};
  78     my $text   = $viewer->text;
  79     $text .= $line;
  80     $viewer->text($text);
  81
  82     # forcing redraw if needed
  83     $viewer->draw if $self->_current eq $name;
  84 }
  85
  86 sub module_spawned {
  87     my ($k, $cui, $module) = @_[KERNEL, HEAP, ARG0];
  88     my $self = $cui->userdata;
  89
  90     my $name = $module->name;
  91
  92     # updating list of modules
  93     my $lb = $self->_listbox;
  94     my $values = $lb->values;
  95     push @$values, $module;
  96     $lb->add_labels( { $module => "- $name" } );
  97     $lb->values([ sort { $a->name cmp $b->name } @$values ]);
  98     $lb->draw;
  99
 100     # adding a new pane
 101     my $win = $self->_win;
 102     my $pane = $win->add(undef, 'Window');
 103
 104     # title
 105     $pane->add(
 106         undef, 'Label',
 107         -height => 1,
 108         -text   => $name,
 109     );
 110
 111     # prereqs
 112     my $text = 'Missing prereqs: ';
 113     my $a = $pane->add(
 114         undef, 'Label',
 115         '-y'    => 2,
 116         -width  => length($text),
 117         -height => 1,
 118         -text   => $text,
 119     );
 120     my $prereqs = $pane->add(
 121         undef, 'Label',
 122         -x      => length($text),
 123         '-y'    => 2,
 124         -height => 1,
 125     );
 126     $prereqs->text('unknown');
 127
 128     # viewer
 129     my $viewer = $pane->add(
 130         undef, 'TextViewer',
 131         '-y'        => 4,
 132         -text       => '',
 133         -vscrollbar => 1,
 134     );
 135
 136     #$self->_set_bindings($pane);
 137     #$self->_set_bindings($viewer);
 138
 139     # storing the new ui elements
 140     $self->_panes->{$name}   = $pane;
 141     $self->_prereqs->{$name} = $prereqs;
 142     $self->_viewers->{$name} = $viewer;
 143
 144     # forcing redraw if needed
 145     if ( not defined $self->_current ) {
 146         $self->_current($name);
 147         $win->draw;
 148         $viewer->draw;
 149         $viewer->focus;
 150     }
 151 }
 152
 153 sub module_available {
 154     my ($k, $cui, $module) = @_[KERNEL, HEAP, ARG0];
 155     my $self = $cui->userdata;
 156
 157     # update list of modules
 158     my $name = $module->name;
 159     my $lb = $self->_listbox;
 160     $lb->add_labels( { $module => "+ $name" } );
 161     $lb->draw;
 162 }
 163
 164 sub prereqs {
 165     my ($cui, $module, @prereqs) = @_[HEAP, ARG0..$#_];
 166     my $self = $cui->userdata;
 167
 168     my $name  = $module->name;
 169     my $label = $self->_prereqs->{$name};
 170     if ( @prereqs ) {
 171         $label->set_color_fg('red');
 172         $label->text(join ', ', sort @prereqs);
 173
 174     } else {
 175         $label->set_color_fg('green');
 176         $label->text('none');
 177     }
 178 }
 179
 180
 181 # -- poe inline states
 182
 183 sub _start {
 184     my ($k, $cui) = @_[KERNEL, HEAP];
 185     my $self = $cui->userdata;
 186
 187     $k->alias_set('ui');
 188     $self->_build_gui($cui);
 189
 190     my $opts = $self->_opts;
 191     App::CPAN2Pkg->spawn($opts);
 192 }
 193
 194
 195
 196 #--
 197 # METHODS
 198
 199 # -- gui events
 200
 201 sub _focus_to_listbox {
 202     my ($self) = @_;
 203
 204     my $lb = $self->_listbox;
 205     $lb->focus;
 206 }
 207
 208 sub _focus_to_viewer {
 209     my ($self) = @_;
 210
 211     #my $lb = $self->_listbox;
 212     $self->_win->focus;
 213 }
 214
 215
 216 sub _listbox_item_selected {
 217     my ($self) = @_;
 218
 219     my $lb = $self->_listbox;
 220     my $labels = $lb->labels;
 221     my $name   = substr $labels->{ $lb->get_active_value }, 2;
 222     $self->_current($name);
 223     $self->_viewers->{$name}->focus;
 224 }
 225
 226 # -- private methods
 227
 228 sub _build_gui {
 229     my ($self, $cui) = @_;
 230
 231     $self->_build_title($cui);
 232     $self->_build_queue($cui);
 233     $self->_build_right_window($cui);
 234     $self->_set_bindings($cui);
 235 }
 236
 237 sub _build_title {
 238     my ($self, $cui) = @_;
 239     my $title = 'cpan2pkg - generating native linux packages from cpan';
 240     my $tb = $cui->add(undef, 'Window', -height => 1);
 241     $tb->add(undef, 'Label', -bold=>1, -text=>$title);
 242 }
 243
 244 sub _build_queue {
 245     my ($self, $cui) = @_;
 246     my $win = $cui->add(undef, 'Window',
 247         qw/ -y 2 -width 40 -vscrollbar 1 -border 1 /,
 248     );
 249     my $list = $win->add(
 250         undef, 'Listbox',
 251         -onchange => sub { $self->_listbox_item_selected },
 252     );
 253     $list->set_binding( sub {$self->_focus_to_viewer}, CUI_TAB );
 254     $self->_listbox($list);
 255 }
 256
 257 sub _build_right_window {
 258     my ($self, $cui) = @_;
 259     my $win = $cui->add(undef, 'Window',
 260         qw/ -x 41 -y 2 -border 1 /,
 261     );
 262     $self->_win($win);
 263     #$self->_set_bindings($win);
 264 }
 265
 266 sub _set_bindings {
 267     my ($self, $widget) = @_;
 268     $widget->set_binding( sub{ die; }, "\cQ" );
 269     $widget->set_binding( sub {$self->_focus_to_listbox}, KEY_F(2) );
 270 }
 271
 272 1;
 273 __END__
 274
 275
 276 =head1 NAME
 277
 278 App::CPAN2Pkg::Curses - curses user interface for cpan2pkg
 279
 280
 281
 282 =head1 DESCRIPTION
 283
 284 C<App::CPAN2Pkg::Curses> implements a POE session driving a curses
 285 interface for C<cpan2pkg>.
 286
 287 It is spawned directly by C<cpan2pkg> (since C<Curses::UI::POE> is a bit
 288 special regarding the event loop), and is responsible for launching the
 289 application controller (see C<App::CPAN2Pkg>).
 290
 291
 292
 293 =head1 PUBLIC PACKAGE METHODS
 294
 295 =head2 my $cui = App::CPAN2Pkg->spawn( \%params )
 296
 297 This method will create a POE session responsible for creating the
 298 curses UI and reacting to it.
 299
 300 It will return a C<Curses::UI::POE> object.
 301
 302 You can tune the session by passing some arguments as a hash
 303 reference, where the hash keys are:
 304
 305 =over 4
 306
 307 =item * modules => \@list_of_modules
 308
 309 A list of modules to start packaging.
 310
 311
 312 =back
 313
 314
 315
 316 =head1 PUBLIC EVENTS ACCEPTED
 317
 318 The following events are the module's API.
 319
 320
 321 =head2 append( $module, $line )
 322
 323 Update the specific part of the ui devoluted to C<$module> with an
 324 additional C<$line>.
 325
 326
 327 =head2 module_available( $module )
 328
 329 Sent when C<$module> is available. Updating list of modules to reflect
 330 this new status.
 331
 332
 333 =head2 module_spawned( $module )
 334
 335 Sent when a new module has been requested to be packaged. The argment
 336 C<$module> is a C<App::CPAN2Pkg::Module> object with all the needed
 337 information.
 338
 339
 340 =head2 prereqs( $module, @prereqs )
 341
 342 Update the missing C<@prereqs> of C<$module> in the ui.
 343
 344
 345 =head1 SEE ALSO
 346
 347 For all related information (bug reporting, source code repository,
 348 etc.), refer to C<App::CPAN2Pkg>'s pod, section C<SEE ALSO>.
 349
 350
 351
 352 =head1 AUTHOR
 353
 354 Jerome Quelin, C<< <jquelin@cpan.org> >>
 355
 356
 357
 358 =head1 COPYRIGHT & LICENSE
 359
 360 Copyright (c) 2009 Jerome Quelin, all rights reserved.
 361
 362 This program is free software; you can redistribute it and/or modify
 363 it under the same terms as Perl itself.
 364
 365 =cut
 366