lire 2:2.1.1-2.1 / usr / share / perl5 / Lire / Test / CursesUIDriver.pm

package Lire::Test::CursesUIDriver;

use strict;

use Carp;
use Curses;
use Curses::UI;

use Lire::Utils qw/ check_param check_object_param /;

# item_index also exists in Curses
*lr_item_index = \&Lire::Utils::item_index;

=pod

=head1 NAME

Lire::Test::CursesUIDriver - Object that can be used to drive a Curses::UI interface

=head1 SYNOPSIS

 XXX

=head1 DESCRIPTION

 XXX

=cut

sub new {
    my $class = shift;

    return bless { '_event_loop_handlers' => [],
                   '_fatalerror_ref' => undef,
                   '_do_one_event_ref' => undef },
             $class;
}

sub setup_curses_ui {
    my $self = $_[0];

    $Curses::UI::rootobject       = undef;

    $Curses::UI::debug            = 0;
    $Curses::UI::screen_too_small = 0;
    $Curses::UI::initialized      = 0;
    $Curses::UI::color_support    = 0;
    $Curses::UI::color_object     = 0;

    $Curses::UI::ncurses_mouse    = 
      Curses->can('NCURSES_MOUSE_VERSION') && NCURSES_MOUSE_VERSION() >= 1;

    $self->{'_do_one_event_ref'} = \&Curses::UI::do_one_event;
    $self->{'_fatalerror_ref'} = \&Curses::UI::fatalerror;
    $self->{'_old_initscr'} = \&Curses::UI::initscr;
    {
        no warnings 'redefine';
        *Curses::UI::initscr = sub {};
        *Curses::UI::do_one_event = sub { $self->event_loop_dispatcher( @_ ) };
        *Curses::UI::fatalerror = \&fatalerror;
    }

    $self->{'term'}->delscreen()
      if ( $self->{'term'} );

    $self->{'term'} = newterm( undef, \*STDIN, \*STDOUT );
    def_prog_mode();

    return;
}

sub set_curses_ui {
     my ( $self, $ui ) = @_;

     check_object_param( $ui, 'ui', 'Curses::UI' );

     croak "you need to call teardown_curses_ui() before calling set_curses_ui() again"
       if defined $self->{'_ui'};

     $self->{'_ui'} = $ui;

     return;
}

sub teardown_curses_ui {
    my $self = $_[0];

    endwin();
    $self->{'_ui'} = undef;
    {
        no warnings 'redefine';
        *Curses::UI::initscr = $self->{'_old_initscr'};
        *Curses::UI::do_one_event = $self->{'_do_one_event_ref'};
        *Curses::UI::fatalerror = $self->{'_fatalerror_ref'};
    }

    return;
}

sub _find_menu {
    my ( $self, $menu_items, $menu_id ) = @_;

    foreach my $menu ( @{$menu_items} ) {
        return $menu
          if ( $menu->{'-label'} eq $menu_id );
    }

    return undef;
}

sub event_loop_dispatcher {
    my ( $self, $ui, $widget ) = @_;

    croak "no event loop handlers available in current CursesUIDriver"
      unless @{ $self->{'_event_loop_handlers'} };

    my $handler = shift @{ $self->{'_event_loop_handlers'} };
    $handler->( $ui, $widget );
    $widget->{'-has_modal_focus'} = 0
      if ( exists $widget->{'-has_modal_focus'} );

    return;
}

sub add_event_loop_handler {
    my ( $self, $handler ) = @_;

    check_param( $handler, 'handler' );
    croak "'handler' should be a CODE ref, not '$handler'"
      unless ( ref $handler eq 'CODE' );

    push @{ $self->{'_event_loop_handlers'} }, $handler;

    return;
}

sub fatalerror {
    croak @_;
}

sub find_menu_def {
    my ( $self, $menu_path ) = @_;

    croak "set_curses_ui() wasn't called"
      unless defined $self->{'_ui'};
    check_param( $menu_path, 'menu_path' );

    my ($mb_id, @path) = split '/', $menu_path;
    croak "'menu_path' should have at least 2 components"
      unless (@path);
    my $menubar = $self->{'_ui'}->getobj( $mb_id );
    croak "no '$mb_id' menubar"
      unless defined $menubar;

    my $menu_items = $menubar->{'-menu'};
    my $seen_menus = [ $mb_id ];
    my $current_menu;
    foreach my $menu_id ( @path ) {
        $current_menu = $self->_find_menu( $menu_items, $menu_id );
        unless ( defined $current_menu ) {
            croak (( @$seen_menus == 1 )
              ? "no '$menu_id' menu in '$mb_id' menubar"
              : "no '$menu_id' submenu in '"
                  . join ( '/', @$seen_menus ) . "' menu" );
        }
        push @$seen_menus, $menu_id;
        $menu_items = $current_menu->{'-submenu'};
    }

    return $current_menu;
}

sub activate_menu {
    my ( $self, $menu_path ) = @_;

    my $current_menu = $self->find_menu_def( $menu_path );
    my ($mb_id, @path) = split '/', $menu_path;
    my $menubar = $self->{'_ui'}->getobj( $mb_id );

    croak "no callback defined for '" . join ( '/', @path ) . "' in '$mb_id' menubar"
      unless ( defined $current_menu->{'-value'}
               && ( ref $current_menu->{'-value'} eq 'CODE' ) );
    $current_menu->{'-value'}->( $menubar );

    return;
}

sub top_window {
    my $self = $_[0];

    my $focused = $self->{'_ui'}->focus_path(-1);
    if ( $focused->isa( 'Curses::UI::Menubar' ) ) {
        my $mbar = $focused;
        $focused->loose_focus();
        $focused = $self->{'_ui'}->focus_path(-1);
        $mbar->focus();
    }

    return ( $focused->isa( 'Curses::UI::Window' )
             ? $focused
             : $focused->parentwindow() );
}

sub _widget_path {
    my ( $self, $widget ) = @_;

    my @path;
    while ( $widget ne $self->{'_ui'} ) {
        my $parent = $widget->parent();
        my $widget_id = $parent->{'-object2id'}{$widget};
        die "widget not linked to its container?"
          unless defined $widget_id;
        push @path, $widget_id;
        $widget = $parent;
    }

    return '/' . join( '/', reverse @path );
}

sub find_widget {
    my ( $self, $path ) = @_;

    check_param( $path, 'path' );

    return $self->{'_ui'}->focus_path(-1)
      if ( $path eq '.' );

    my @widgets = split '/', $path;
    my $widget;
    my $seen_path;

    if ( ! defined $widgets[0] || $widgets[0] eq '' ) {
        shift @widgets;
        $widget = $self->{'_ui'};
        $seen_path = '';
    } else {
        $widget = $self->top_window();
        $seen_path = $self->_widget_path( $widget );
    }

    foreach my $id ( @widgets ) {
        $widget = $widget->getobj( $id );
        croak "no widget '$id' in "
          . ( $seen_path ? "'$seen_path'" : "root" )
          . " container"
            unless defined $widget;
        $seen_path .= "/$id";
    }

    return $widget;
}

sub click_button {
    my ( $self, $path, $button ) = @_;

    check_param( $path, 'path' );
    check_param( $button, 'button' );

    my $button_box = $self->find_widget( $path );
    croak "'" . $self->_widget_path( $button_box ) . "' should be a Curses::UI::Buttonbox widget, not '$button_box'"
      unless $button_box->isa( 'Curses::UI::Buttonbox' );

    my $buttons = $button_box->{'-buttons'};
    my $button_idx;
    for ( my $idx = 0; $idx < @$buttons; $idx++ ) {
        if ( $buttons->[$idx]->{'-label'} eq $button ) {
            $button_idx = $idx;
            last;
        }
    }
    croak "no '$button' button in '" . $self->_widget_path( $button_box )
      . "' Buttonbox"
        unless defined $button_idx;

    $button_box->{'-selected'} = $button_idx;
    my $callback = $buttons->[$button_idx]->{'-onpress'};
    $callback->( $button_box )
      if ( defined $callback && ref $callback eq 'CODE' );

    return;
}

sub enter_text {
    my ( $self, $path, $text ) = @_;

    check_param( $path, 'path' );
    check_param( $text, 'text' );

    my $widget = $self->find_widget( $path );
    $widget->parent()->focus( $widget, 1 );
    foreach my $char ( split //, $text ) {
        $widget->event_keypress( $char );
    }

    return;
}

sub enter_key {
    my ( $self, $path, $char ) = @_;

    check_param( $path, 'path' );
    check_param( $char, 'char', qr/^([0-9]+|\w)$/,
                 "'char' should be either an integer or a single character" );

    my $widget = $self->find_widget( $path );
    $widget->parent()->focus( $widget, 1 );
    $widget->event_keypress( $char );

    return;
}

sub select_items {
    my ( $self, $path, @items ) = @_;

    check_param( $path, 'path' );
    croak "at least one 'item' parameter is required"
      unless @items;

    my $widget = $self->find_widget( $path );
    my $abs_path = $self->_widget_path( $widget );
    croak "'$abs_path' should be a Curses::UI::Listbox or Curses::UI::Popupmenu widget, not '$widget'"
      unless ( $widget->isa( 'Curses::UI::Listbox' )
               || $widget->isa( 'Curses::UI::Popupmenu' ) );
    croak "'$abs_path' doesn't support multi-selection"
      if ( @items > 1 && !$widget->{'-multi'} );

    my $selection = [];

    my $labels = $self->_widget_displayed_labels( $widget );
    foreach my $item ( @items ) {
        my $idx = lr_item_index( $labels, $item );
        croak "'$abs_path' doesn't have any '$item' item"
          unless defined $idx;
        push @$selection, $idx;
    }

    if ( $widget->isa( 'Curses::UI::Listbox' ) ) {
        $widget->set_selection( @$selection );
    } else {
        my $old_sel = $widget->{'-selected'};
        $widget->{'-selected'} = $selection->[0];
        $widget->run_event('-onchange')
          if ( ! defined $old_sel
               || $old_sel != $widget->{'-selected'} );
    }

    return;
}

sub _widget_displayed_labels {
    my ( $self, $widget ) = @_;

    return $widget->{'-values'} unless defined $widget->{'-labels'};

    my @labels = ();
    foreach my $val ( @{$widget->{'-values'}} ) {
        push @labels, ( defined $widget->{'-labels'}{$val}
                        ? $widget->{'-labels'}{$val}
                        : $val );
    }
    return \@labels;
}

sub DESTROY {
    my $self = $_[0];

    $self->{'term'}->delscreen()
      if ( $self->{'term'} );
}

1;

=pod

=head1 SEE ALSO

Curses::UI(3pm)

=head1 VERSION

$Id: CursesUIDriver.pm,v 1.15 2006/07/23 13:16:31 vanbaal Exp $

=head1 AUTHORS

Francis J. Lacoste <flacoste@logreport.org>
Wolfgang Sourdeau <wolfgang@logreport.org>

=head1 COPYRIGHT

Copyright (C) 2004 Stichting LogReport Foundation LogReport@LogReport.org

This file is part of Lire.

Lire is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program (see COPYING); if not, check with
http://www.gnu.org/copyleft/gpl.html. 

=cut